![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to format.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / f2c|
Return to format.c CVS log | Up to [Research Unix] / researchv10no / cmd / f2c |
1.1 root 1: /****************************************************************
2: Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories 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 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.
13:
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
21: this software.
22: ****************************************************************/
23:
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. */
27:
28: #include "defs.h"
29: #include "p1defs.h"
30: #include "format.h"
31: #include "output.h"
32: #include "names.h"
33: #include "iob.h"
34:
35: int c_output_line_length = DEF_C_LINE_LENGTH;
36:
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 */
42:
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(), do_p1_elseifstart();
53: static void do_p1_comment(), do_p1_set_line();
54: static expptr do_p1_addr();
55: static void proto();
56: void list_arg_types();
57: chainp length_comp();
58: void listargs();
59: extern chainp assigned_fmts;
60: static char filename[P1_FILENAME_MAX];
61: extern int gflag;
62: int gflag1;
63: extern char *parens;
64:
65: start_formatting ()
66: {
67: FILE *infile;
68: static int wrote_one = 0;
69: extern int usedefsforcommon;
70: extern char *p1_file, *p1_bakfile;
71:
72: this_proc_name[0] = '\0';
73: last_was_label = 0;
74: ei_next = ei_first;
75: wh_next = wh_first;
76:
77: (void) fclose (pass1_file);
78: if ((infile = fopen (p1_file, binread)) == NULL)
79: Fatal("start_formatting: couldn't open the intermediate file\n");
80:
81: if (wrote_one)
82: nice_printf (c_file, "\n");
83:
84: while (!feof (infile)) {
85: expptr this_expr;
86:
87: this_expr = do_format (infile, c_file);
88: if (this_expr) {
89: out_and_free_statement (c_file, this_expr);
90: } /* if this_expr */
91: } /* while !feof infile */
92:
93: (void) fclose (infile);
94:
95: if (last_was_label)
96: nice_printf (c_file, ";\n");
97:
98: prev_tab (c_file);
99: gflag1 = 0;
100: if (this_proc_name[0])
101: nice_printf (c_file, "} /* %s */\n", this_proc_name);
102:
103:
104: /* Write the #undefs for common variable reference */
105:
106: if (usedefsforcommon) {
107: Extsym *ext;
108: int did_one = 0;
109:
110: for (ext = extsymtab; ext < nextext; ext++)
111: if (ext -> extstg == STGCOMMON && ext -> used_here) {
112: ext -> used_here = 0;
113: if (!did_one)
114: nice_printf (c_file, "\n");
115: wr_abbrevs(c_file, 0, ext->extp);
116: did_one = 1;
117: ext -> extp = CHNULL;
118: } /* if */
119:
120: if (did_one)
121: nice_printf (c_file, "\n");
122: } /* if usedefsforcommon */
123:
124: other_undefs(c_file);
125:
126: wrote_one = 1;
127:
128: /* For debugging only */
129:
130: if (debugflag && (pass1_file = fopen (p1_bakfile, binwrite)))
131: if (infile = fopen (p1_file, binread)) {
132: ffilecopy (infile, pass1_file);
133: fclose (infile);
134: fclose (pass1_file);
135: } /* if infile */
136:
137: /* End of "debugging only" */
138:
139: scrub(p1_file); /* optionally unlink */
140:
141: if ((pass1_file = fopen (p1_file, binwrite)) == NULL)
142: err ("start_formatting: couldn't reopen the pass1 file");
143:
144: } /* start_formatting */
145:
146:
147: static void
148: put_semi(outfile)
149: FILE *outfile;
150: {
151: nice_printf (outfile, ";\n");
152: last_was_label = 0;
153: }
154:
155: #define SEM_CHECK(x) if (last_was_label) put_semi(x)
156:
157: /* do_format -- takes an input stream (a file in pass1 format) and writes
158: the appropriate C code to outfile when possible. When reading an
159: expression, the expression tree is returned instead. */
160:
161: static expptr do_format (infile, outfile)
162: FILE *infile, *outfile;
163: {
164: int token_type, was_c_token;
165: expptr retval = ENULL;
166:
167: token_type = get_p1_token (infile);
168: was_c_token = 1;
169: switch (token_type) {
170: case P1_COMMENT:
171: do_p1_comment (infile, outfile);
172: was_c_token = 0;
173: break;
174: case P1_SET_LINE:
175: do_p1_set_line (infile);
176: was_c_token = 0;
177: break;
178: case P1_FILENAME:
179: p1gets(infile, filename, P1_FILENAME_MAX);
180: was_c_token = 0;
181: break;
182: case P1_NAME_POINTER:
183: retval = do_p1_name_pointer (infile);
184: break;
185: case P1_CONST:
186: retval = do_p1_const (infile);
187: break;
188: case P1_EXPR:
189: retval = do_p1_expr (infile, outfile);
190: break;
191: case P1_IDENT:
192: retval = do_p1_ident(infile);
193: break;
194: case P1_CHARP:
195: retval = do_p1_charp(infile);
196: break;
197: case P1_EXTERN:
198: retval = do_p1_extern (infile);
199: break;
200: case P1_HEAD:
201: gflag1 = 0;
202: retval = do_p1_head (infile, outfile);
203: gflag1 = gflag;
204: break;
205: case P1_LIST:
206: retval = do_p1_list (infile, outfile);
207: break;
208: case P1_LITERAL:
209: retval = do_p1_literal (infile);
210: break;
211: case P1_LABEL:
212: do_p1_label (infile, outfile);
213: /* last_was_label = 1; -- now set in do_p1_label */
214: was_c_token = 0;
215: break;
216: case P1_ASGOTO:
217: do_p1_asgoto (infile, outfile);
218: break;
219: case P1_GOTO:
220: do_p1_goto (infile, outfile);
221: break;
222: case P1_IF:
223: do_p1_if (infile, outfile);
224: break;
225: case P1_ELSE:
226: SEM_CHECK(outfile);
227: do_p1_else (outfile);
228: break;
229: case P1_ELIF:
230: SEM_CHECK(outfile);
231: do_p1_elif (infile, outfile);
232: break;
233: case P1_ENDIF:
234: SEM_CHECK(outfile);
235: do_p1_endif (outfile);
236: break;
237: case P1_ENDELSE:
238: SEM_CHECK(outfile);
239: do_p1_endelse (outfile);
240: break;
241: case P1_ADDR:
242: retval = do_p1_addr (infile, outfile);
243: break;
244: case P1_SUBR_RET:
245: do_p1_subr_ret (infile, outfile);
246: break;
247: case P1_COMP_GOTO:
248: do_p1_comp_goto (infile, outfile);
249: break;
250: case P1_FOR:
251: do_p1_for (infile, outfile);
252: break;
253: case P1_ENDFOR:
254: SEM_CHECK(outfile);
255: do_p1_end_for (outfile);
256: break;
257: case P1_WHILE1START:
258: do_p1_1while(outfile);
259: break;
260: case P1_WHILE2START:
261: do_p1_2while(infile, outfile);
262: break;
263: case P1_PROCODE:
264: procode(outfile);
265: break;
266: case P1_ELSEIFSTART:
267: SEM_CHECK(outfile);
268: do_p1_elseifstart(outfile);
269: break;
270: case P1_FORTRAN:
271: do_p1_fortran(infile, outfile);
272: /* no break; */
273: case P1_EOF:
274: was_c_token = 0;
275: break;
276: case P1_UNKNOWN:
277: Fatal("do_format: Unknown token type in intermediate file");
278: break;
279: default:
280: Fatal("do_format: Bad token type in intermediate file");
281: break;
282: } /* switch */
283:
284: if (was_c_token)
285: last_was_label = 0;
286: return retval;
287: } /* do_format */
288:
289:
290: static void
291: do_p1_comment (infile, outfile)
292: FILE *infile, *outfile;
293: {
294: extern int c_output_line_length, in_comment;
295:
296: char storage[COMMENT_BUFFER_SIZE + 1];
297: int length;
298:
299: if (!p1gets(infile, storage, COMMENT_BUFFER_SIZE + 1))
300: return;
301:
302: length = strlen (storage);
303:
304: gflag1 = 0;
305: in_comment = 1;
306: if (length > c_output_line_length - 6)
307: margin_printf (outfile, "/*%s*/\n", storage);
308: else
309: margin_printf (outfile, length ? "/* %s */\n" : "\n", storage);
310: in_comment = 0;
311: gflag1 = gflag;
312: } /* do_p1_comment */
313:
314: static void
315: do_p1_set_line (infile)
316: FILE *infile;
317: {
318: int status;
319: long new_line_number = -1;
320:
321: status = p1getd (infile, &new_line_number);
322:
323: if (status == EOF)
324: err ("do_p1_set_line: Missing line number at end of file\n");
325: else if (status == 0 || new_line_number == -1)
326: errl("do_p1_set_line: Illegal line number in intermediate file: %ld\n",
327: new_line_number);
328: else {
329: lineno = new_line_number;
330: }
331: } /* do_p1_set_line */
332:
333:
334: static expptr do_p1_name_pointer (infile)
335: FILE *infile;
336: {
337: Namep namep = (Namep) NULL;
338: int status;
339:
340: status = p1getd (infile, (long *) &namep);
341:
342: if (status == EOF)
343: err ("do_p1_name_pointer: Missing pointer at end of file\n");
344: else if (status == 0 || namep == (Namep) NULL)
345: erri ("do_p1_name_pointer: Illegal name pointer in p1 file: '%x'\n",
346: (int) namep);
347:
348: return (expptr) namep;
349: } /* do_p1_name_pointer */
350:
351:
352:
353: static expptr do_p1_const (infile)
354: FILE *infile;
355: {
356: struct Constblock *c = (struct Constblock *) NULL;
357: long type = -1;
358: int status;
359:
360: status = p1getd (infile, &type);
361:
362: if (status == EOF)
363: err ("do_p1_const: Missing constant type at end of file\n");
364: else if (status == 0)
365: errl("do_p1_const: Illegal constant type in p1 file: %ld\n", type);
366: else {
367: status = p1get_const (infile, (int)type, &c);
368:
369: if (status == EOF) {
370: err ("do_p1_const: Missing constant value at end of file\n");
371: c = (struct Constblock *) NULL;
372: } else if (status == 0) {
373: err ("do_p1_const: Illegal constant value in p1 file\n");
374: c = (struct Constblock *) NULL;
375: } /* else */
376: } /* else */
377: return (expptr) c;
378: } /* do_p1_const */
379:
380:
381: static expptr do_p1_literal (infile)
382: FILE *infile;
383: {
384: int status;
385: long memno;
386: Addrp addrp;
387:
388: status = p1getd (infile, &memno);
389:
390: if (status == EOF)
391: err ("do_p1_literal: Missing memno at end of file");
392: else if (status == 0)
393: err ("do_p1_literal: Missing memno in p1 file");
394: else {
395: struct Literal *litp, *lastlit;
396:
397: addrp = ALLOC (Addrblock);
398: addrp -> tag = TADDR;
399: addrp -> vtype = TYUNKNOWN;
400: addrp -> Field = NULL;
401:
402: lastlit = litpool + nliterals;
403: for (litp = litpool; litp < lastlit; litp++)
404: if (litp -> litnum == memno) {
405: addrp -> vtype = litp -> littype;
406: *((union Constant *) &(addrp -> user)) =
407: *((union Constant *) &(litp -> litval));
408: break;
409: } /* if litp -> litnum == memno */
410:
411: addrp -> memno = memno;
412: addrp -> vstg = STGMEMNO;
413: addrp -> uname_tag = UNAM_CONST;
414: } /* else */
415:
416: return (expptr) addrp;
417: } /* do_p1_literal */
418:
419:
420: static void do_p1_label (infile, outfile)
421: FILE *infile, *outfile;
422: {
423: int status;
424: ftnint stateno;
425: char *user_label ();
426: struct Labelblock *L;
427: char *fmt;
428:
429: status = p1getd (infile, &stateno);
430:
431: if (status == EOF)
432: err ("do_p1_label: Missing label at end of file");
433: else if (status == 0)
434: err ("do_p1_label: Missing label in p1 file ");
435: else if (stateno < 0) { /* entry */
436: margin_printf(outfile, "\n%s:\n", user_label(stateno));
437: last_was_label = 1;
438: }
439: else {
440: L = labeltab + stateno;
441: if (L->labused) {
442: fmt = "%s:\n";
443: last_was_label = 1;
444: }
445: else
446: fmt = "/* %s: */\n";
447: margin_printf(outfile, fmt, user_label(L->stateno));
448: } /* else */
449: } /* do_p1_label */
450:
451:
452:
453: static void do_p1_asgoto (infile, outfile)
454: FILE *infile, *outfile;
455: {
456: expptr expr;
457:
458: expr = do_format (infile, outfile);
459: out_asgoto (outfile, expr);
460:
461: } /* do_p1_asgoto */
462:
463:
464: static void do_p1_goto (infile, outfile)
465: FILE *infile, *outfile;
466: {
467: int status;
468: long stateno;
469: char *user_label ();
470:
471: status = p1getd (infile, &stateno);
472:
473: if (status == EOF)
474: err ("do_p1_goto: Missing goto label at end of file");
475: else if (status == 0)
476: err ("do_p1_goto: Missing goto label in p1 file");
477: else {
478: nice_printf (outfile, "goto %s;\n", user_label (stateno));
479: } /* else */
480: } /* do_p1_goto */
481:
482:
483: static void do_p1_if (infile, outfile)
484: FILE *infile, *outfile;
485: {
486: expptr cond;
487:
488: do {
489: cond = do_format (infile, outfile);
490: } while (cond == ENULL);
491:
492: out_if (outfile, cond);
493: } /* do_p1_if */
494:
495:
496: static void do_p1_else (outfile)
497: FILE *outfile;
498: {
499: out_else (outfile);
500: } /* do_p1_else */
501:
502:
503: static void do_p1_elif (infile, outfile)
504: FILE *infile, *outfile;
505: {
506: expptr cond;
507:
508: do {
509: cond = do_format (infile, outfile);
510: } while (cond == ENULL);
511:
512: elif_out (outfile, cond);
513: } /* do_p1_elif */
514:
515: static void do_p1_endif (outfile)
516: FILE *outfile;
517: {
518: endif_out (outfile);
519: } /* do_p1_endif */
520:
521:
522: static void do_p1_endelse (outfile)
523: FILE *outfile;
524: {
525: end_else_out (outfile);
526: } /* do_p1_endelse */
527:
528:
529: static expptr do_p1_addr (infile, outfile)
530: FILE *infile, *outfile;
531: {
532: Addrp addrp = (Addrp) NULL;
533: int status;
534:
535: status = p1getn (infile, (int)sizeof(struct Addrblock), (char **) &addrp);
536:
537: if (status == EOF)
538: err ("do_p1_addr: Missing Addrp at end of file");
539: else if (status == 0)
540: err ("do_p1_addr: Missing Addrp in p1 file");
541: else if (addrp == (Addrp) NULL)
542: err ("do_p1_addr: Null addrp in p1 file");
543: else if (addrp -> tag != TADDR)
544: erri ("do_p1_addr: bad tag in p1 file '%d'", addrp -> tag);
545: else {
546: addrp -> vleng = do_format (infile, outfile);
547: addrp -> memoffset = do_format (infile, outfile);
548: }
549:
550: return (expptr) addrp;
551: } /* do_p1_addr */
552:
553:
554:
555: static void do_p1_subr_ret (infile, outfile)
556: FILE *infile, *outfile;
557: {
558: expptr retval;
559:
560: nice_printf (outfile, "return ");
561: retval = do_format (infile, outfile);
562: if (!multitype)
563: if (retval)
564: expr_out (outfile, retval);
565:
566: nice_printf (outfile, ";\n");
567: } /* do_p1_subr_ret */
568:
569:
570:
571: static void do_p1_comp_goto (infile, outfile)
572: FILE *infile, *outfile;
573: {
574: expptr index;
575: expptr labels;
576:
577: index = do_format (infile, outfile);
578:
579: if (index == ENULL) {
580: err ("do_p1_comp_goto: no expression for computed goto");
581: return;
582: } /* if index == ENULL */
583:
584: labels = do_format (infile, outfile);
585:
586: if (labels && labels -> tag != TLIST)
587: erri ("do_p1_comp_goto: expected list, got tag '%d'", labels -> tag);
588: else
589: compgoto_out (outfile, index, labels);
590: } /* do_p1_comp_goto */
591:
592:
593: static void do_p1_for (infile, outfile)
594: FILE *infile, *outfile;
595: {
596: expptr init, test, inc;
597:
598: init = do_format (infile, outfile);
599: test = do_format (infile, outfile);
600: inc = do_format (infile, outfile);
601:
602: out_for (outfile, init, test, inc);
603: } /* do_p1_for */
604:
605: static void do_p1_end_for (outfile)
606: FILE *outfile;
607: {
608: out_end_for (outfile);
609: } /* do_p1_end_for */
610:
611:
612: static void
613: do_p1_fortran(infile, outfile)
614: FILE *infile, *outfile;
615: {
616: char buf[P1_STMTBUFSIZE];
617: if (!p1gets(infile, buf, P1_STMTBUFSIZE))
618: return;
619: /* bypass nice_printf nonsense */
620: fprintf(outfile, "/*< %s >*/\n", buf+1); /* + 1 to skip by '$' */
621: }
622:
623:
624: static expptr do_p1_expr (infile, outfile)
625: FILE *infile, *outfile;
626: {
627: int status;
628: long opcode, type;
629: struct Exprblock *result = (struct Exprblock *) NULL;
630:
631: status = p1getd (infile, &opcode);
632:
633: if (status == EOF)
634: err ("do_p1_expr: Missing expr opcode at end of file");
635: else if (status == 0)
636: err ("do_p1_expr: Missing expr opcode in p1 file");
637: else {
638:
639: status = p1getd (infile, &type);
640:
641: if (status == EOF)
642: err ("do_p1_expr: Missing expr type at end of file");
643: else if (status == 0)
644: err ("do_p1_expr: Missing expr type in p1 file");
645: else if (opcode == 0)
646: return ENULL;
647: else {
648: result = ALLOC (Exprblock);
649:
650: result -> tag = TEXPR;
651: result -> vtype = type;
652: result -> opcode = opcode;
653: result -> vleng = do_format (infile, outfile);
654:
655: if (is_unary_op (opcode))
656: result -> leftp = do_format (infile, outfile);
657: else if (is_binary_op (opcode)) {
658: result -> leftp = do_format (infile, outfile);
659: result -> rightp = do_format (infile, outfile);
660: } else
661: errl("do_p1_expr: Illegal opcode %ld", opcode);
662: } /* else */
663: } /* else */
664:
665: return (expptr) result;
666: } /* do_p1_expr */
667:
668:
669: static expptr do_p1_ident(infile)
670: FILE *infile;
671: {
672: Addrp addrp;
673: int status;
674: long vtype, vstg;
675:
676: addrp = ALLOC (Addrblock);
677: addrp -> tag = TADDR;
678:
679: status = p1getd (infile, &vtype);
680: if (status == EOF)
681: err ("do_p1_ident: Missing identifier type at end of file\n");
682: else if (status == 0 || vtype < 0 || vtype >= NTYPES)
683: errl("do_p1_ident: Bad type in intermediate file: %ld\n", vtype);
684: else
685: addrp -> vtype = vtype;
686:
687: status = p1getd (infile, &vstg);
688: if (status == EOF)
689: err ("do_p1_ident: Missing identifier storage at end of file\n");
690: else if (status == 0 || vstg < 0 || vstg > STGNULL)
691: errl("do_p1_ident: Bad storage in intermediate file: %ld\n", vtype);
692: else
693: addrp -> vstg = vstg;
694:
695: status = p1gets(infile, addrp->user.ident, IDENT_LEN);
696:
697: if (status == EOF)
698: err ("do_p1_ident: Missing ident string at end of file");
699: else if (status == 0)
700: err ("do_p1_ident: Missing ident string in intermediate file");
701: addrp->uname_tag = UNAM_IDENT;
702: return (expptr) addrp;
703: } /* do_p1_ident */
704:
705: static expptr do_p1_charp(infile)
706: FILE *infile;
707: {
708: Addrp addrp;
709: int status;
710: long vtype, vstg;
711: char buf[64];
712:
713: addrp = ALLOC (Addrblock);
714: addrp -> tag = TADDR;
715:
716: status = p1getd (infile, &vtype);
717: if (status == EOF)
718: err ("do_p1_ident: Missing identifier type at end of file\n");
719: else if (status == 0 || vtype < 0 || vtype >= NTYPES)
720: errl("do_p1_ident: Bad type in intermediate file: %ld\n", vtype);
721: else
722: addrp -> vtype = vtype;
723:
724: status = p1getd (infile, &vstg);
725: if (status == EOF)
726: err ("do_p1_ident: Missing identifier storage at end of file\n");
727: else if (status == 0 || vstg < 0 || vstg > STGNULL)
728: errl("do_p1_ident: Bad storage in intermediate file: %ld\n", vtype);
729: else
730: addrp -> vstg = vstg;
731:
732: status = p1gets(infile, buf, (int)sizeof(buf));
733:
734: if (status == EOF)
735: err ("do_p1_ident: Missing charp ident string at end of file");
736: else if (status == 0)
737: err ("do_p1_ident: Missing charp ident string in intermediate file");
738: addrp->uname_tag = UNAM_CHARP;
739: addrp->user.Charp = strcpy(mem(strlen(buf)+1,0), buf);
740: return (expptr) addrp;
741: }
742:
743:
744: static expptr do_p1_extern (infile)
745: FILE *infile;
746: {
747: Addrp addrp;
748:
749: addrp = ALLOC (Addrblock);
750: if (addrp) {
751: int status;
752:
753: addrp->tag = TADDR;
754: addrp->vstg = STGEXT;
755: addrp->uname_tag = UNAM_EXTERN;
756: status = p1getd (infile, &(addrp -> memno));
757: if (status == EOF)
758: err ("do_p1_extern: Missing memno at end of file");
759: else if (status == 0)
760: err ("do_p1_extern: Missing memno in intermediate file");
761: if (addrp->vtype = extsymtab[addrp->memno].extype)
762: addrp->vclass = CLPROC;
763: } /* if addrp */
764:
765: return (expptr) addrp;
766: } /* do_p1_extern */
767:
768:
769:
770: static expptr do_p1_head (infile, outfile)
771: FILE *infile, *outfile;
772: {
773: int status;
774: int add_n_;
775: long class;
776: char storage[256];
777:
778: status = p1getd (infile, &class);
779: if (status == EOF)
780: err ("do_p1_head: missing header class at end of file");
781: else if (status == 0)
782: err ("do_p1_head: missing header class in p1 file");
783: else {
784: status = p1gets (infile, storage, (int)sizeof(storage));
785: if (status == EOF || status == 0)
786: storage[0] = '\0';
787: } /* else */
788:
789: if (class == CLPROC || class == CLMAIN) {
790: chainp lengths;
791:
792: add_n_ = nentry > 1;
793: lengths = length_comp(entries, add_n_);
794:
795: if (!add_n_ && protofile && class != CLMAIN)
796: protowrite(protofile, proctype, storage, entries, lengths);
797:
798: if (class == CLMAIN)
799: nice_printf (outfile, "/* Main program */ ");
800: else
801: nice_printf(outfile, "%s ", multitype ? "VOID"
802: : c_type_decl(proctype, 1));
803:
804: nice_printf(outfile, add_n_ ? "%s0_" : "%s", storage);
805: if (!Ansi) {
806: listargs(outfile, entries, add_n_, lengths);
807: nice_printf (outfile, "\n");
808: }
809: list_arg_types (outfile, entries, lengths, add_n_, "\n");
810: nice_printf (outfile, "{\n");
811: frchain(&lengths);
812: next_tab (outfile);
813: strcpy(this_proc_name, storage);
814: list_decls (outfile);
815:
816: } else if (class == CLBLOCK)
817: next_tab (outfile);
818: else
819: errl("do_p1_head: got class %ld", class);
820:
821: return NULL;
822: } /* do_p1_head */
823:
824:
825: static expptr do_p1_list (infile, outfile)
826: FILE *infile, *outfile;
827: {
828: long tag, type, count;
829: int status;
830: expptr result;
831:
832: status = p1getd (infile, &tag);
833: if (status == EOF)
834: err ("do_p1_list: missing list tag at end of file");
835: else if (status == 0)
836: err ("do_p1_list: missing list tag in p1 file");
837: else {
838: status = p1getd (infile, &type);
839: if (status == EOF)
840: err ("do_p1_list: missing list type at end of file");
841: else if (status == 0)
842: err ("do_p1_list: missing list type in p1 file");
843: else {
844: status = p1getd (infile, &count);
845: if (status == EOF)
846: err ("do_p1_list: missing count at end of file");
847: else if (status == 0)
848: err ("do_p1_list: missing count in p1 file");
849: } /* else */
850: } /* else */
851:
852: result = (expptr) ALLOC (Listblock);
853: if (result) {
854: chainp pointer;
855:
856: result -> tag = tag;
857: result -> listblock.vtype = type;
858:
859: /* Assume there will be enough data */
860:
861: if (count--) {
862: pointer = result->listblock.listp =
863: mkchain((char *)do_format(infile, outfile), CHNULL);
864: while (count--) {
865: pointer -> nextp =
866: mkchain((char *)do_format(infile, outfile), CHNULL);
867: pointer = pointer -> nextp;
868: } /* while (count--) */
869: } /* if (count) */
870: } /* if (result) */
871:
872: return result;
873: } /* do_p1_list */
874:
875:
876: chainp length_comp(e, add_n) /* get lengths of characters args */
877: struct Entrypoint *e;
878: int add_n;
879: {
880: chainp lengths;
881: chainp args, args1;
882: Namep arg, np;
883: int nchargs;
884: Argtypes *at;
885: Atype *a;
886: extern int init_ac[TYSUBR+1];
887:
888: if (!e)
889: return 0; /* possible only with errors */
890: args = args1 = add_n ? allargs : e->arglist;
891: nchargs = 0;
892: for (lengths = NULL; args; args = args -> nextp)
893: if (arg = (Namep)args->datap) {
894: if (arg->vclass == CLUNKNOWN)
895: arg->vclass = CLVAR;
896: if (arg->vtype == TYCHAR && arg->vclass != CLPROC) {
897: lengths = mkchain((char *)arg, lengths);
898: nchargs++;
899: }
900: }
901: if (!add_n && (np = e->enamep)) {
902: /* one last check -- by now we know all we ever will
903: * about external args...
904: */
905: save_argtypes(e->arglist, &e->entryname->arginfo,
906: &np->arginfo, 0, np->fvarname, STGEXT, nchargs,
907: np->vtype, 1);
908: at = e->entryname->arginfo;
909: a = at->atypes + init_ac[np->vtype];
910: for(; args1; a++, args1 = args1->nextp) {
911: frchain(&a->cp);
912: if (arg = (Namep)args1->datap)
913: switch(arg->vclass) {
914: case CLPROC:
915: if (arg->vimpltype
916: && a->type >= 300)
917: a->type = TYUNKNOWN + 200;
918: break;
919: case CLUNKNOWN:
920: a->type %= 100;
921: }
922: }
923: }
924: return revchain(lengths);
925: }
926:
927: void listargs(outfile, entryp, add_n_, lengths)
928: FILE *outfile;
929: struct Entrypoint *entryp;
930: int add_n_;
931: chainp lengths;
932: {
933: chainp args;
934: char *s;
935: Namep arg;
936: int did_one = 0;
937:
938: nice_printf (outfile, "(");
939:
940: if (add_n_) {
941: nice_printf(outfile, "n__");
942: did_one = 1;
943: args = allargs;
944: }
945: else {
946: if (!entryp)
947: return; /* possible only with errors */
948: args = entryp->arglist;
949: }
950:
951: if (multitype)
952: {
953: nice_printf(outfile, ", ret_val");
954: did_one = 1;
955: args = allargs;
956: }
957: else if (ONEOF(proctype, MSKCOMPLEX|MSKCHAR))
958: {
959: s = xretslot[proctype]->user.ident;
960: nice_printf(outfile, did_one ? ", %s" : "%s",
961: *s == '(' /*)*/ ? "r_v" : s);
962: did_one = 1;
963: if (proctype == TYCHAR)
964: nice_printf (outfile, ", ret_val_len");
965: }
966: for (; args; args = args -> nextp)
967: if (arg = (Namep)args->datap) {
968: nice_printf (outfile, "%s", did_one ? ", " : "");
969: out_name (outfile, arg);
970: did_one = 1;
971: }
972:
973: for (args = lengths; args; args = args -> nextp)
974: nice_printf(outfile, ", %s",
975: new_arg_length((Namep)args->datap));
976: nice_printf (outfile, ")");
977: } /* listargs */
978:
979:
980: void list_arg_types(outfile, entryp, lengths, add_n_, finalnl)
981: FILE *outfile;
982: struct Entrypoint *entryp;
983: chainp lengths;
984: int add_n_;
985: char *finalnl;
986: {
987: chainp args;
988: int last_type = -1, last_class = -1;
989: int did_one = 0, done_one, is_ext;
990: char *s, *sep = "", *sep1;
991:
992: if (outfile == (FILE *) NULL) {
993: err ("list_arg_types: null output file");
994: return;
995: } else if (entryp == (struct Entrypoint *) NULL) {
996: err ("list_arg_types: null procedure entry pointer");
997: return;
998: } /* else */
999:
1000: if (Ansi) {
1001: done_one = 0;
1002: sep1 = ", ";
1003: nice_printf(outfile, "(" /*)*/);
1004: }
1005: else {
1006: done_one = 1;
1007: sep1 = ";\n";
1008: }
1009: args = entryp->arglist;
1010: if (add_n_) {
1011: nice_printf(outfile, "int n__");
1012: did_one = done_one;
1013: sep = sep1;
1014: args = allargs;
1015: }
1016: if (multitype) {
1017: nice_printf(outfile, "%sMultitype *ret_val", sep);
1018: did_one = done_one;
1019: sep = sep1;
1020: }
1021: else if (ONEOF (proctype, MSKCOMPLEX|MSKCHAR)) {
1022: s = xretslot[proctype]->user.ident;
1023: nice_printf(outfile, "%s%s *%s", sep, c_type_decl(proctype, 0),
1024: *s == '(' /*)*/ ? "r_v" : s);
1025: did_one = done_one;
1026: sep = sep1;
1027: if (proctype == TYCHAR)
1028: nice_printf (outfile, "%sftnlen ret_val_len", sep);
1029: } /* if ONEOF proctype */
1030: for (; args; args = args -> nextp) {
1031: Namep arg = (Namep) args->datap;
1032:
1033: /* Scalars are passed by reference, and arrays will have their lower bound
1034: adjusted, so nearly everything is printed with a star in front. The
1035: exception is character lengths, which are passed by value. */
1036:
1037: if (arg) {
1038: int type = arg -> vtype, class = arg -> vclass;
1039:
1040: if (class == CLPROC)
1041: if (arg->vimpltype)
1042: type = Castargs ? TYUNKNOWN : TYSUBR;
1043: else if (type == TYREAL && forcedouble && !Castargs)
1044: type = TYDREAL;
1045:
1046: if (type == last_type && class == last_class && did_one)
1047: nice_printf (outfile, ", ");
1048: else
1049: if ((is_ext = class == CLPROC) && Castargs)
1050: nice_printf(outfile, "%s%s ", sep,
1051: usedcasts[type] = casttypes[type]);
1052: else
1053: nice_printf(outfile, "%s%s ", sep,
1054: c_type_decl(type, is_ext));
1055: if (class == CLPROC)
1056: if (Castargs)
1057: out_name(outfile, arg);
1058: else {
1059: nice_printf(outfile, "(*");
1060: out_name(outfile, arg);
1061: nice_printf(outfile, ") %s", parens);
1062: }
1063: else {
1064: nice_printf (outfile, "*");
1065: out_name (outfile, arg);
1066: }
1067:
1068: last_type = type;
1069: last_class = class;
1070: did_one = done_one;
1071: sep = sep1;
1072: } /* if (arg) */
1073: } /* for args = entryp -> arglist */
1074:
1075: for (args = lengths; args; args = args -> nextp)
1076: nice_printf(outfile, "%sftnlen %s", sep,
1077: new_arg_length((Namep)args->datap));
1078: if (did_one)
1079: nice_printf (outfile, ";\n");
1080: else if (Ansi)
1081: nice_printf(outfile,
1082: /*((*/ sep != sep1 && Ansi == 1 ? "void)%s" : ")%s",
1083: finalnl);
1084: } /* list_arg_types */
1085:
1086: static void
1087: write_formats(outfile)
1088: FILE *outfile;
1089: {
1090: register struct Labelblock *lp;
1091: int first = 1;
1092: char *fs;
1093:
1094: for(lp = labeltab ; lp < highlabtab ; ++lp)
1095: if (lp->fmtlabused) {
1096: if (first) {
1097: first = 0;
1098: nice_printf(outfile, "/* Format strings */\n");
1099: }
1100: nice_printf(outfile, "static char fmt_%ld[] = \"",
1101: lp->stateno);
1102: if (!(fs = lp->fmtstring))
1103: fs = "";
1104: nice_printf(outfile, "%s\";\n", fs);
1105: }
1106: if (!first)
1107: nice_printf(outfile, "\n");
1108: }
1109:
1110: static void
1111: write_ioblocks(outfile)
1112: FILE *outfile;
1113: {
1114: register iob_data *L;
1115: register char *f, **s, *sep;
1116:
1117: nice_printf(outfile, "/* Fortran I/O blocks */\n");
1118: L = iob_list = (iob_data *)revchain((chainp)iob_list);
1119: do {
1120: nice_printf(outfile, "static %s %s = { ",
1121: L->type, L->name);
1122: sep = 0;
1123: for(s = L->fields; f = *s; s++) {
1124: if (sep)
1125: nice_printf(outfile, sep);
1126: sep = ", ";
1127: if (*f == '"') { /* kludge */
1128: nice_printf(outfile, "\"");
1129: nice_printf(outfile, "%s\"", f+1);
1130: }
1131: else
1132: nice_printf(outfile, "%s", f);
1133: }
1134: nice_printf(outfile, " };\n");
1135: }
1136: while(L = L->next);
1137: nice_printf(outfile, "\n\n");
1138: }
1139:
1140: static void
1141: write_assigned_fmts(outfile)
1142: FILE *outfile;
1143: {
1144: register chainp cp;
1145: Namep np;
1146: int did_one = 0;
1147:
1148: cp = assigned_fmts = revchain(assigned_fmts);
1149: nice_printf(outfile, "/* Assigned format variables */\nchar ");
1150: do {
1151: np = (Namep)cp->datap;
1152: if (did_one)
1153: nice_printf(outfile, ", ");
1154: did_one = 1;
1155: nice_printf(outfile, "*%s_fmt", np->fvarname);
1156: }
1157: while(cp = cp->nextp);
1158: nice_printf(outfile, ";\n\n");
1159: }
1160:
1161: static char *
1162: to_upper(s)
1163: register char *s;
1164: {
1165: static char buf[64];
1166: register char *t = buf;
1167: register int c;
1168: while(*t++ = (c = *s++) >= 'a' && c <= 'z' ? c + 'A' - 'a' : c);
1169: return buf;
1170: }
1171:
1172:
1173: /* This routine creates static structures representing a namelist.
1174: Declarations of the namelist and related structures are:
1175:
1176: struct Vardesc {
1177: char *name;
1178: char *addr;
1179: ftnlen *dims; /* laid out as struct dimensions below *//*
1180: int type;
1181: };
1182: typedef struct Vardesc Vardesc;
1183:
1184: struct Namelist {
1185: char *name;
1186: Vardesc **vars;
1187: int nvars;
1188: };
1189:
1190: struct dimensions
1191: {
1192: ftnlen numberofdimensions;
1193: ftnlen numberofelements
1194: ftnlen baseoffset;
1195: ftnlen span[numberofdimensions-1];
1196: };
1197:
1198: If dims is not null, then the corner element of the array is at
1199: addr. However, the element with subscripts (i1,...,in) is at
1200: addr + sizeoftype * (i1+span[0]*(i2+span[1]*...) - dimp->baseoffset)
1201: */
1202:
1203: static void
1204: write_namelists(nmch, outfile)
1205: chainp nmch;
1206: FILE *outfile;
1207: {
1208: Namep var;
1209: struct Hashentry *entry;
1210: struct Dimblock *dimp;
1211: int i, nd, type;
1212: char *comma, *name;
1213: register chainp q;
1214: register Namep v;
1215: extern int typeconv[];
1216:
1217: nice_printf(outfile, "/* Namelist stuff */\n\n");
1218: for (entry = hashtab; entry < lasthash; ++entry) {
1219: if (!(v = entry->varp) || !v->vnamelist)
1220: continue;
1221: type = v->vtype;
1222: name = v->cvarname;
1223: if (dimp = v->vdim) {
1224: nd = dimp->ndim;
1225: nice_printf(outfile,
1226: "static ftnlen %s_dims[] = { %d, %ld, %ld",
1227: name, nd,
1228: dimp->nelt->constblock.Const.ci,
1229: dimp->baseoffset->constblock.Const.ci);
1230: for(i = 0, --nd; i < nd; i++)
1231: nice_printf(outfile, ", %ld",
1232: dimp->dims[i].dimsize->constblock.Const.ci);
1233: nice_printf(outfile, " };\n");
1234: }
1235: nice_printf(outfile, "static Vardesc %s_dv = { \"%s\", %s",
1236: name, to_upper(v->fvarname),
1237: type == TYCHAR ? ""
1238: : (dimp || oneof_stg(v,v->vstg,
1239: M(STGEQUIV)|M(STGCOMMON)))
1240: ? "(char *)" : "(char *)&");
1241: out_name(outfile, v);
1242: nice_printf(outfile, dimp ? ", %s_dims" : ", (ftnlen *)0", name);
1243: nice_printf(outfile, ", %ld };\n",
1244: type != TYCHAR ? (long)typeconv[type]
1245: : -v->vleng->constblock.Const.ci);
1246: }
1247:
1248: do {
1249: var = (Namep)nmch->datap;
1250: name = var->cvarname;
1251: nice_printf(outfile, "\nstatic Vardesc *%s_vl[] = ", name);
1252: comma = "{";
1253: i = 0;
1254: for(q = var->varxptr.namelist ; q ; q = q->nextp) {
1255: v = (Namep)q->datap;
1256: if (!v->vnamelist)
1257: continue;
1258: i++;
1259: nice_printf(outfile, "%s &%s_dv", comma, v->cvarname);
1260: comma = ",";
1261: }
1262: nice_printf(outfile, " };\n");
1263: nice_printf(outfile,
1264: "static Namelist %s = { \"%s\", %s_vl, %d };\n",
1265: name, to_upper(var->fvarname), name, i);
1266: }
1267: while(nmch = nmch->nextp);
1268: nice_printf(outfile, "\n");
1269: }
1270:
1271: /* fixextype tries to infer from usage in previous procedures
1272: the type of an external procedure declared
1273: external and passed as an argument but never typed or invoked.
1274: */
1275:
1276: static int
1277: fixexttype(var)
1278: Namep var;
1279: {
1280: Extsym *e;
1281: int type, type1;
1282: extern void changedtype();
1283:
1284: type = var->vtype;
1285: e = &extsymtab[var->vardesc.varno];
1286: if ((type1 = e->extype) && type == TYUNKNOWN)
1287: return var->vtype = type1;
1288: if (var->visused) {
1289: if (e->exused && type != type1)
1290: changedtype(var);
1291: e->exused = 1;
1292: e->extype = type;
1293: }
1294: return type;
1295: }
1296:
1297: static void
1298: ref_defs(outfile, refdefs) FILE *outfile; chainp refdefs;
1299: {
1300: chainp cp;
1301: int eb, i, j, n;
1302: struct Dimblock *dimp;
1303: long L;
1304: expptr b, vl;
1305: Namep var;
1306: char *amp, *comma;
1307:
1308: ind_printf(0, outfile, "\n");
1309: for(cp = refdefs = revchain(refdefs); cp; cp = cp->nextp) {
1310: var = (Namep)cp->datap;
1311: cp->datap = 0;
1312: amp = "_subscr";
1313: if (!(eb = var->vsubscrused)) {
1314: var->vrefused = 0;
1315: if (!ISCOMPLEX(var->vtype))
1316: amp = "_ref";
1317: }
1318: def_start(outfile, var->cvarname, amp, CNULL);
1319: dimp = var->vdim;
1320: vl = 0;
1321: comma = "(";
1322: amp = "";
1323: if (var->vtype == TYCHAR) {
1324: amp = "&";
1325: vl = var->vleng;
1326: if (ISCONST(vl) && vl->constblock.Const.ci == 1)
1327: vl = 0;
1328: nice_printf(outfile, "%sa_0", comma);
1329: comma = ",";
1330: }
1331: n = dimp->ndim;
1332: for(i = 1; i <= n; i++, comma = ",")
1333: nice_printf(outfile, "%sa_%d", comma, i);
1334: nice_printf(outfile, ") %s", amp);
1335: if (var->vsubscrused)
1336: var->vsubscrused = 0;
1337: else if (!ISCOMPLEX(var->vtype)) {
1338: out_name(outfile, var);
1339: nice_printf(outfile, "[%s", vl ? "(" : "");
1340: }
1341: for(j = 2; j < n; j++)
1342: nice_printf(outfile, "(");
1343: while(--i > 1) {
1344: nice_printf(outfile, "(a_%d)%s*", i, i == n ? "" : ")");
1345: expr_out(outfile, cpexpr(dimp->dims[i-2].dimsize));
1346: nice_printf(outfile, " + ");
1347: }
1348: nice_printf(outfile, "a_1");
1349: if (var->vtype == TYCHAR) {
1350: if (vl) {
1351: nice_printf(outfile, ")*");
1352: expr_out(outfile, cpexpr(vl));
1353: }
1354: nice_printf(outfile, " + a_0");
1355: }
1356: if (var->vstg != STGARG && (b = dimp->baseoffset)) {
1357: b = cpexpr(b);
1358: if (var->vtype == TYCHAR)
1359: b = mkexpr(OPSTAR, cpexpr(var->vleng), b);
1360: nice_printf(outfile, " - ");
1361: expr_out(outfile, b);
1362: }
1363: if (ISCOMPLEX(var->vtype)) {
1364: ind_printf(0, outfile, "\n");
1365: def_start(outfile, var->cvarname, "_ref", CNULL);
1366: comma = "(";
1367: for(i = 1; i <= n; i++, comma = ",")
1368: nice_printf(outfile, "%sa_%d", comma, i);
1369: nice_printf(outfile, ") %s[%s_subscr",
1370: var->cvarname, var->cvarname);
1371: comma = "(";
1372: for(i = 1; i <= n; i++, comma = ",")
1373: nice_printf(outfile, "%sa_%d", comma, i);
1374: nice_printf(outfile, ")");
1375: }
1376: ind_printf(0, outfile, "]\n" + eb);
1377: }
1378: nice_printf(outfile, "\n");
1379: frchain(refdefs);
1380: }
1381:
1382: list_decls (outfile)
1383: FILE *outfile;
1384: {
1385: extern chainp used_builtins;
1386: extern struct Hashentry *hashtab;
1387: extern ftnint wr_char_len();
1388: struct Hashentry *entry;
1389: int write_header = 1;
1390: int last_class = -1, last_stg = -1;
1391: Namep var;
1392: int Alias, Define, did_one, last_type, type;
1393: extern int def_equivs, useauto;
1394: extern chainp new_vars; /* Compiler-generated locals */
1395: chainp namelists = 0, refdefs = 0;
1396: char *ctype;
1397: int useauto1 = useauto && !saveall;
1398: long x;
1399: extern int hsize;
1400:
1401: /* First write out the statically initialized data */
1402:
1403: if (initfile)
1404: list_init_data(&initfile, initfname, outfile);
1405:
1406: /* Next come formats */
1407: write_formats(outfile);
1408:
1409: /* Now write out the system-generated identifiers */
1410:
1411: if (new_vars || nequiv) {
1412: chainp args, next_var, this_var;
1413: chainp nv[TYVOID], nv1[TYVOID];
1414: int i, j;
1415: Addrp Var;
1416: Namep arg;
1417:
1418: /* zap unused dimension variables */
1419:
1420: for(args = allargs; args; args = args->nextp) {
1421: arg = (Namep)args->datap;
1422: if (this_var = arg->vlastdim) {
1423: frexpr((tagptr)this_var->datap);
1424: this_var->datap = 0;
1425: }
1426: }
1427:
1428: /* sort new_vars by type, skipping entries just zapped */
1429:
1430: for(i = TYADDR; i < TYVOID; i++)
1431: nv[i] = 0;
1432: for(this_var = new_vars; this_var; this_var = next_var) {
1433: next_var = this_var->nextp;
1434: if (Var = (Addrp)this_var->datap) {
1435: if (!(this_var->nextp = nv[j = Var->vtype]))
1436: nv1[j] = this_var;
1437: nv[j] = this_var;
1438: }
1439: else {
1440: this_var->nextp = 0;
1441: frchain(&this_var);
1442: }
1443: }
1444: new_vars = 0;
1445: for(i = TYVOID; --i >= TYADDR;)
1446: if (this_var = nv[i]) {
1447: nv1[i]->nextp = new_vars;
1448: new_vars = this_var;
1449: }
1450:
1451: /* write the declarations */
1452:
1453: did_one = 0;
1454: last_type = -1;
1455:
1456: for (this_var = new_vars; this_var; this_var = this_var -> nextp) {
1457: Var = (Addrp) this_var->datap;
1458:
1459: if (Var == (Addrp) NULL)
1460: err ("list_decls: null variable");
1461: else if (Var -> tag != TADDR)
1462: erri ("list_decls: bad tag on new variable '%d'",
1463: Var -> tag);
1464:
1465: type = nv_type (Var);
1466: if (Var->vstg == STGINIT
1467: || Var->uname_tag == UNAM_IDENT
1468: && *Var->user.ident == ' '
1469: && multitype)
1470: continue;
1471: if (!did_one)
1472: nice_printf (outfile, "/* System generated locals */\n");
1473:
1474: if (last_type == type && did_one)
1475: nice_printf (outfile, ", ");
1476: else {
1477: if (did_one)
1478: nice_printf (outfile, ";\n");
1479: nice_printf (outfile, "%s ",
1480: c_type_decl (type, Var -> vclass == CLPROC));
1481: } /* else */
1482:
1483: /* Character type is really a string type. Put out a '*' for parameters
1484: with unknown length and functions returning character */
1485:
1486: if (Var -> vtype == TYCHAR && (!ISICON ((Var -> vleng))
1487: || Var -> vclass == CLPROC))
1488: nice_printf (outfile, "*");
1489:
1490: write_nv_ident(outfile, (Addrp)this_var->datap);
1491: if (Var -> vtype == TYCHAR && Var->vclass != CLPROC &&
1492: ISICON((Var -> vleng))
1493: && (i = Var->vleng->constblock.Const.ci) > 0)
1494: nice_printf (outfile, "[%d]", i);
1495:
1496: did_one = 1;
1497: last_type = nv_type (Var);
1498: } /* for this_var */
1499:
1500: /* Handle the uninitialized equivalences */
1501:
1502: do_uninit_equivs (outfile, &did_one);
1503:
1504: if (did_one)
1505: nice_printf (outfile, ";\n\n");
1506: } /* if new_vars */
1507:
1508: /* Write out builtin declarations */
1509:
1510: if (used_builtins) {
1511: chainp cp;
1512: Extsym *es;
1513:
1514: last_type = -1;
1515: did_one = 0;
1516:
1517: nice_printf (outfile, "/* Builtin functions */");
1518:
1519: for (cp = used_builtins; cp; cp = cp -> nextp) {
1520: Addrp e = (Addrp)cp->datap;
1521:
1522: switch(type = e->vtype) {
1523: case TYDREAL:
1524: case TYREAL:
1525: /* if (forcedouble || e->dbl_builtin) */
1526: /* libF77 currently assumes everything double */
1527: type = TYDREAL;
1528: ctype = "double";
1529: break;
1530: case TYCOMPLEX:
1531: case TYDCOMPLEX:
1532: type = TYVOID;
1533: /* no break */
1534: default:
1535: ctype = c_type_decl(type, 0);
1536: }
1537:
1538: if (did_one && last_type == type)
1539: nice_printf(outfile, ", ");
1540: else
1541: nice_printf(outfile, "%s\n%s ", did_one ? ";" : "", ctype);
1542:
1543: extern_out(outfile, es = &extsymtab[e -> memno]);
1544: proto(outfile, es->arginfo, es->fextname);
1545: last_type = type;
1546: did_one = 1;
1547: } /* for cp = used_builtins */
1548:
1549: nice_printf (outfile, ";\n\n");
1550: } /* if used_builtins */
1551:
1552: last_type = -1;
1553: for (entry = hashtab; entry < lasthash; ++entry) {
1554: var = entry -> varp;
1555:
1556: if (var) {
1557: int procclass = var -> vprocclass;
1558: char *comment = NULL;
1559: int stg = var -> vstg;
1560: int class = var -> vclass;
1561: type = var -> vtype;
1562:
1563: if (var->vrefused)
1564: refdefs = mkchain((char *)var, refdefs);
1565: if (var->vsubscrused)
1566: if (ISCOMPLEX(var->vtype))
1567: var->vsubscrused = 0;
1568: else
1569: refdefs = mkchain((char *)var, refdefs);
1570: if (ONEOF(stg, M(STGARG)|M(STGLENG)|M(STGINIT)))
1571: continue;
1572:
1573: if (useauto1 && stg == STGBSS && !var->vsave)
1574: stg = STGAUTO;
1575:
1576: switch (class) {
1577: case CLVAR:
1578: break;
1579: case CLPROC:
1580: switch(procclass) {
1581: case PTHISPROC:
1582: extsymtab[var->vardesc.varno].extype = type;
1583: continue;
1584: case PSTFUNCT:
1585: case PINTRINSIC:
1586: continue;
1587: case PUNKNOWN:
1588: err ("list_decls: unknown procedure class");
1589: continue;
1590: case PEXTERNAL:
1591: if (stg == STGUNKNOWN) {
1592: warn1(
1593: "%.64s declared EXTERNAL but never used.",
1594: var->fvarname);
1595: /* to retain names declared EXTERNAL */
1596: /* but not referenced, change
1597: /* "continue" to "stg = STGEXT" */
1598: continue;
1599: }
1600: else
1601: type = fixexttype(var);
1602: }
1603: break;
1604: case CLUNKNOWN:
1605: /* declared but never used */
1606: continue;
1607: case CLPARAM:
1608: continue;
1609: case CLNAMELIST:
1610: if (var->visused)
1611: namelists = mkchain((char *)var, namelists);
1612: continue;
1613: default:
1614: erri("list_decls: can't handle class '%d' yet",
1615: class);
1616: Fatal(var->fvarname);
1617: continue;
1618: } /* switch */
1619:
1620: /* Might be equivalenced to a common. If not, don't process */
1621: if (stg == STGCOMMON && !var->vcommequiv)
1622: continue;
1623:
1624: /* Only write the header if system-generated locals, builtins, or
1625: uninitialized equivs were already output */
1626:
1627: if (write_header == 1 && (new_vars || nequiv || used_builtins)
1628: && oneof_stg ( var, stg,
1629: M(STGBSS)|M(STGEXT)|M(STGAUTO)|M(STGCOMMON)|M(STGEQUIV))) {
1630: nice_printf (outfile, "/* Local variables */\n");
1631: write_header = 2;
1632: }
1633:
1634:
1635: Alias = oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON));
1636: if (Define = (Alias && def_equivs)) {
1637: if (!write_header)
1638: nice_printf(outfile, ";\n");
1639: def_start(outfile, var->cvarname, CNULL, "(");
1640: goto Alias1;
1641: }
1642: else if (type == last_type && class == last_class &&
1643: stg == last_stg && !write_header)
1644: nice_printf (outfile, ", ");
1645: else {
1646: if (!write_header && ONEOF(stg, M(STGBSS)|
1647: M(STGEXT)|M(STGAUTO)|M(STGEQUIV)|M(STGCOMMON)))
1648: nice_printf (outfile, ";\n");
1649:
1650: switch (stg) {
1651: case STGARG:
1652: case STGLENG:
1653: /* Part of the argument list, don't write them out
1654: again */
1655: continue; /* Go back to top of the loop */
1656: case STGBSS:
1657: case STGEQUIV:
1658: case STGCOMMON:
1659: nice_printf (outfile, "static ");
1660: break;
1661: case STGEXT:
1662: nice_printf (outfile, "extern ");
1663: break;
1664: case STGAUTO:
1665: break;
1666: case STGINIT:
1667: case STGUNKNOWN:
1668: /* Don't want to touch the initialized data, that will
1669: be handled elsewhere. Unknown data have
1670: already been complained about, so skip them */
1671: continue;
1672: default:
1673: erri("list_decls: can't handle storage class %d",
1674: stg);
1675: continue;
1676: } /* switch */
1677:
1678: if (type == TYCHAR && halign && class != CLPROC
1679: && ISICON(var->vleng)) {
1680: nice_printf(outfile, "struct { %s fill; char val",
1681: halign);
1682: x = wr_char_len(outfile, var->vdim,
1683: var->vleng->constblock.Const.ci, 1);
1684: if (x %= hsize)
1685: nice_printf(outfile, "; char fill2[%ld]",
1686: hsize - x);
1687: nice_printf(outfile, "; } %s_st;\n", var->cvarname);
1688: def_start(outfile, var->cvarname, CNULL, var->cvarname);
1689: ind_printf(0, outfile, "_st.val\n");
1690: last_type = -1;
1691: write_header = 2;
1692: continue;
1693: }
1694: nice_printf(outfile, "%s ",
1695: c_type_decl(type, class == CLPROC));
1696: } /* else */
1697:
1698: /* Character type is really a string type. Put out a '*' for variable
1699: length strings, and also for equivalences */
1700:
1701: if (type == TYCHAR && class != CLPROC
1702: && (!var->vleng || !ISICON (var -> vleng))
1703: || oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON)))
1704: nice_printf (outfile, "*%s", var->cvarname);
1705: else {
1706: nice_printf (outfile, "%s", var->cvarname);
1707: if (class == CLPROC) {
1708: Argtypes *at;
1709: if (!(at = var->arginfo)
1710: && var->vprocclass == PEXTERNAL)
1711: at = extsymtab[var->vardesc.varno].arginfo;
1712: proto(outfile, at, var->fvarname);
1713: }
1714: else if (type == TYCHAR && ISICON ((var -> vleng)))
1715: wr_char_len(outfile, var->vdim,
1716: (int)var->vleng->constblock.Const.ci, 0);
1717: else if (var -> vdim &&
1718: !oneof_stg (var, stg, M(STGEQUIV)|M(STGCOMMON)))
1719: comment = wr_ardecls(outfile, var->vdim, 1L);
1720: }
1721:
1722: if (comment)
1723: nice_printf (outfile, "%s", comment);
1724: Alias1:
1725: if (Alias) {
1726: char *amp, *lp, *name, *rp;
1727: char *equiv_name ();
1728: ftnint voff = var -> voffset;
1729: int et0, expr_type, k;
1730: Extsym *E;
1731: struct Equivblock *eb;
1732: char buf[16];
1733:
1734: /* We DON'T want to use oneof_stg here, because we need to distinguish
1735: between them */
1736:
1737: if (stg == STGEQUIV) {
1738: name = equiv_name(k = var->vardesc.varno, CNULL);
1739: eb = eqvclass + k;
1740: if (eb->eqvinit) {
1741: amp = "&";
1742: et0 = TYERROR;
1743: }
1744: else {
1745: amp = "";
1746: et0 = eb->eqvtype;
1747: }
1748: expr_type = et0;
1749: }
1750: else {
1751: E = &extsymtab[var->vardesc.varno];
1752: sprintf(name = buf, "%s%d", E->cextname, E->curno);
1753: expr_type = type;
1754: et0 = -1;
1755: amp = "&";
1756: } /* else */
1757:
1758: if (!Define)
1759: nice_printf (outfile, " = ");
1760: if (voff) {
1761: k = typesize[type];
1762: switch((int)(voff % k)) {
1763: case 0:
1764: voff /= k;
1765: expr_type = type;
1766: break;
1767: case SZSHORT:
1768: case SZSHORT+SZLONG:
1769: expr_type = TYSHORT;
1770: voff /= SZSHORT;
1771: break;
1772: case SZLONG:
1773: expr_type = TYLONG;
1774: voff /= SZLONG;
1775: break;
1776: default:
1777: expr_type = TYCHAR;
1778: }
1779: }
1780:
1781: if (expr_type == type) {
1782: lp = rp = "";
1783: if (et0 == -1 && !voff)
1784: goto cast;
1785: }
1786: else {
1787: lp = "(";
1788: rp = ")";
1789: cast:
1790: nice_printf(outfile, "(%s *)", c_type_decl(type, 0));
1791: }
1792:
1793: /* Now worry about computing the offset */
1794:
1795: if (voff) {
1796: if (expr_type == et0)
1797: nice_printf (outfile, "%s%s + %ld%s",
1798: lp, name, voff, rp);
1799: else
1800: nice_printf(outfile, "%s(%s *)%s%s + %ld%s", lp,
1801: c_type_decl (expr_type, 0), amp,
1802: name, voff, rp);
1803: } else
1804: nice_printf(outfile, "%s%s", amp, name);
1805: /* Always put these at the end of the line */
1806: last_type = last_class = last_stg = -1;
1807: write_header = 0;
1808: if (Define) {
1809: ind_printf(0, outfile, ")\n");
1810: write_header = 2;
1811: }
1812: continue;
1813: }
1814: write_header = 0;
1815: last_type = type;
1816: last_class = class;
1817: last_stg = stg;
1818: } /* if (var) */
1819: } /* for (entry = hashtab */
1820:
1821: if (!write_header)
1822: nice_printf (outfile, ";\n\n");
1823: else if (write_header == 2)
1824: nice_printf(outfile, "\n");
1825:
1826: /* Next, namelists, which may reference equivs */
1827:
1828: if (namelists) {
1829: write_namelists(namelists = revchain(namelists), outfile);
1830: frchain(&namelists);
1831: }
1832:
1833: /* Finally, ioblocks (which may reference equivs and namelists) */
1834: if (iob_list)
1835: write_ioblocks(outfile);
1836: if (assigned_fmts)
1837: write_assigned_fmts(outfile);
1838:
1839: if (refdefs)
1840: ref_defs(outfile, refdefs);
1841:
1842: } /* list_decls */
1843:
1844: do_uninit_equivs (outfile, did_one)
1845: FILE *outfile;
1846: int *did_one;
1847: {
1848: extern int nequiv;
1849: struct Equivblock *eqv, *lasteqv = eqvclass + nequiv;
1850: int k, last_type = -1, t;
1851:
1852: for (eqv = eqvclass; eqv < lasteqv; eqv++)
1853: if (!eqv -> eqvinit && eqv -> eqvtop != eqv -> eqvbottom) {
1854: if (!*did_one)
1855: nice_printf (outfile, "/* System generated locals */\n");
1856: t = eqv->eqvtype;
1857: if (last_type == t)
1858: nice_printf (outfile, ", ");
1859: else {
1860: if (*did_one)
1861: nice_printf (outfile, ";\n");
1862: nice_printf (outfile, "static %s ", c_type_decl(t, 0));
1863: k = typesize[t];
1864: } /* else */
1865: nice_printf(outfile, "%s", equiv_name((int)(eqv - eqvclass), CNULL));
1866: nice_printf(outfile, "[%ld]",
1867: (eqv->eqvtop - eqv->eqvbottom + k - 1) / k);
1868: last_type = t;
1869: *did_one = 1;
1870: } /* if !eqv -> eqvinit */
1871: } /* do_uninit_equivs */
1872:
1873:
1874: /* wr_ardecls -- Writes the brackets and size for an array
1875: declaration. Because of the inner workings of the compiler,
1876: multi-dimensional arrays get mapped directly into a one-dimensional
1877: array, so we have to compute the size of the array here. When the
1878: dimension is greater than 1, a string comment about the original size
1879: is returned */
1880:
1881: char *wr_ardecls(outfile, dimp, size)
1882: FILE *outfile;
1883: struct Dimblock *dimp;
1884: long size;
1885: {
1886: int i, k;
1887: static char buf[1000];
1888:
1889: if (dimp == (struct Dimblock *) NULL)
1890: return NULL;
1891:
1892: sprintf(buf, "\t/* was "); /* would like to say k = sprintf(...), but */
1893: k = strlen(buf); /* BSD doesn't return char transmitted count */
1894:
1895: for (i = 0; i < dimp -> ndim; i++) {
1896: expptr this_size = dimp -> dims[i].dimsize;
1897:
1898: if (!ISICON (this_size))
1899: err ("wr_ardecls: nonconstant array size");
1900: else {
1901: size *= this_size -> constblock.Const.ci;
1902: sprintf(buf+k, "[%ld]", this_size -> constblock.Const.ci);
1903: k += strlen(buf+k); /* BSD prevents combining this with prev stmt */
1904: } /* else */
1905: } /* for i = 0 */
1906:
1907: nice_printf (outfile, "[%ld]", size);
1908: strcat(buf+k, " */");
1909:
1910: return (i > 1) ? buf : NULL;
1911: } /* wr_ardecls */
1912:
1913:
1914:
1915: /* ----------------------------------------------------------------------
1916:
1917: The following routines read from the p1 intermediate file. If
1918: that format changes, only these routines need be changed
1919:
1920: ---------------------------------------------------------------------- */
1921:
1922: static int get_p1_token (infile)
1923: FILE *infile;
1924: {
1925: int token = P1_UNKNOWN;
1926:
1927: /* NOT PORTABLE!! */
1928:
1929: if (fscanf (infile, "%d", &token) == EOF)
1930: return P1_EOF;
1931:
1932: /* Skip over the ": " */
1933:
1934: if (getc (infile) != '\n')
1935: getc (infile);
1936:
1937: return token;
1938: } /* get_p1_token */
1939:
1940:
1941:
1942: /* Returns a (null terminated) string from the input file */
1943:
1944: static int p1gets (fp, str, size)
1945: FILE *fp;
1946: char *str;
1947: int size;
1948: {
1949: char *fgets ();
1950: char c;
1951:
1952: if (str == NULL)
1953: return 0;
1954:
1955: if ((c = getc (fp)) != ' ')
1956: ungetc (c, fp);
1957:
1958: if (fgets (str, size, fp)) {
1959: int length;
1960:
1961: str[size - 1] = '\0';
1962: length = strlen (str);
1963:
1964: /* Get rid of the newline */
1965:
1966: if (str[length - 1] == '\n')
1967: str[length - 1] = '\0';
1968: return 1;
1969:
1970: } else if (feof (fp))
1971: return EOF;
1972: else
1973: return 0;
1974: } /* p1gets */
1975:
1976:
1977: static int p1get_const (infile, type, resultp)
1978: FILE *infile;
1979: int type;
1980: struct Constblock **resultp;
1981: {
1982: int status;
1983: struct Constblock *result;
1984:
1985: if (type != TYCHAR) {
1986: *resultp = result = ALLOC(Constblock);
1987: result -> tag = TCONST;
1988: result -> vtype = type;
1989: }
1990:
1991: switch (type) {
1992: case TYINT1:
1993: case TYSHORT:
1994: case TYLONG:
1995: case TYLOGICAL:
1996: #ifdef TYQUAD
1997: case TYQUAD:
1998: #endif
1999: case TYLOGICAL1:
2000: case TYLOGICAL2:
2001: status = p1getd (infile, &(result -> Const.ci));
2002: break;
2003: case TYREAL:
2004: case TYDREAL:
2005: status = p1getf(infile, &result->Const.cds[0]);
2006: result->vstg = 1;
2007: break;
2008: case TYCOMPLEX:
2009: case TYDCOMPLEX:
2010: status = p1getf(infile, &result->Const.cds[0]);
2011: if (status && status != EOF)
2012: status = p1getf(infile, &result->Const.cds[1]);
2013: result->vstg = 1;
2014: break;
2015: case TYCHAR:
2016: status = fscanf(infile, "%lx", resultp);
2017: break;
2018: default:
2019: erri ("p1get_const: bad constant type '%d'", type);
2020: status = 0;
2021: break;
2022: } /* switch */
2023:
2024: return status;
2025: } /* p1get_const */
2026:
2027: static int p1getd (infile, result)
2028: FILE *infile;
2029: long *result;
2030: {
2031: return fscanf (infile, "%ld", result);
2032: } /* p1getd */
2033:
2034: static int
2035: p1getf(infile, result)
2036: FILE *infile;
2037: char **result;
2038: {
2039:
2040: char buf[1324];
2041: register int k;
2042:
2043: k = fscanf (infile, "%s", buf);
2044: if (k < 1)
2045: k = EOF;
2046: else
2047: strcpy(*result = mem(strlen(buf)+1,0), buf);
2048: return k;
2049: }
2050:
2051: static int p1getn (infile, count, result)
2052: FILE *infile;
2053: int count;
2054: char **result;
2055: {
2056:
2057: char *bufptr;
2058: extern ptr ckalloc ();
2059:
2060: bufptr = (char *) ckalloc (count);
2061:
2062: if (result)
2063: *result = bufptr;
2064:
2065: for (; !feof (infile) && count > 0; count--)
2066: *bufptr++ = getc (infile);
2067:
2068: return feof (infile) ? EOF : 1;
2069: } /* p1getn */
2070:
2071: static void
2072: proto(outfile, at, fname)
2073: FILE *outfile;
2074: Argtypes *at;
2075: char *fname;
2076: {
2077: int i, j, k, n;
2078: char *comma;
2079: Atype *atypes;
2080: Namep np;
2081: chainp cp;
2082: extern void bad_atypes();
2083:
2084: if (at) {
2085: /* Correct types that we learn on the fly, e.g.
2086: subroutine gotcha(foo)
2087: external foo
2088: call zap(...,foo,...)
2089: call foo(...)
2090: */
2091: atypes = at->atypes;
2092: n = at->defined ? at->dnargs : at->nargs;
2093: for(i = 0; i++ < n; atypes++) {
2094: if (!(cp = atypes->cp))
2095: continue;
2096: j = atypes->type;
2097: do {
2098: np = (Namep)cp->datap;
2099: k = np->vtype;
2100: if (np->vclass == CLPROC) {
2101: if (!np->vimpltype && k)
2102: k += 200;
2103: else {
2104: if (j >= 300)
2105: j = TYUNKNOWN + 200;
2106: continue;
2107: }
2108: }
2109: if (j == k)
2110: continue;
2111: if (j >= 300
2112: || j == 200 && k >= 200)
2113: j = k;
2114: else {
2115: if (at->nargs >= 0)
2116: bad_atypes(at,fname,i,j,k,""," and");
2117: goto break2;
2118: }
2119: }
2120: while(cp = cp->nextp);
2121: atypes->type = j;
2122: frchain(&atypes->cp);
2123: }
2124: }
2125: break2:
2126: if (parens) {
2127: nice_printf(outfile, parens);
2128: return;
2129: }
2130:
2131: if (!at || (n = at-> defined ? at->dnargs : at->nargs) < 0) {
2132: nice_printf(outfile, Ansi == 1 ? "()" : "(...)");
2133: return;
2134: }
2135:
2136: if (n == 0) {
2137: nice_printf(outfile, Ansi == 1 ? "(void)" : "()");
2138: return;
2139: }
2140:
2141: atypes = at->atypes;
2142: nice_printf(outfile, "(");
2143: comma = "";
2144: for(; --n >= 0; atypes++) {
2145: k = atypes->type;
2146: if (k == TYADDR)
2147: nice_printf(outfile, "%schar **", comma);
2148: else if (k >= 200) {
2149: k -= 200;
2150: nice_printf(outfile, "%s%s", comma,
2151: usedcasts[k] = casttypes[k]);
2152: }
2153: else if (k >= 100)
2154: nice_printf(outfile,
2155: k == TYCHAR + 100 ? "%s%s *" : "%s%s",
2156: comma, c_type_decl(k-100, 0));
2157: else
2158: nice_printf(outfile, "%s%s *", comma,
2159: c_type_decl(k, 0));
2160: comma = ", ";
2161: }
2162: nice_printf(outfile, ")");
2163: }
2164:
2165: void
2166: protowrite(protofile, type, name, e, lengths)
2167: FILE *protofile;
2168: char *name;
2169: struct Entrypoint *e;
2170: chainp lengths;
2171: {
2172: extern char used_rets[];
2173: int asave;
2174:
2175: if (!(asave = Ansi))
2176: Castargs = Ansi = 1;
2177: nice_printf(protofile, "extern %s %s", protorettypes[type], name);
2178: list_arg_types(protofile, e, lengths, 0, ";\n");
2179: used_rets[type] = 1;
2180: if (!(Ansi = asave))
2181: Castargs = 0;
2182: }
2183:
2184: static void
2185: do_p1_1while(outfile)
2186: FILE *outfile;
2187: {
2188: if (*wh_next) {
2189: nice_printf(outfile,
2190: "for(;;) { /* while(complicated condition) */\n" /*}*/ );
2191: next_tab(outfile);
2192: }
2193: else
2194: nice_printf(outfile, "while(" /*)*/ );
2195: }
2196:
2197: static void
2198: do_p1_2while(infile, outfile)
2199: FILE *infile, *outfile;
2200: {
2201: expptr test;
2202:
2203: test = do_format(infile, outfile);
2204: if (*wh_next)
2205: nice_printf(outfile, "if (!(");
2206: expr_out(outfile, test);
2207: if (*wh_next++)
2208: nice_printf(outfile, "))\n\tbreak;\n");
2209: else {
2210: nice_printf(outfile, /*(*/ ") {\n");
2211: next_tab(outfile);
2212: }
2213: }
2214:
2215: static void
2216: do_p1_elseifstart(outfile)
2217: FILE *outfile;
2218: {
2219: if (*ei_next++) {
2220: prev_tab(outfile);
2221: nice_printf(outfile, /*{*/
2222: "} else /* if(complicated condition) */ {\n" /*}*/ );
2223: next_tab(outfile);
2224: }
2225: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.