![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to p1output.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 p1output.c CVS log | Up to [Research Unix] / researchv10no / cmd / f2c |
1.1 root 1: /****************************************************************
2: Copyright 1990, 1991, 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: #include "defs.h"
25: #include "p1defs.h"
26: #include "output.h"
27: #include "names.h"
28:
29:
30: static void p1_addr(), p1_big_addr(), p1_binary(), p1_const(), p1_list(),
31: p1_literal(), p1_name(), p1_unary(), p1putn();
32: static void p1putd (/* int, int */);
33: static void p1putds (/* int, int, char * */);
34: static void p1putdds (/* int, int, int, char * */);
35: static void p1putdd (/* int, int, int */);
36: static void p1putddd (/* int, int, int, int */);
37:
38:
39: /* p1_comment -- save the text of a Fortran comment in the intermediate
40: file. Make sure that there are no spurious "/ *" or "* /" characters by
41: mapping them onto "/+" and "+/". str is assumed to hold no newlines and be
42: null terminated; it may be modified by this function. */
43:
44: void p1_comment (str)
45: char *str;
46: {
47: register unsigned char *pointer, *ustr;
48:
49: if (!str)
50: return;
51:
52: /* Get rid of any open or close comment combinations that may be in the
53: Fortran input */
54:
55: ustr = (unsigned char *)str;
56: for(pointer = ustr; *pointer; pointer++)
57: if (*pointer == '*' && (pointer[1] == '/'
58: || pointer > ustr && pointer[-1] == '/'))
59: *pointer = '+';
60: /* trim trailing white space */
61: #ifdef isascii
62: while(--pointer >= ustr && (!isascii(*pointer) || isspace(*pointer)));
63: #else
64: while(--pointer >= ustr && isspace(*pointer));
65: #endif
66: pointer[1] = 0;
67: p1puts (P1_COMMENT, str);
68: } /* p1_comment */
69:
70: void p1_line_number (line_number)
71: long line_number;
72: {
73:
74: p1putd (P1_SET_LINE, line_number);
75: } /* p1_line_number */
76:
77: /* p1_name -- Writes the address of a hash table entry into the
78: intermediate file */
79:
80: static void p1_name (namep)
81: Namep namep;
82: {
83: p1putd (P1_NAME_POINTER, (long) namep);
84: namep->visused = 1;
85: } /* p1_name */
86:
87:
88:
89: void p1_expr (expr)
90: expptr expr;
91: {
92: /* An opcode of 0 means a null entry */
93:
94: if (expr == ENULL) {
95: p1putdd (P1_EXPR, 0, TYUNKNOWN); /* Should this be TYERROR? */
96: return;
97: } /* if (expr == ENULL) */
98:
99: switch (expr -> tag) {
100: case TNAME:
101: p1_name ((Namep) expr);
102: return;
103: case TCONST:
104: p1_const(&expr->constblock);
105: return;
106: case TEXPR:
107: /* Fall through the switch */
108: break;
109: case TADDR:
110: p1_addr (&(expr -> addrblock));
111: goto freeup;
112: case TPRIM:
113: warn ("p1_expr: got TPRIM");
114: return;
115: case TLIST:
116: p1_list (&(expr->listblock));
117: frchain( &(expr->listblock.listp) );
118: return;
119: case TERROR:
120: return;
121: default:
122: erri ("p1_expr: bad tag '%d'", (int) (expr -> tag));
123: return;
124: }
125:
126: /* Now we know that the tag is TEXPR */
127:
128: if (is_unary_op (expr -> exprblock.opcode))
129: p1_unary (&(expr -> exprblock));
130: else if (is_binary_op (expr -> exprblock.opcode))
131: p1_binary (&(expr -> exprblock));
132: else
133: erri ("p1_expr: bad opcode '%d'", (int) expr -> exprblock.opcode);
134: freeup:
135: free((char *)expr);
136:
137: } /* p1_expr */
138:
139:
140:
141: static void p1_const(cp)
142: register Constp cp;
143: {
144: int type = cp->vtype;
145: expptr vleng = cp->vleng;
146: union Constant *c = &cp->Const;
147: char cdsbuf0[64], cdsbuf1[64];
148: char *cds0, *cds1;
149:
150: switch (type) {
151: case TYINT1:
152: case TYSHORT:
153: case TYLONG:
154: #ifdef TYQUAD
155: case TYQUAD:
156: #endif
157: case TYLOGICAL:
158: case TYLOGICAL1:
159: case TYLOGICAL2:
160: fprintf(pass1_file, "%d: %d %ld\n", P1_CONST, type, c->ci);
161: break;
162: case TYREAL:
163: case TYDREAL:
164: fprintf(pass1_file, "%d: %d %s\n", P1_CONST, type,
165: cp->vstg ? c->cds[0] : cds(dtos(c->cd[0]), cdsbuf0));
166: break;
167: case TYCOMPLEX:
168: case TYDCOMPLEX:
169: if (cp->vstg) {
170: cds0 = c->cds[0];
171: cds1 = c->cds[1];
172: }
173: else {
174: cds0 = cds(dtos(c->cd[0]), cdsbuf0);
175: cds1 = cds(dtos(c->cd[1]), cdsbuf1);
176: }
177: fprintf(pass1_file, "%d: %d %s %s\n", P1_CONST, type,
178: cds0, cds1);
179: break;
180: case TYCHAR:
181: if (vleng && !ISICON (vleng))
182: erri("p1_const: bad vleng '%d'\n", (int) vleng);
183: else
184: fprintf(pass1_file, "%d: %d %lx\n", P1_CONST, type,
185: cpexpr((expptr)cp));
186: break;
187: default:
188: erri ("p1_const: bad constant type '%d'", type);
189: break;
190: } /* switch */
191: } /* p1_const */
192:
193:
194: void p1_asgoto (addrp)
195: Addrp addrp;
196: {
197: p1put (P1_ASGOTO);
198: p1_addr (addrp);
199: } /* p1_asgoto */
200:
201:
202: void p1_goto (stateno)
203: ftnint stateno;
204: {
205: p1putd (P1_GOTO, stateno);
206: } /* p1_goto */
207:
208:
209: static void p1_addr (addrp)
210: register struct Addrblock *addrp;
211: {
212: int stg;
213:
214: if (addrp == (struct Addrblock *) NULL)
215: return;
216:
217: stg = addrp -> vstg;
218:
219: if (ONEOF(stg, M(STGINIT)|M(STGREG))
220: || ONEOF(stg, M(STGCOMMON)|M(STGEQUIV)) &&
221: (!ISICON(addrp->memoffset)
222: || (addrp->uname_tag == UNAM_NAME
223: ? addrp->memoffset->constblock.Const.ci
224: != addrp->user.name->voffset
225: : addrp->memoffset->constblock.Const.ci))
226: || ONEOF(stg, M(STGBSS)|M(STGINIT)|M(STGAUTO)|M(STGARG)) &&
227: (!ISICON(addrp->memoffset)
228: || addrp->memoffset->constblock.Const.ci)
229: || addrp->Field || addrp->isarray || addrp->vstg == STGLENG)
230: {
231: p1_big_addr (addrp);
232: return;
233: }
234:
235: /* Write out a level of indirection for non-array arguments, which have
236: addrp -> memoffset set and are handled by p1_big_addr().
237: Lengths are passed by value, so don't check STGLENG
238: 28-Jun-89 (dmg) Added the check for != TYCHAR
239: */
240:
241: if (oneof_stg ( addrp -> uname_tag == UNAM_NAME ? addrp -> user.name : NULL,
242: stg, M(STGARG)|M(STGEQUIV)) && addrp->vtype != TYCHAR) {
243: p1putdd (P1_EXPR, OPWHATSIN, addrp -> vtype);
244: p1_expr (ENULL); /* Put dummy vleng */
245: } /* if stg == STGARG */
246:
247: switch (addrp -> uname_tag) {
248: case UNAM_NAME:
249: p1_name (addrp -> user.name);
250: break;
251: case UNAM_IDENT:
252: p1putdds(P1_IDENT, addrp->vtype, addrp->vstg,
253: addrp->user.ident);
254: break;
255: case UNAM_CHARP:
256: p1putdds(P1_CHARP, addrp->vtype, addrp->vstg,
257: addrp->user.Charp);
258: break;
259: case UNAM_EXTERN:
260: p1putd (P1_EXTERN, (long) addrp -> memno);
261: if (addrp->vclass == CLPROC)
262: extsymtab[addrp->memno].extype = addrp->vtype;
263: break;
264: case UNAM_CONST:
265: if (addrp -> memno != BAD_MEMNO)
266: p1_literal (addrp -> memno);
267: else
268: p1_const((struct Constblock *)addrp);
269: break;
270: case UNAM_UNKNOWN:
271: default:
272: erri ("p1_addr: unknown uname_tag '%d'", addrp -> uname_tag);
273: break;
274: } /* switch */
275: } /* p1_addr */
276:
277:
278: static void p1_list (listp)
279: struct Listblock *listp;
280: {
281: chainp lis;
282: int count = 0;
283:
284: if (listp == (struct Listblock *) NULL)
285: return;
286:
287: /* Count the number of parameters in the list */
288:
289: for (lis = listp -> listp; lis; lis = lis -> nextp)
290: count++;
291:
292: p1putddd (P1_LIST, listp -> tag, listp -> vtype, count);
293:
294: for (lis = listp -> listp; lis; lis = lis -> nextp)
295: p1_expr ((expptr) lis -> datap);
296:
297: } /* p1_list */
298:
299:
300: void p1_label (lab)
301: long lab;
302: {
303: if (parstate < INDATA)
304: earlylabs = mkchain((char *)lab, earlylabs);
305: else
306: p1putd (P1_LABEL, lab);
307: }
308:
309:
310:
311: static void p1_literal (memno)
312: long memno;
313: {
314: p1putd (P1_LITERAL, memno);
315: } /* p1_literal */
316:
317:
318: void p1_if (expr)
319: expptr expr;
320: {
321: p1put (P1_IF);
322: p1_expr (expr);
323: } /* p1_if */
324:
325:
326:
327:
328: void p1_elif (expr)
329: expptr expr;
330: {
331: p1put (P1_ELIF);
332: p1_expr (expr);
333: } /* p1_elif */
334:
335:
336:
337:
338: void p1_else ()
339: {
340: p1put (P1_ELSE);
341: } /* p1_else */
342:
343:
344:
345:
346: void p1_endif ()
347: {
348: p1put (P1_ENDIF);
349: } /* p1_endif */
350:
351:
352:
353:
354: void p1else_end ()
355: {
356: p1put (P1_ENDELSE);
357: } /* p1else_end */
358:
359:
360: static void p1_big_addr (addrp)
361: Addrp addrp;
362: {
363: if (addrp == (Addrp) NULL)
364: return;
365:
366: p1putn (P1_ADDR, (int)sizeof(struct Addrblock), (char *) addrp);
367: p1_expr (addrp -> vleng);
368: p1_expr (addrp -> memoffset);
369: if (addrp->uname_tag == UNAM_NAME)
370: addrp->user.name->visused = 1;
371: } /* p1_big_addr */
372:
373:
374:
375: static void p1_unary (e)
376: struct Exprblock *e;
377: {
378: if (e == (struct Exprblock *) NULL)
379: return;
380:
381: p1putdd (P1_EXPR, (int) e -> opcode, e -> vtype);
382: p1_expr (e -> vleng);
383:
384: switch (e -> opcode) {
385: case OPNEG:
386: case OPNEG1:
387: case OPNOT:
388: case OPABS:
389: case OPBITNOT:
390: case OPPREINC:
391: case OPPREDEC:
392: case OPADDR:
393: case OPIDENTITY:
394: case OPCHARCAST:
395: case OPDABS:
396: p1_expr(e -> leftp);
397: break;
398: default:
399: erri ("p1_unary: bad opcode '%d'", (int) e -> opcode);
400: break;
401: } /* switch */
402:
403: } /* p1_unary */
404:
405:
406: static void p1_binary (e)
407: struct Exprblock *e;
408: {
409: if (e == (struct Exprblock *) NULL)
410: return;
411:
412: p1putdd (P1_EXPR, e -> opcode, e -> vtype);
413: p1_expr (e -> vleng);
414: p1_expr (e -> leftp);
415: p1_expr (e -> rightp);
416: } /* p1_binary */
417:
418:
419: void p1_head (class, name)
420: int class;
421: char *name;
422: {
423: p1putds (P1_HEAD, class, name ? name : "");
424: } /* p1_head */
425:
426:
427: void p1_subr_ret (retexp)
428: expptr retexp;
429: {
430:
431: p1put (P1_SUBR_RET);
432: p1_expr (cpexpr(retexp));
433: } /* p1_subr_ret */
434:
435:
436:
437: void p1comp_goto (index, count, labels)
438: expptr index;
439: int count;
440: struct Labelblock *labels[];
441: {
442: struct Constblock c;
443: int i;
444: register struct Labelblock *L;
445:
446: p1put (P1_COMP_GOTO);
447: p1_expr (index);
448:
449: /* Write out a P1_LIST directly, to avoid the overhead of allocating a
450: list before it's needed HACK HACK HACK */
451:
452: p1putddd (P1_LIST, TLIST, TYUNKNOWN, count);
453: c.vtype = TYLONG;
454: c.vleng = 0;
455:
456: for (i = 0; i < count; i++) {
457: L = labels[i];
458: L->labused = 1;
459: c.Const.ci = L->stateno;
460: p1_const(&c);
461: } /* for i = 0 */
462: } /* p1comp_goto */
463:
464:
465:
466: void p1_for (init, test, inc)
467: expptr init, test, inc;
468: {
469: p1put (P1_FOR);
470: p1_expr (init);
471: p1_expr (test);
472: p1_expr (inc);
473: } /* p1_for */
474:
475:
476: void p1for_end ()
477: {
478: p1put (P1_ENDFOR);
479: } /* p1for_end */
480:
481:
482:
483:
484: /* ----------------------------------------------------------------------
485: The intermediate file actually gets written ONLY by the routines below.
486: To change the format of the file, you need only change these routines.
487: ----------------------------------------------------------------------
488: */
489:
490:
491: /* p1puts -- Put a typed string into the Pass 1 intermediate file. Assumes that
492: str contains no newlines and is null-terminated. */
493:
494: void p1puts (type, str)
495: int type;
496: char *str;
497: {
498: fprintf (pass1_file, "%d: %s\n", type, str);
499: } /* p1puts */
500:
501:
502: /* p1putd -- Put a typed integer into the Pass 1 intermediate file. */
503:
504: static void p1putd (type, value)
505: int type;
506: long value;
507: {
508: fprintf (pass1_file, "%d: %ld\n", type, value);
509: } /* p1_putd */
510:
511:
512: /* p1putdd -- Put a typed pair of integers into the intermediate file. */
513:
514: static void p1putdd (type, v1, v2)
515: int type, v1, v2;
516: {
517: fprintf (pass1_file, "%d: %d %d\n", type, v1, v2);
518: } /* p1putdd */
519:
520:
521: /* p1putddd -- Put a typed triple of integers into the intermediate file. */
522:
523: static void p1putddd (type, v1, v2, v3)
524: int type, v1, v2, v3;
525: {
526: fprintf (pass1_file, "%d: %d %d %d\n", type, v1, v2, v3);
527: } /* p1putddd */
528:
529: union dL {
530: double d;
531: long L[2];
532: };
533:
534: static void p1putn (type, count, str)
535: int type, count;
536: char *str;
537: {
538: int i;
539:
540: fprintf (pass1_file, "%d: ", type);
541:
542: for (i = 0; i < count; i++)
543: putc (str[i], pass1_file);
544:
545: putc ('\n', pass1_file);
546: } /* p1putn */
547:
548:
549:
550: /* p1put -- Put a type marker into the intermediate file. */
551:
552: void p1put(type)
553: int type;
554: {
555: fprintf (pass1_file, "%d:\n", type);
556: } /* p1put */
557:
558:
559:
560: static void p1putds (type, i, str)
561: int type;
562: int i;
563: char *str;
564: {
565: fprintf (pass1_file, "%d: %d %s\n", type, i, str);
566: } /* p1putds */
567:
568:
569: static void p1putdds (token, type, stg, str)
570: int token, type, stg;
571: char *str;
572: {
573: fprintf (pass1_file, "%d: %d %d %s\n", token, type, stg, str);
574: } /* p1putdds */
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.