f2c from netlib.att.com Jan 4 1994

1 files changed, 567 insertions, 0 deletions

diff --git a/usr.bin/f2c/p1output.c b/usr.bin/f2c/p1output.c
new file mode 100644
index 0000000..d4419b5
--- /dev/null
+++ b/usr.bin/f2c/p1output.c
@@ -0,0 +1,567 @@
+/****************************************************************
+Copyright 1990, 1991, 1993 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "p1defs.h"
+#include "output.h"
+#include "names.h"
+
+
+static void p1_addr(), p1_big_addr(), p1_binary(), p1_const(), p1_list(),
+	p1_literal(), p1_name(), p1_unary(), p1putn();
+static void p1putd (/* int, int */);
+static void p1putds (/* int, int, char * */);
+static void p1putdds (/* int, int, int, char * */);
+static void p1putdd (/* int, int, int */);
+static void p1putddd (/* int, int, int, int */);
+
+
+/* p1_comment -- save the text of a Fortran comment in the intermediate
+   file.  Make sure that there are no spurious "/ *" or "* /" characters by
+   mapping them onto "/+" and "+/".   str   is assumed to hold no newlines and be
+   null terminated; it may be modified by this function. */
+
+void p1_comment (str)
+char *str;
+{
+    register unsigned char *pointer, *ustr;
+
+    if (!str)
+	return;
+
+/* Get rid of any open or close comment combinations that may be in the
+   Fortran input */
+
+	ustr = (unsigned char *)str;
+	for(pointer = ustr; *pointer; pointer++)
+		if (*pointer == '*' && (pointer[1] == '/'
+					|| pointer > ustr && pointer[-1] == '/'))
+			*pointer = '+';
+	/* trim trailing white space */
+#ifdef isascii
+	while(--pointer >= ustr && (!isascii(*pointer) || isspace(*pointer)));
+#else
+	while(--pointer >= ustr && isspace(*pointer));
+#endif
+	pointer[1] = 0;
+	p1puts (P1_COMMENT, str);
+} /* p1_comment */
+
+/* p1_name -- Writes the address of a hash table entry into the
+   intermediate file */
+
+static void p1_name (namep)
+Namep namep;
+{
+	p1putd (P1_NAME_POINTER, (long) namep);
+	namep->visused = 1;
+} /* p1_name */
+
+
+
+void p1_expr (expr)
+expptr expr;
+{
+/* An opcode of 0 means a null entry */
+
+    if (expr == ENULL) {
+	p1putdd (P1_EXPR, 0, TYUNKNOWN);	/* Should this be TYERROR? */
+	return;
+    } /* if (expr == ENULL) */
+
+    switch (expr -> tag) {
+        case TNAME:
+		p1_name ((Namep) expr);
+		return;
+	case TCONST:
+		p1_const(&expr->constblock);
+		return;
+	case TEXPR:
+		/* Fall through the switch */
+		break;
+	case TADDR:
+		p1_addr (&(expr -> addrblock));
+		goto freeup;
+	case TPRIM:
+		warn ("p1_expr:  got TPRIM");
+		return;
+	case TLIST:
+		p1_list (&(expr->listblock));
+		frchain( &(expr->listblock.listp) );
+		return;
+	case TERROR:
+		return;
+	default:
+		erri ("p1_expr: bad tag '%d'", (int) (expr -> tag));
+		return;
+	}
+
+/* Now we know that the tag is TEXPR */
+
+    if (is_unary_op (expr -> exprblock.opcode))
+	p1_unary (&(expr -> exprblock));
+    else if (is_binary_op (expr -> exprblock.opcode))
+	p1_binary (&(expr -> exprblock));
+    else
+	erri ("p1_expr:  bad opcode '%d'", (int) expr -> exprblock.opcode);
+ freeup:
+    free((char *)expr);
+
+} /* p1_expr */
+
+
+
+static void p1_const(cp)
+ register Constp cp;
+{
+	int type = cp->vtype;
+	expptr vleng = cp->vleng;
+	union Constant *c = &cp->Const;
+	char cdsbuf0[64], cdsbuf1[64];
+	char *cds0, *cds1;
+
+    switch (type) {
+	case TYINT1:
+        case TYSHORT:
+	case TYLONG:
+#ifdef TYQUAD
+	case TYQUAD:
+#endif
+	case TYLOGICAL:
+	case TYLOGICAL1:
+	case TYLOGICAL2:
+	    fprintf(pass1_file, "%d: %d %ld\n", P1_CONST, type, c->ci);
+	    break;
+	case TYREAL:
+	case TYDREAL:
+		fprintf(pass1_file, "%d: %d %s\n", P1_CONST, type,
+			cp->vstg ? c->cds[0] : cds(dtos(c->cd[0]), cdsbuf0));
+	    break;
+	case TYCOMPLEX:
+	case TYDCOMPLEX:
+		if (cp->vstg) {
+			cds0 = c->cds[0];
+			cds1 = c->cds[1];
+			}
+		else {
+			cds0 = cds(dtos(c->cd[0]), cdsbuf0);
+			cds1 = cds(dtos(c->cd[1]), cdsbuf1);
+			}
+		fprintf(pass1_file, "%d: %d %s %s\n", P1_CONST, type,
+			cds0, cds1);
+	    break;
+	case TYCHAR:
+	    if (vleng && !ISICON (vleng))
+		erri("p1_const:  bad vleng '%d'\n", (int) vleng);
+	    else
+		fprintf(pass1_file, "%d: %d %lx\n", P1_CONST, type,
+			cpexpr((expptr)cp));
+	    break;
+	default:
+	    erri ("p1_const:  bad constant type '%d'", type);
+	    break;
+    } /* switch */
+} /* p1_const */
+
+
+void p1_asgoto (addrp)
+Addrp addrp;
+{
+    p1put (P1_ASGOTO);
+    p1_addr (addrp);
+} /* p1_asgoto */
+
+
+void p1_goto (stateno)
+ftnint stateno;
+{
+    p1putd (P1_GOTO, stateno);
+} /* p1_goto */
+
+
+static void p1_addr (addrp)
+ register struct Addrblock *addrp;
+{
+    int stg;
+
+    if (addrp == (struct Addrblock *) NULL)
+	return;
+
+    stg = addrp -> vstg;
+
+    if (ONEOF(stg, M(STGINIT)|M(STGREG))
+	|| ONEOF(stg, M(STGCOMMON)|M(STGEQUIV)) &&
+		(!ISICON(addrp->memoffset)
+		|| (addrp->uname_tag == UNAM_NAME
+			? addrp->memoffset->constblock.Const.ci
+				!= addrp->user.name->voffset
+			: addrp->memoffset->constblock.Const.ci))
+	|| ONEOF(stg, M(STGBSS)|M(STGINIT)|M(STGAUTO)|M(STGARG)) &&
+		(!ISICON(addrp->memoffset)
+			|| addrp->memoffset->constblock.Const.ci)
+	|| addrp->Field || addrp->isarray || addrp->vstg == STGLENG)
+	{
+		p1_big_addr (addrp);
+		return;
+	}
+
+/* Write out a level of indirection for non-array arguments, which have
+   addrp -> memoffset   set and are handled by   p1_big_addr().
+   Lengths are passed by value, so don't check STGLENG
+   28-Jun-89 (dmg)  Added the check for != TYCHAR
+ */
+
+    if (oneof_stg ( addrp -> uname_tag == UNAM_NAME ? addrp -> user.name : NULL,
+	    stg, M(STGARG)|M(STGEQUIV)) && addrp->vtype != TYCHAR) {
+	p1putdd (P1_EXPR, OPWHATSIN, addrp -> vtype);
+	p1_expr (ENULL);	/* Put dummy   vleng   */
+    } /* if stg == STGARG */
+
+    switch (addrp -> uname_tag) {
+        case UNAM_NAME:
+	    p1_name (addrp -> user.name);
+	    break;
+	case UNAM_IDENT:
+	    p1putdds(P1_IDENT, addrp->vtype, addrp->vstg,
+				addrp->user.ident);
+	    break;
+	case UNAM_CHARP:
+		p1putdds(P1_CHARP, addrp->vtype, addrp->vstg,
+				addrp->user.Charp);
+		break;
+	case UNAM_EXTERN:
+	    p1putd (P1_EXTERN, (long) addrp -> memno);
+	    if (addrp->vclass == CLPROC)
+		extsymtab[addrp->memno].extype = addrp->vtype;
+	    break;
+	case UNAM_CONST:
+	    if (addrp -> memno != BAD_MEMNO)
+		p1_literal (addrp -> memno);
+	    else
+		p1_const((struct Constblock *)addrp);
+	    break;
+	case UNAM_UNKNOWN:
+	default:
+	    erri ("p1_addr:  unknown uname_tag '%d'", addrp -> uname_tag);
+	    break;
+    } /* switch */
+} /* p1_addr */
+
+
+static void p1_list (listp)
+struct Listblock *listp;
+{
+    chainp lis;
+    int count = 0;
+
+    if (listp == (struct Listblock *) NULL)
+	return;
+
+/* Count the number of parameters in the list */
+
+    for (lis = listp -> listp; lis; lis = lis -> nextp)
+	count++;
+
+    p1putddd (P1_LIST, listp -> tag, listp -> vtype, count);
+
+    for (lis = listp -> listp; lis; lis = lis -> nextp)
+	p1_expr ((expptr) lis -> datap);
+
+} /* p1_list */
+
+
+void p1_label (lab)
+long lab;
+{
+	if (parstate < INDATA)
+		earlylabs = mkchain((char *)lab, earlylabs);
+	else
+		p1putd (P1_LABEL, lab);
+	}
+
+
+
+static void p1_literal (memno)
+long memno;
+{
+    p1putd (P1_LITERAL, memno);
+} /* p1_literal */
+
+
+void p1_if (expr)
+expptr expr;
+{
+    p1put (P1_IF);
+    p1_expr (expr);
+} /* p1_if */
+
+
+
+
+void p1_elif (expr)
+expptr expr;
+{
+    p1put (P1_ELIF);
+    p1_expr (expr);
+} /* p1_elif */
+
+
+
+
+void p1_else ()
+{
+    p1put (P1_ELSE);
+} /* p1_else */
+
+
+
+
+void p1_endif ()
+{
+    p1put (P1_ENDIF);
+} /* p1_endif */
+
+
+
+
+void p1else_end ()
+{
+    p1put (P1_ENDELSE);
+} /* p1else_end */
+
+
+static void p1_big_addr (addrp)
+Addrp addrp;
+{
+    if (addrp == (Addrp) NULL)
+	return;
+
+    p1putn (P1_ADDR, (int)sizeof(struct Addrblock), (char *) addrp);
+    p1_expr (addrp -> vleng);
+    p1_expr (addrp -> memoffset);
+    if (addrp->uname_tag == UNAM_NAME)
+	addrp->user.name->visused = 1;
+} /* p1_big_addr */
+
+
+
+static void p1_unary (e)
+struct Exprblock *e;
+{
+    if (e == (struct Exprblock *) NULL)
+	return;
+
+    p1putdd (P1_EXPR, (int) e -> opcode, e -> vtype);
+    p1_expr (e -> vleng);
+
+    switch (e -> opcode) {
+        case OPNEG:
+	case OPNEG1:
+	case OPNOT:
+	case OPABS:
+	case OPBITNOT:
+	case OPPREINC:
+	case OPPREDEC:
+	case OPADDR:
+	case OPIDENTITY:
+	case OPCHARCAST:
+	case OPDABS:
+	    p1_expr(e -> leftp);
+	    break;
+	default:
+	    erri ("p1_unary: bad opcode '%d'", (int) e -> opcode);
+	    break;
+    } /* switch */
+
+} /* p1_unary */
+
+
+static void p1_binary (e)
+struct Exprblock *e;
+{
+    if (e == (struct Exprblock *) NULL)
+	return;
+
+    p1putdd (P1_EXPR, e -> opcode, e -> vtype);
+    p1_expr (e -> vleng);
+    p1_expr (e -> leftp);
+    p1_expr (e -> rightp);
+} /* p1_binary */
+
+
+void p1_head (class, name)
+int class;
+char *name;
+{
+    p1putds (P1_HEAD, class, name ? name : "");
+} /* p1_head */
+
+
+void p1_subr_ret (retexp)
+expptr retexp;
+{
+
+    p1put (P1_SUBR_RET);
+    p1_expr (cpexpr(retexp));
+} /* p1_subr_ret */
+
+
+
+void p1comp_goto (index, count, labels)
+expptr index;
+int count;
+struct Labelblock *labels[];
+{
+    struct Constblock c;
+    int i;
+    register struct Labelblock *L;
+
+    p1put (P1_COMP_GOTO);
+    p1_expr (index);
+
+/* Write out a P1_LIST directly, to avoid the overhead of allocating a
+   list before it's needed HACK HACK HACK */
+
+    p1putddd (P1_LIST, TLIST, TYUNKNOWN, count);
+    c.vtype = TYLONG;
+    c.vleng = 0;
+
+    for (i = 0; i < count; i++) {
+	L = labels[i];
+	L->labused = 1;
+	c.Const.ci = L->stateno;
+	p1_const(&c);
+    } /* for i = 0 */
+} /* p1comp_goto */
+
+
+
+void p1_for (init, test, inc)
+expptr init, test, inc;
+{
+    p1put (P1_FOR);
+    p1_expr (init);
+    p1_expr (test);
+    p1_expr (inc);
+} /* p1_for */
+
+
+void p1for_end ()
+{
+    p1put (P1_ENDFOR);
+} /* p1for_end */
+
+
+
+
+/* ----------------------------------------------------------------------
+   The intermediate file actually gets written ONLY by the routines below.
+   To change the format of the file, you need only change these routines.
+   ----------------------------------------------------------------------
+*/
+
+
+/* p1puts -- Put a typed string into the Pass 1 intermediate file.  Assumes that
+   str   contains no newlines and is null-terminated. */
+
+void p1puts (type, str)
+int type;
+char *str;
+{
+    fprintf (pass1_file, "%d: %s\n", type, str);
+} /* p1puts */
+
+
+/* p1putd -- Put a typed integer into the Pass 1 intermediate file. */
+
+static void p1putd (type, value)
+int type;
+long value;
+{
+    fprintf (pass1_file, "%d: %ld\n", type, value);
+} /* p1_putd */
+
+
+/* p1putdd -- Put a typed pair of integers into the intermediate file. */
+
+static void p1putdd (type, v1, v2)
+int type, v1, v2;
+{
+    fprintf (pass1_file, "%d: %d %d\n", type, v1, v2);
+} /* p1putdd */
+
+
+/* p1putddd -- Put a typed triple of integers into the intermediate file. */
+
+static void p1putddd (type, v1, v2, v3)
+int type, v1, v2, v3;
+{
+    fprintf (pass1_file, "%d: %d %d %d\n", type, v1, v2, v3);
+} /* p1putddd */
+
+ union dL {
+	double d;
+	long L[2];
+	};
+
+static void p1putn (type, count, str)
+int type, count;
+char *str;
+{
+    int i;
+
+    fprintf (pass1_file, "%d: ", type);
+
+    for (i = 0; i < count; i++)
+	putc (str[i], pass1_file);
+
+    putc ('\n', pass1_file);
+} /* p1putn */
+
+
+
+/* p1put -- Put a type marker into the intermediate file. */
+
+void p1put(type)
+int type;
+{
+    fprintf (pass1_file, "%d:\n", type);
+} /* p1put */
+
+
+
+static void p1putds (type, i, str)
+int type;
+int i;
+char *str;
+{
+    fprintf (pass1_file, "%d: %d %s\n", type, i, str);
+} /* p1putds */
+
+
+static void p1putdds (token, type, stg, str)
+int token, type, stg;
+char *str;
+{
+    fprintf (pass1_file, "%d: %d %d %s\n", token, type, stg, str);
+} /* p1putdds */