1 /****************************************************************
2 Copyright 1990 by AT&T Bell Laboratories and Bellcore.
4 Permission to use, copy, modify, and distribute this software
5 and its documentation for any purpose and without fee is hereby
6 granted, provided that the above copyright notice appear in all
7 copies and that both that the copyright notice and this
8 permission notice and warranty disclaimer appear in supporting
9 documentation, and that the names of AT&T Bell Laboratories or
10 Bellcore or any of their entities not be used in advertising or
11 publicity pertaining to distribution of the software without
12 specific, written prior permission.
14 AT&T and Bellcore disclaim all warranties with regard to this
15 software, including all implied warranties of merchantability
16 and fitness. In no event shall AT&T or Bellcore be liable for
17 any special, indirect or consequential damages or any damages
18 whatsoever resulting from loss of use, data or profits, whether
19 in an action of contract, negligence or other tortious action,
20 arising out of or in connection with the use or performance of
22 ****************************************************************/
30 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 */);
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. */
47 register unsigned char *pointer, *ustr;
52 /* Get rid of any open or close comment combinations that may be in the
55 ustr = (unsigned char *)str;
56 for(pointer = ustr; *pointer; pointer++)
57 if (*pointer == '*' && pointer[1] == '/')
59 /* trim trailing white space */
61 while(--pointer >= ustr && (!isascii(*pointer) || isspace(*pointer)));
63 while(--pointer >= ustr && isspace(*pointer));
66 p1puts (P1_COMMENT, str);
69 void p1_line_number (line_number)
73 p1putd (P1_SET_LINE, line_number);
74 } /* p1_line_number */
76 /* p1_name -- Writes the address of a hash table entry into the
79 static void p1_name (namep)
82 p1putd (P1_NAME_POINTER, (long) namep);
91 /* An opcode of 0 means a null entry */
94 p1putdd (P1_EXPR, 0, TYUNKNOWN); /* Should this be TYERROR? */
96 } /* if (expr == ENULL) */
98 switch (expr -> tag) {
100 p1_name ((Namep) expr);
103 p1_const(&expr->constblock);
106 /* Fall through the switch */
109 p1_addr (&(expr -> addrblock));
112 warn ("p1_expr: got TPRIM");
115 p1_list (&(expr -> listblock));
120 erri ("p1_expr: bad tag '%d'", (int) (expr -> tag));
124 /* Now we know that the tag is TEXPR */
126 if (is_unary_op (expr -> exprblock.opcode))
127 p1_unary (&(expr -> exprblock));
128 else if (is_binary_op (expr -> exprblock.opcode))
129 p1_binary (&(expr -> exprblock));
131 erri ("p1_expr: bad opcode '%d'", (int) expr -> exprblock.opcode);
137 static void p1_const(cp)
140 int type = cp->vtype;
141 expptr vleng = cp->vleng;
142 union Constant *c = &cp->Const;
143 char cdsbuf0[64], cdsbuf1[64];
150 p1putdd (P1_CONST, type, (int)c -> ci);
154 fprintf(pass1_file, "%d: %d %s\n", P1_CONST, type,
155 cp->vstg ? c->cds[0] : cds(dtos(c->cd[0]), cdsbuf0));
164 cds0 = cds(dtos(c->cd[0]), cdsbuf0);
165 cds1 = cds(dtos(c->cd[1]), cdsbuf1);
167 fprintf(pass1_file, "%d: %d %s %s\n", P1_CONST, type,
171 if (vleng && !ISICON (vleng))
172 erri("p1_const: bad vleng '%d'\n", (int) vleng);
174 fprintf(pass1_file, "%d: %d %lx\n", P1_CONST, type,
178 erri ("p1_const: bad constant type '%d'", type);
184 void p1_asgoto (addrp)
192 void p1_goto (stateno)
195 p1putd (P1_GOTO, stateno);
199 static void p1_addr (addrp)
200 register struct Addrblock *addrp;
204 if (addrp == (struct Addrblock *) NULL)
209 if (ONEOF(stg, M(STGINIT)|M(STGREG))
210 || ONEOF(stg, M(STGCOMMON)|M(STGEQUIV)) &&
211 (!ISICON(addrp->memoffset)
212 || (addrp->uname_tag == UNAM_NAME
213 ? addrp->memoffset->constblock.Const.ci
214 != addrp->user.name->voffset
215 : addrp->memoffset->constblock.Const.ci))
216 || ONEOF(stg, M(STGBSS)|M(STGINIT)|M(STGAUTO)|M(STGARG)) &&
217 (!ISICON(addrp->memoffset)
218 || addrp->memoffset->constblock.Const.ci)
219 || addrp->Field || addrp->isarray || addrp->vstg == STGLENG)
225 /* Write out a level of indirection for non-array arguments, which have
226 addrp -> memoffset set and are handled by p1_big_addr().
227 Lengths are passed by value, so don't check STGLENG
228 28-Jun-89 (dmg) Added the check for != TYCHAR
231 if (oneof_stg ( addrp -> uname_tag == UNAM_NAME ? addrp -> user.name : NULL,
232 stg, M(STGARG)|M(STGEQUIV)) && addrp->vtype != TYCHAR) {
233 p1putdd (P1_EXPR, OPWHATSIN, addrp -> vtype);
234 p1_expr (ENULL); /* Put dummy vleng */
235 } /* if stg == STGARG */
237 switch (addrp -> uname_tag) {
239 p1_name (addrp -> user.name);
242 p1putdds(P1_IDENT, addrp->vtype, addrp->vstg,
246 p1putdds(P1_CHARP, addrp->vtype, addrp->vstg,
250 p1putd (P1_EXTERN, (long) addrp -> memno);
251 if (addrp->vclass == CLPROC)
252 extsymtab[addrp->memno].extype = addrp->vtype;
255 if (addrp -> memno != BAD_MEMNO)
256 p1_literal (addrp -> memno);
258 p1_const((struct Constblock *)addrp);
262 erri ("p1_addr: unknown uname_tag '%d'", addrp -> uname_tag);
268 static void p1_list (listp)
269 struct Listblock *listp;
274 if (listp == (struct Listblock *) NULL)
277 /* Count the number of parameters in the list */
279 for (lis = listp -> listp; lis; lis = lis -> nextp)
282 p1putddd (P1_LIST, listp -> tag, listp -> vtype, count);
284 for (lis = listp -> listp; lis; lis = lis -> nextp)
285 p1_expr ((expptr) lis -> datap);
293 if (parstate < INDATA)
294 earlylabs = mkchain((char *)lab, earlylabs);
296 p1putd (P1_LABEL, lab);
301 static void p1_literal (memno)
304 p1putd (P1_LITERAL, memno);
350 static void p1_big_addr (addrp)
353 if (addrp == (Addrp) NULL)
356 p1putn (P1_ADDR, sizeof (struct Addrblock), (char *) addrp);
357 p1_expr (addrp -> vleng);
358 p1_expr (addrp -> memoffset);
359 if (addrp->uname_tag == UNAM_NAME)
360 addrp->user.name->visused = 1;
365 static void p1_unary (e)
368 if (e == (struct Exprblock *) NULL)
371 p1putdd (P1_EXPR, (int) e -> opcode, e -> vtype);
372 p1_expr (e -> vleng);
374 switch (e -> opcode) {
389 erri ("p1_unary: bad opcode '%d'", (int) e -> opcode);
396 static void p1_binary (e)
399 if (e == (struct Exprblock *) NULL)
402 p1putdd (P1_EXPR, e -> opcode, e -> vtype);
403 p1_expr (e -> vleng);
404 p1_expr (e -> leftp);
405 p1_expr (e -> rightp);
409 void p1_head (class, name)
413 p1putds (P1_HEAD, class, name);
417 void p1_subr_ret (retexp)
427 void p1comp_goto (index, count, labels)
430 struct Labelblock *labels[];
434 register struct Labelblock *L;
436 p1put (P1_COMP_GOTO);
439 /* Write out a P1_LIST directly, to avoid the overhead of allocating a
440 list before it's needed HACK HACK HACK */
442 p1putddd (P1_LIST, TLIST, TYUNKNOWN, count);
446 for (i = 0; i < count; i++) {
449 c.Const.ci = L->stateno;
456 void p1_for (init, test, inc)
457 expptr init, test, inc;
474 /* ----------------------------------------------------------------------
475 The intermediate file actually gets written ONLY by the routines below.
476 To change the format of the file, you need only change these routines.
477 ----------------------------------------------------------------------
481 /* p1puts -- Put a typed string into the Pass 1 intermediate file. Assumes that
482 str contains no newlines and is null-terminated. */
484 void p1puts (type, str)
488 fprintf (pass1_file, "%d: %s\n", type, str);
492 /* p1putd -- Put a typed integer into the Pass 1 intermediate file. */
494 static void p1putd (type, value)
498 fprintf (pass1_file, "%d: %ld\n", type, value);
502 /* p1putdd -- Put a typed pair of integers into the intermediate file. */
504 static void p1putdd (type, v1, v2)
507 fprintf (pass1_file, "%d: %d %d\n", type, v1, v2);
511 /* p1putddd -- Put a typed triple of integers into the intermediate file. */
513 static void p1putddd (type, v1, v2, v3)
514 int type, v1, v2, v3;
516 fprintf (pass1_file, "%d: %d %d %d\n", type, v1, v2, v3);
524 static void p1putn (type, count, str)
530 fprintf (pass1_file, "%d: ", type);
532 for (i = 0; i < count; i++)
533 putc (str[i], pass1_file);
535 putc ('\n', pass1_file);
540 /* p1put -- Put a type marker into the intermediate file. */
545 fprintf (pass1_file, "%d:\n", type);
550 static void p1putds (type, i, str)
555 fprintf (pass1_file, "%d: %d %s\n", type, i, str);
559 static void p1putdds (token, type, stg, str)
560 int token, type, stg;
563 fprintf (pass1_file, "%d: %d %d %s\n", token, type, stg, str);