summaryrefslogtreecommitdiffstats
path: root/usr.bin/f2c/putpcc.c
diff options
context:
space:
mode:
Diffstat (limited to 'usr.bin/f2c/putpcc.c')
-rw-r--r--usr.bin/f2c/putpcc.c2075
1 files changed, 2075 insertions, 0 deletions
diff --git a/usr.bin/f2c/putpcc.c b/usr.bin/f2c/putpcc.c
new file mode 100644
index 0000000..c104098
--- /dev/null
+++ b/usr.bin/f2c/putpcc.c
@@ -0,0 +1,2075 @@
+/****************************************************************
+Copyright 1990 - 1996 by AT&T, Lucent Technologies 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,
+Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
+this software, including all implied warranties of
+merchantability and fitness. In no event shall AT&T, Lucent 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.
+****************************************************************/
+
+/* INTERMEDIATE CODE GENERATION FOR S. C. JOHNSON C COMPILERS */
+/* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */
+
+#include "defs.h"
+#include "pccdefs.h"
+#include "output.h" /* for nice_printf */
+#include "names.h"
+#include "p1defs.h"
+
+static Addrp intdouble Argdcl((Addrp));
+static Addrp putcx1 Argdcl((tagptr));
+static tagptr putaddr Argdcl((tagptr));
+static tagptr putcall Argdcl((tagptr, Addrp*));
+static tagptr putcat Argdcl((tagptr, tagptr));
+static Addrp putch1 Argdcl((tagptr));
+static tagptr putchcmp Argdcl((tagptr));
+static tagptr putcheq Argdcl((tagptr));
+static void putct1 Argdcl((tagptr, Addrp, Addrp, ptr));
+static tagptr putcxcmp Argdcl((tagptr));
+static Addrp putcxeq Argdcl((tagptr));
+static tagptr putmnmx Argdcl((tagptr));
+static tagptr putop Argdcl((tagptr));
+static tagptr putpower Argdcl((tagptr));
+
+extern int init_ac[TYSUBR+1];
+extern int ops2[];
+extern int proc_argchanges, proc_protochanges;
+extern int krparens;
+
+#define P2BUFFMAX 128
+
+/* Puthead -- output the header information about subroutines, functions
+ and entry points */
+
+ void
+#ifdef KR_headers
+puthead(s, class)
+ char *s;
+ int class;
+#else
+puthead(char *s, int class)
+#endif
+{
+ if (headerdone == NO) {
+ if (class == CLMAIN)
+ s = "MAIN__";
+ p1_head (class, s);
+ headerdone = YES;
+ }
+}
+
+ void
+#ifdef KR_headers
+putif(p, else_if_p)
+ register expptr p;
+ int else_if_p;
+#else
+putif(register expptr p, int else_if_p)
+#endif
+{
+ register int k;
+ int n;
+ long where;
+
+ if (else_if_p) {
+ p1put(P1_ELSEIFSTART);
+ where = ftell(pass1_file);
+ }
+ if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype )) )
+ {
+ if(k != TYERROR)
+ err("non-logical expression in IF statement");
+ }
+ else {
+ if (else_if_p) {
+ if (ei_next >= ei_last)
+ {
+ k = ei_last - ei_first;
+ n = k + 100;
+ ei_next = mem(n,0);
+ ei_last = ei_first + n;
+ if (k)
+ memcpy(ei_next, ei_first, k);
+ ei_first = ei_next;
+ ei_next += k;
+ ei_last = ei_first + n;
+ }
+ p = putx(p);
+ if (*ei_next++ = ftell(pass1_file) > where) {
+ p1_if(p);
+ new_endif();
+ }
+ else
+ p1_elif(p);
+ }
+ else {
+ p = putx(p);
+ p1_if(p);
+ }
+ }
+ }
+
+ void
+#ifdef KR_headers
+putout(p)
+ expptr p;
+#else
+putout(expptr p)
+#endif
+{
+ p1_expr (p);
+
+/* Used to make temporaries in holdtemps available here, but they */
+/* may be reused too soon (e.g. when multiple **'s are involved). */
+}
+
+
+ void
+#ifdef KR_headers
+putcmgo(index, nlab, labs)
+ expptr index;
+ int nlab;
+ struct Labelblock **labs;
+#else
+putcmgo(expptr index, int nlab, struct Labelblock **labs)
+#endif
+{
+ if(! ISINT(index->headblock.vtype) )
+ {
+ execerr("computed goto index must be integer", CNULL);
+ return;
+ }
+
+ p1comp_goto (index, nlab, labs);
+}
+
+ static expptr
+#ifdef KR_headers
+krput(p)
+ register expptr p;
+#else
+krput(register expptr p)
+#endif
+{
+ register expptr e, e1;
+ register unsigned op;
+ int t = krparens == 2 ? TYDREAL : p->exprblock.vtype;
+
+ op = p->exprblock.opcode;
+ e = p->exprblock.leftp;
+ if (e->tag == TEXPR && e->exprblock.opcode == op) {
+ e1 = (expptr)mktmp(t, ENULL);
+ putout(putassign(cpexpr(e1), e));
+ p->exprblock.leftp = e1;
+ }
+ else
+ p->exprblock.leftp = putx(e);
+
+ e = p->exprblock.rightp;
+ if (e->tag == TEXPR && e->exprblock.opcode == op) {
+ e1 = (expptr)mktmp(t, ENULL);
+ putout(putassign(cpexpr(e1), e));
+ p->exprblock.rightp = e1;
+ }
+ else
+ p->exprblock.rightp = putx(e);
+ return p;
+ }
+
+ expptr
+#ifdef KR_headers
+putx(p)
+ register expptr p;
+#else
+putx(register expptr p)
+#endif
+{
+ int opc;
+ int k;
+
+ if (p)
+ switch(p->tag)
+ {
+ case TERROR:
+ break;
+
+ case TCONST:
+ switch(p->constblock.vtype)
+ {
+ case TYLOGICAL1:
+ case TYLOGICAL2:
+ case TYLOGICAL:
+#ifdef TYQUAD
+ case TYQUAD:
+#endif
+ case TYLONG:
+ case TYSHORT:
+ case TYINT1:
+ break;
+
+ case TYADDR:
+ break;
+ case TYREAL:
+ case TYDREAL:
+
+/* Don't write it out to the p2 file, since you'd need to call putconst,
+ which is just what we need to avoid in the translator */
+
+ break;
+ default:
+ p = putx( (expptr)putconst((Constp)p) );
+ break;
+ }
+ break;
+
+ case TEXPR:
+ switch(opc = p->exprblock.opcode)
+ {
+ case OPCALL:
+ case OPCCALL:
+ if( ISCOMPLEX(p->exprblock.vtype) )
+ p = putcxop(p);
+ else p = putcall(p, (Addrp *)NULL);
+ break;
+
+ case OPMIN:
+ case OPMAX:
+ p = putmnmx(p);
+ break;
+
+
+ case OPASSIGN:
+ if(ISCOMPLEX(p->exprblock.leftp->headblock.vtype)
+ || ISCOMPLEX(p->exprblock.rightp->headblock.vtype)) {
+ (void) putcxeq(p);
+ p = ENULL;
+ } else if( ISCHAR(p) )
+ p = putcheq(p);
+ else
+ goto putopp;
+ break;
+
+ case OPEQ:
+ case OPNE:
+ if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) ||
+ ISCOMPLEX(p->exprblock.rightp->headblock.vtype) )
+ {
+ p = putcxcmp(p);
+ break;
+ }
+ case OPLT:
+ case OPLE:
+ case OPGT:
+ case OPGE:
+ if(ISCHAR(p->exprblock.leftp))
+ {
+ p = putchcmp(p);
+ break;
+ }
+ goto putopp;
+
+ case OPPOWER:
+ p = putpower(p);
+ break;
+
+ case OPSTAR:
+ /* m * (2**k) -> m<<k */
+ if(INT(p->exprblock.leftp->headblock.vtype) &&
+ ISICON(p->exprblock.rightp) &&
+ ( (k = log_2(p->exprblock.rightp->constblock.Const.ci))>0) )
+ {
+ p->exprblock.opcode = OPLSHIFT;
+ frexpr(p->exprblock.rightp);
+ p->exprblock.rightp = ICON(k);
+ goto putopp;
+ }
+ if (krparens && ISREAL(p->exprblock.vtype))
+ return krput(p);
+
+ case OPMOD:
+ goto putopp;
+ case OPPLUS:
+ if (krparens && ISREAL(p->exprblock.vtype))
+ return krput(p);
+ case OPMINUS:
+ case OPSLASH:
+ case OPNEG:
+ case OPNEG1:
+ case OPABS:
+ case OPDABS:
+ if( ISCOMPLEX(p->exprblock.vtype) )
+ p = putcxop(p);
+ else goto putopp;
+ break;
+
+ case OPCONV:
+ if( ISCOMPLEX(p->exprblock.vtype) )
+ p = putcxop(p);
+ else if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) )
+ {
+ p = putx( mkconv(p->exprblock.vtype,
+ (expptr)realpart(putcx1(p->exprblock.leftp))));
+ }
+ else goto putopp;
+ break;
+
+ case OPNOT:
+ case OPOR:
+ case OPAND:
+ case OPEQV:
+ case OPNEQV:
+ case OPADDR:
+ case OPPLUSEQ:
+ case OPSTAREQ:
+ case OPCOMMA:
+ case OPQUEST:
+ case OPCOLON:
+ case OPBITOR:
+ case OPBITAND:
+ case OPBITXOR:
+ case OPBITNOT:
+ case OPLSHIFT:
+ case OPRSHIFT:
+ case OPASSIGNI:
+ case OPIDENTITY:
+ case OPCHARCAST:
+ case OPMIN2:
+ case OPMAX2:
+ case OPDMIN:
+ case OPDMAX:
+ case OPBITTEST:
+ case OPBITCLR:
+ case OPBITSET:
+#ifdef TYQUAD
+ case OPQBITSET:
+ case OPQBITCLR:
+#endif
+putopp:
+ p = putop(p);
+ break;
+
+ case OPCONCAT:
+ /* weird things like ichar(a//a) */
+ p = (expptr)putch1(p);
+ break;
+
+ default:
+ badop("putx", opc);
+ p = errnode ();
+ }
+ break;
+
+ case TADDR:
+ p = putaddr(p);
+ break;
+
+ default:
+ badtag("putx", p->tag);
+ p = errnode ();
+ }
+
+ return p;
+}
+
+
+
+ LOCAL expptr
+#ifdef KR_headers
+putop(p)
+ expptr p;
+#else
+putop(expptr p)
+#endif
+{
+ expptr lp, tp;
+ int pt, lt, lt1;
+ int comma;
+ char *hsave;
+
+ switch(p->exprblock.opcode) /* check for special cases and rewrite */
+ {
+ case OPCONV:
+ pt = p->exprblock.vtype;
+ lp = p->exprblock.leftp;
+ lt = lp->headblock.vtype;
+
+/* Simplify nested type casts */
+
+ while(p->tag==TEXPR && p->exprblock.opcode==OPCONV &&
+ ( (ISREAL(pt)&&ONEOF(lt,MSKREAL|MSKCOMPLEX)) ||
+ (INT(pt)&&(ONEOF(lt,MSKINT|MSKADDR|MSKCHAR|M(TYSUBR)))) ))
+ {
+ if(pt==TYDREAL && lt==TYREAL)
+ {
+ if(lp->tag==TEXPR
+ && lp->exprblock.opcode == OPCONV) {
+ lt1 = lp->exprblock.leftp->headblock.vtype;
+ if (lt1 == TYDREAL) {
+ lp->exprblock.leftp =
+ putx(lp->exprblock.leftp);
+ return p;
+ }
+ if (lt1 == TYDCOMPLEX) {
+ lp->exprblock.leftp = putx(
+ (expptr)realpart(
+ putcx1(lp->exprblock.leftp)));
+ return p;
+ }
+ }
+ break;
+ }
+ else if (ISREAL(pt) && ISCOMPLEX(lt)) {
+ p->exprblock.leftp = putx(mkconv(pt,
+ (expptr)realpart(
+ putcx1(p->exprblock.leftp))));
+ break;
+ }
+ if(lt==TYCHAR && lp->tag==TEXPR &&
+ lp->exprblock.opcode==OPCALL)
+ {
+
+/* May want to make a comma expression here instead. I had one, but took
+ it out for my convenience, not for the convenience of the end user */
+
+ putout (putcall (lp, (Addrp *) &(p ->
+ exprblock.leftp)));
+ return putop (p);
+ }
+ if (lt == TYCHAR) {
+ if (ISCONST(p->exprblock.leftp)
+ && ISNUMERIC(p->exprblock.vtype)) {
+ hsave = halign;
+ halign = 0;
+ p->exprblock.leftp = putx((expptr)
+ putconst((Constp)
+ p->exprblock.leftp));
+ halign = hsave;
+ }
+ else
+ p->exprblock.leftp =
+ putx(p->exprblock.leftp);
+ return p;
+ }
+ if (pt < lt && ONEOF(lt,MSKINT|MSKREAL))
+ break;
+ frexpr(p->exprblock.vleng);
+ free( (charptr) p );
+ p = lp;
+ if (p->tag != TEXPR)
+ goto retputx;
+ pt = lt;
+ lp = p->exprblock.leftp;
+ lt = lp->headblock.vtype;
+ } /* while */
+ if(p->tag==TEXPR && p->exprblock.opcode==OPCONV)
+ break;
+ retputx:
+ return putx(p);
+
+ case OPADDR:
+ comma = NO;
+ lp = p->exprblock.leftp;
+ free( (charptr) p );
+ if(lp->tag != TADDR)
+ {
+ tp = (expptr)
+ mktmp(lp->headblock.vtype,lp->headblock.vleng);
+ p = putx( mkexpr(OPASSIGN, cpexpr(tp), lp) );
+ lp = tp;
+ comma = YES;
+ }
+ if(comma)
+ p = mkexpr(OPCOMMA, p, putaddr(lp));
+ else
+ p = (expptr)putaddr(lp);
+ return p;
+
+ case OPASSIGN:
+ case OPASSIGNI:
+ case OPLT:
+ case OPLE:
+ case OPGT:
+ case OPGE:
+ case OPEQ:
+ case OPNE:
+ ;
+ }
+
+ if( ops2[p->exprblock.opcode] <= 0)
+ badop("putop", p->exprblock.opcode);
+ lp = p->exprblock.leftp = putx(p->exprblock.leftp);
+ if (p -> exprblock.rightp) {
+ tp = p->exprblock.rightp = putx(p->exprblock.rightp);
+ if (ISCONST(tp) && ISCONST(lp))
+ p = fold(p);
+ }
+ return p;
+}
+
+ LOCAL expptr
+#ifdef KR_headers
+putpower(p)
+ expptr p;
+#else
+putpower(expptr p)
+#endif
+{
+ expptr base;
+ Addrp t1, t2;
+ ftnint k;
+ int type;
+ char buf[80]; /* buffer for text of comment */
+
+ if(!ISICON(p->exprblock.rightp) ||
+ (k = p->exprblock.rightp->constblock.Const.ci)<2)
+ Fatal("putpower: bad call");
+ base = p->exprblock.leftp;
+ type = base->headblock.vtype;
+ t1 = mktmp(type, ENULL);
+ t2 = NULL;
+
+ free ((charptr) p);
+ p = putassign (cpexpr((expptr) t1), base);
+
+ sprintf (buf, "Computing %ld%s power", k,
+ k == 2 ? "nd" : k == 3 ? "rd" : "th");
+ p1_comment (buf);
+
+ for( ; (k&1)==0 && k>2 ; k>>=1 )
+ {
+ p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
+ }
+
+ if(k == 2) {
+
+/* Write the power computation out immediately */
+ putout (p);
+ p = putx( mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1)));
+ } else {
+ t2 = mktmp(type, ENULL);
+ p = mkexpr (OPCOMMA, p, putassign(cpexpr((expptr)t2),
+ cpexpr((expptr)t1)));
+
+ for(k>>=1 ; k>1 ; k>>=1)
+ {
+ p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
+ if(k & 1)
+ {
+ p = mkexpr (OPCOMMA, p, putsteq(t2, t1));
+ }
+ }
+/* Write the power computation out immediately */
+ putout (p);
+ p = putx( mkexpr(OPSTAR, cpexpr((expptr)t2),
+ mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1))));
+ }
+ frexpr((expptr)t1);
+ if(t2)
+ frexpr((expptr)t2);
+ return p;
+}
+
+
+
+
+ LOCAL Addrp
+#ifdef KR_headers
+intdouble(p)
+ Addrp p;
+#else
+intdouble(Addrp p)
+#endif
+{
+ register Addrp t;
+
+ t = mktmp(TYDREAL, ENULL);
+ putout (putassign(cpexpr((expptr)t), (expptr)p));
+ return(t);
+}
+
+
+
+
+
+/* Complex-type variable assignment */
+
+ LOCAL Addrp
+#ifdef KR_headers
+putcxeq(p)
+ register expptr p;
+#else
+putcxeq(register expptr p)
+#endif
+{
+ register Addrp lp, rp;
+ expptr code;
+
+ if(p->tag != TEXPR)
+ badtag("putcxeq", p->tag);
+
+ lp = putcx1(p->exprblock.leftp);
+ rp = putcx1(p->exprblock.rightp);
+ code = putassign ( (expptr)realpart(lp), (expptr)realpart(rp));
+
+ if( ISCOMPLEX(p->exprblock.vtype) )
+ {
+ code = mkexpr (OPCOMMA, code, putassign
+ (imagpart(lp), imagpart(rp)));
+ }
+ putout (code);
+ frexpr((expptr)rp);
+ free ((charptr) p);
+ return lp;
+}
+
+
+
+/* putcxop -- used to write out embedded calls to complex functions, and
+ complex arguments to procedures */
+
+ expptr
+#ifdef KR_headers
+putcxop(p)
+ expptr p;
+#else
+putcxop(expptr p)
+#endif
+{
+ return (expptr)putaddr((expptr)putcx1(p));
+}
+
+#define PAIR(x,y) mkexpr (OPCOMMA, (x), (y))
+
+ LOCAL Addrp
+#ifdef KR_headers
+putcx1(p)
+ register expptr p;
+#else
+putcx1(register expptr p)
+#endif
+{
+ expptr q;
+ Addrp lp, rp;
+ register Addrp resp;
+ int opcode;
+ int ltype, rtype;
+ long ts, tskludge;
+
+ if(p == NULL)
+ return(NULL);
+
+ switch(p->tag)
+ {
+ case TCONST:
+ if( ISCOMPLEX(p->constblock.vtype) )
+ p = (expptr) putconst((Constp)p);
+ return( (Addrp) p );
+
+ case TADDR:
+ resp = &p->addrblock;
+ if (addressable(p))
+ return (Addrp) p;
+ ts = tskludge = 0;
+ if (q = resp->memoffset) {
+ if (resp->uname_tag == UNAM_REF) {
+ q = cpexpr((tagptr)resp);
+ q->addrblock.vtype = tyint;
+ q->addrblock.cmplx_sub = 1;
+ p->addrblock.skip_offset = 1;
+ resp->user.name->vsubscrused = 1;
+ resp->uname_tag = UNAM_NAME;
+ tskludge = typesize[resp->vtype]
+ * (resp->Field ? 2 : 1);
+ }
+ else if (resp->isarray
+ && resp->vtype != TYCHAR) {
+ if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
+ && resp->uname_tag == UNAM_NAME)
+ q = mkexpr(OPMINUS, q,
+ mkintcon(resp->user.name->voffset));
+ ts = typesize[resp->vtype]
+ * (resp->Field ? 2 : 1);
+ q = resp->memoffset = mkexpr(OPSLASH, q,
+ ICON(ts));
+ }
+ }
+ resp = mktmp(tyint, ENULL);
+ putout(putassign(cpexpr((expptr)resp), q));
+ p->addrblock.memoffset = tskludge
+ ? mkexpr(OPSTAR, (expptr)resp, ICON(tskludge))
+ : (expptr)resp;
+ if (ts) {
+ resp = &p->addrblock;
+ q = mkexpr(OPSTAR, resp->memoffset, ICON(ts));
+ if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
+ && resp->uname_tag == UNAM_NAME)
+ q = mkexpr(OPPLUS, q,
+ mkintcon(resp->user.name->voffset));
+ resp->memoffset = q;
+ }
+ return (Addrp) p;
+
+ case TEXPR:
+ if( ISCOMPLEX(p->exprblock.vtype) )
+ break;
+ resp = mktmp(p->exprblock.vtype, ENULL);
+ /*first arg of above mktmp call was TYDREAL before 19950102 */
+ putout (putassign( cpexpr((expptr)resp), p));
+ return(resp);
+
+ case TERROR:
+ return NULL;
+
+ default:
+ badtag("putcx1", p->tag);
+ }
+
+ opcode = p->exprblock.opcode;
+ if(opcode==OPCALL || opcode==OPCCALL)
+ {
+ Addrp t;
+ p = putcall(p, &t);
+ putout(p);
+ return t;
+ }
+ else if(opcode == OPASSIGN)
+ {
+ return putcxeq (p);
+ }
+
+/* BUG (inefficient) Generates too many temporary variables */
+
+ resp = mktmp(p->exprblock.vtype, ENULL);
+ if(lp = putcx1(p->exprblock.leftp) )
+ ltype = lp->vtype;
+ if(rp = putcx1(p->exprblock.rightp) )
+ rtype = rp->vtype;
+
+ switch(opcode)
+ {
+ case OPCOMMA:
+ frexpr((expptr)resp);
+ resp = rp;
+ rp = NULL;
+ break;
+
+ case OPNEG:
+ case OPNEG1:
+ putout (PAIR (
+ putassign( (expptr)realpart(resp),
+ mkexpr(OPNEG, (expptr)realpart(lp), ENULL)),
+ putassign( imagpart(resp),
+ mkexpr(OPNEG, imagpart(lp), ENULL))));
+ break;
+
+ case OPPLUS:
+ case OPMINUS: { expptr r;
+ r = putassign( (expptr)realpart(resp),
+ mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp) ));
+ if(rtype < TYCOMPLEX)
+ q = putassign( imagpart(resp), imagpart(lp) );
+ else if(ltype < TYCOMPLEX)
+ {
+ if(opcode == OPPLUS)
+ q = putassign( imagpart(resp), imagpart(rp) );
+ else
+ q = putassign( imagpart(resp),
+ mkexpr(OPNEG, imagpart(rp), ENULL) );
+ }
+ else
+ q = putassign( imagpart(resp),
+ mkexpr(opcode, imagpart(lp), imagpart(rp) ));
+ r = PAIR (r, q);
+ putout (r);
+ break;
+ } /* case OPPLUS, OPMINUS: */
+ case OPSTAR:
+ if(ltype < TYCOMPLEX)
+ {
+ if( ISINT(ltype) )
+ lp = intdouble(lp);
+ putout (PAIR (
+ putassign( (expptr)realpart(resp),
+ mkexpr(OPSTAR, cpexpr((expptr)lp),
+ (expptr)realpart(rp))),
+ putassign( imagpart(resp),
+ mkexpr(OPSTAR, cpexpr((expptr)lp), imagpart(rp)))));
+ }
+ else if(rtype < TYCOMPLEX)
+ {
+ if( ISINT(rtype) )
+ rp = intdouble(rp);
+ putout (PAIR (
+ putassign( (expptr)realpart(resp),
+ mkexpr(OPSTAR, cpexpr((expptr)rp),
+ (expptr)realpart(lp))),
+ putassign( imagpart(resp),
+ mkexpr(OPSTAR, cpexpr((expptr)rp), imagpart(lp)))));
+ }
+ else {
+ putout (PAIR (
+ putassign( (expptr)realpart(resp), mkexpr(OPMINUS,
+ mkexpr(OPSTAR, (expptr)realpart(lp),
+ (expptr)realpart(rp)),
+ mkexpr(OPSTAR, imagpart(lp), imagpart(rp)))),
+ putassign( imagpart(resp), mkexpr(OPPLUS,
+ mkexpr(OPSTAR, (expptr)realpart(lp), imagpart(rp)),
+ mkexpr(OPSTAR, imagpart(lp),
+ (expptr)realpart(rp))))));
+ }
+ break;
+
+ case OPSLASH:
+ /* fixexpr has already replaced all divisions
+ * by a complex by a function call
+ */
+ if( ISINT(rtype) )
+ rp = intdouble(rp);
+ putout (PAIR (
+ putassign( (expptr)realpart(resp),
+ mkexpr(OPSLASH, (expptr)realpart(lp), cpexpr((expptr)rp))),
+ putassign( imagpart(resp),
+ mkexpr(OPSLASH, imagpart(lp), cpexpr((expptr)rp)))));
+ break;
+
+ case OPCONV:
+ if (!lp)
+ break;
+ if(ISCOMPLEX(lp->vtype) )
+ q = imagpart(lp);
+ else if(rp != NULL)
+ q = (expptr) realpart(rp);
+ else
+ q = mkrealcon(TYDREAL, "0");
+ putout (PAIR (
+ putassign( (expptr)realpart(resp), (expptr)realpart(lp)),
+ putassign( imagpart(resp), q)));
+ break;
+
+ default:
+ badop("putcx1", opcode);
+ }
+
+ frexpr((expptr)lp);
+ frexpr((expptr)rp);
+ free( (charptr) p );
+ return(resp);
+}
+
+
+
+
+/* Only .EQ. and .NE. may be performed on COMPLEX data, other relations
+ are not defined */
+
+ LOCAL expptr
+#ifdef KR_headers
+putcxcmp(p)
+ register expptr p;
+#else
+putcxcmp(register expptr p)
+#endif
+{
+ int opcode;
+ register Addrp lp, rp;
+ expptr q;
+
+ if(p->tag != TEXPR)
+ badtag("putcxcmp", p->tag);
+
+ opcode = p->exprblock.opcode;
+ lp = putcx1(p->exprblock.leftp);
+ rp = putcx1(p->exprblock.rightp);
+
+ q = mkexpr( opcode==OPEQ ? OPAND : OPOR ,
+ mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp)),
+ mkexpr(opcode, imagpart(lp), imagpart(rp)) );
+
+ free( (charptr) lp);
+ free( (charptr) rp);
+ free( (charptr) p );
+ if (ISCONST(q))
+ return q;
+ return putx( fixexpr((Exprp)q) );
+}
+
+/* putch1 -- Forces constants into the literal pool, among other things */
+
+ LOCAL Addrp
+#ifdef KR_headers
+putch1(p)
+ register expptr p;
+#else
+putch1(register expptr p)
+#endif
+{
+ Addrp t;
+ expptr e;
+
+ switch(p->tag)
+ {
+ case TCONST:
+ return( putconst((Constp)p) );
+
+ case TADDR:
+ return( (Addrp) p );
+
+ case TEXPR:
+ switch(p->exprblock.opcode)
+ {
+ expptr q;
+
+ case OPCALL:
+ case OPCCALL:
+
+ p = putcall(p, &t);
+ putout (p);
+ break;
+
+ case OPCONCAT:
+ t = mktmp(TYCHAR, ICON(lencat(p)));
+ q = (expptr) cpexpr(p->headblock.vleng);
+ p = putcat( cpexpr((expptr)t), p );
+ /* put the correct length on the block */
+ frexpr(t->vleng);
+ t->vleng = q;
+ putout (p);
+ break;
+
+ case OPCONV:
+ if(!ISICON(p->exprblock.vleng)
+ || p->exprblock.vleng->constblock.Const.ci!=1
+ || ! INT(p->exprblock.leftp->headblock.vtype) )
+ Fatal("putch1: bad character conversion");
+ t = mktmp(TYCHAR, ICON(1));
+ e = mkexpr(OPCONV, (expptr)t, ENULL);
+ e->headblock.vtype = TYCHAR;
+ p = putop( mkexpr(OPASSIGN, cpexpr(e), p));
+ putout (p);
+ break;
+ default:
+ badop("putch1", p->exprblock.opcode);
+ }
+ return(t);
+
+ default:
+ badtag("putch1", p->tag);
+ }
+ /* NOT REACHED */ return 0;
+}
+
+
+/* putchop -- Write out a character actual parameter; that is, this is
+ part of a procedure invocation */
+
+ Addrp
+#ifdef KR_headers
+putchop(p)
+ expptr p;
+#else
+putchop(expptr p)
+#endif
+{
+ p = putaddr((expptr)putch1(p));
+ return (Addrp)p;
+}
+
+
+
+
+ LOCAL expptr
+#ifdef KR_headers
+putcheq(p)
+ register expptr p;
+#else
+putcheq(register expptr p)
+#endif
+{
+ expptr lp, rp;
+ int nbad;
+
+ if(p->tag != TEXPR)
+ badtag("putcheq", p->tag);
+
+ lp = p->exprblock.leftp;
+ rp = p->exprblock.rightp;
+ frexpr(p->exprblock.vleng);
+ free( (charptr) p );
+
+/* If s = t // u, don't bother copying the result, write it directly into
+ this buffer */
+
+ nbad = badchleng(lp) + badchleng(rp);
+ if( rp->tag==TEXPR && rp->exprblock.opcode==OPCONCAT )
+ p = putcat(lp, rp);
+ else if( !nbad
+ && ISONE(lp->headblock.vleng)
+ && ISONE(rp->headblock.vleng) ) {
+ lp = mkexpr(OPCONV, lp, ENULL);
+ rp = mkexpr(OPCONV, rp, ENULL);
+ lp->headblock.vtype = rp->headblock.vtype = TYCHAR;
+ p = putop(mkexpr(OPASSIGN, lp, rp));
+ }
+ else
+ p = putx( call2(TYSUBR, "s_copy", lp, rp) );
+ return p;
+}
+
+
+
+
+ LOCAL expptr
+#ifdef KR_headers
+putchcmp(p)
+ register expptr p;
+#else
+putchcmp(register expptr p)
+#endif
+{
+ expptr lp, rp;
+
+ if(p->tag != TEXPR)
+ badtag("putchcmp", p->tag);
+
+ lp = p->exprblock.leftp;
+ rp = p->exprblock.rightp;
+
+ if(ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) ) {
+ lp = mkexpr(OPCONV, lp, ENULL);
+ rp = mkexpr(OPCONV, rp, ENULL);
+ lp->headblock.vtype = rp->headblock.vtype = TYCHAR;
+ }
+ else {
+ lp = call2(TYINT,"s_cmp", lp, rp);
+ rp = ICON(0);
+ }
+ p->exprblock.leftp = lp;
+ p->exprblock.rightp = rp;
+ p = putop(p);
+ return p;
+}
+
+
+
+
+
+/* putcat -- Writes out a concatenation operation. Two temporary arrays
+ are allocated, putct1() is called to initialize them, and then a
+ call to runtime library routine s_cat() is inserted.
+
+ This routine generates code which will perform an (nconc lhs rhs)
+ at runtime. The runtime funciton does not return a value, the routine
+ that calls this putcat must remember the name of lhs.
+*/
+
+
+ LOCAL expptr
+#ifdef KR_headers
+putcat(lhs0, rhs)
+ expptr lhs0;
+ register expptr rhs;
+#else
+putcat(expptr lhs0, register expptr rhs)
+#endif
+{
+ register Addrp lhs = (Addrp)lhs0;
+ int n, tyi;
+ Addrp length_var, string_var;
+ expptr p;
+ static char Writing_concatenation[] = "Writing concatenation";
+
+/* Create the temporary arrays */
+
+ n = ncat(rhs);
+ length_var = mktmpn(n, tyioint, ENULL);
+ string_var = mktmpn(n, TYADDR, ENULL);
+ frtemp((Addrp)cpexpr((expptr)length_var));
+ frtemp((Addrp)cpexpr((expptr)string_var));
+
+/* Initialize the arrays */
+
+ n = 0;
+ /* p1_comment scribbles on its argument, so we
+ * cannot safely pass a string literal here. */
+ p1_comment(Writing_concatenation);
+ putct1(rhs, length_var, string_var, &n);
+
+/* Create the invocation */
+
+ tyi = tyint;
+ tyint = tyioint; /* for -I2 */
+ p = putx (call4 (TYSUBR, "s_cat",
+ (expptr)lhs,
+ (expptr)string_var,
+ (expptr)length_var,
+ (expptr)putconst((Constp)ICON(n))));
+ tyint = tyi;
+
+ return p;
+}
+
+
+
+
+
+ LOCAL void
+#ifdef KR_headers
+putct1(q, length_var, string_var, ip)
+ register expptr q;
+ register Addrp length_var;
+ register Addrp string_var;
+ int *ip;
+#else
+putct1(register expptr q, register Addrp length_var, register Addrp string_var, int *ip)
+#endif
+{
+ int i;
+ Addrp length_copy, string_copy;
+ expptr e;
+ extern int szleng;
+
+ if(q->tag==TEXPR && q->exprblock.opcode==OPCONCAT)
+ {
+ putct1(q->exprblock.leftp, length_var, string_var,
+ ip);
+ putct1(q->exprblock.rightp, length_var, string_var,
+ ip);
+ frexpr (q -> exprblock.vleng);
+ free ((charptr) q);
+ }
+ else
+ {
+ i = (*ip)++;
+ e = cpexpr(q->headblock.vleng);
+ if (!e)
+ return; /* error -- character*(*) */
+ length_copy = (Addrp) cpexpr((expptr)length_var);
+ length_copy->memoffset =
+ mkexpr(OPPLUS,length_copy->memoffset, ICON(i*szleng));
+ string_copy = (Addrp) cpexpr((expptr)string_var);
+ string_copy->memoffset =
+ mkexpr(OPPLUS, string_copy->memoffset,
+ ICON(i*typesize[TYADDR]));
+ putout (PAIR (putassign((expptr)length_copy, e),
+ putassign((expptr)string_copy, addrof((expptr)putch1(q)))));
+ }
+}
+
+/* putaddr -- seems to write out function invocation actual parameters */
+
+ LOCAL expptr
+#ifdef KR_headers
+putaddr(p0)
+ expptr p0;
+#else
+putaddr(expptr p0)
+#endif
+{
+ register Addrp p;
+ chainp cp;
+
+ if (!(p = (Addrp)p0))
+ return ENULL;
+
+ if( p->tag==TERROR || (p->memoffset!=NULL && ISERROR(p->memoffset)) )
+ {
+ frexpr((expptr)p);
+ return ENULL;
+ }
+ if (p->isarray && p->memoffset)
+ if (p->uname_tag == UNAM_REF) {
+ cp = p->memoffset->listblock.listp;
+ for(; cp; cp = cp->nextp)
+ cp->datap = (char *)fixtype((tagptr)cp->datap);
+ }
+ else
+ p->memoffset = putx(p->memoffset);
+ return (expptr) p;
+}
+
+ LOCAL expptr
+#ifdef KR_headers
+addrfix(e)
+ expptr e;
+#else
+addrfix(expptr e)
+#endif
+ /* fudge character string length if it's a TADDR */
+{
+ return e->tag == TADDR ? mkexpr(OPIDENTITY, e, ENULL) : e;
+ }
+
+ LOCAL int
+#ifdef KR_headers
+typekludge(ccall, q, at, j)
+ int ccall;
+ register expptr q;
+ Atype *at;
+ int j;
+#else
+typekludge(int ccall, register expptr q, Atype *at, int j)
+#endif
+ /* j = alternate type */
+{
+ register int i, k;
+ extern int iocalladdr;
+ register Namep np;
+
+ /* Return value classes:
+ * < 100 ==> Fortran arg (pointer to type)
+ * < 200 ==> C arg
+ * < 300 ==> procedure arg
+ * < 400 ==> external, no explicit type
+ * < 500 ==> arg that may turn out to be
+ * either a variable or a procedure
+ */
+
+ k = q->headblock.vtype;
+ if (ccall) {
+ if (k == TYREAL)
+ k = TYDREAL; /* force double for library routines */
+ return k + 100;
+ }
+ if (k == TYADDR)
+ return iocalladdr;
+ i = q->tag;
+ if ((i == TEXPR && q->exprblock.opcode != OPCOMMA_ARG)
+ || (i == TADDR && q->addrblock.charleng)
+ || i == TCONST)
+ k = TYFTNLEN + 100;
+ else if (i == TADDR)
+ switch(q->addrblock.vclass) {
+ case CLPROC:
+ if (q->addrblock.uname_tag != UNAM_NAME)
+ k += 200;
+ else if ((np = q->addrblock.user.name)->vprocclass
+ != PTHISPROC) {
+ if (k && !np->vimpltype)
+ k += 200;
+ else {
+ if (j > 200 && infertypes && j < 300) {
+ k = j;
+ inferdcl(np, j-200);
+ }
+ else k = (np->vstg == STGEXT
+ ? extsymtab[np->vardesc.varno].extype
+ : 0) + 200;
+ at->cp = mkchain((char *)np, at->cp);
+ }
+ }
+ else if (k == TYSUBR)
+ k += 200;
+ break;
+
+ case CLUNKNOWN:
+ if (q->addrblock.vstg == STGARG
+ && q->addrblock.uname_tag == UNAM_NAME) {
+ k += 400;
+ at->cp = mkchain((char *)q->addrblock.user.name,
+ at->cp);
+ }
+ }
+ else if (i == TNAME && q->nameblock.vstg == STGARG) {
+ np = &q->nameblock;
+ switch(np->vclass) {
+ case CLPROC:
+ if (!np->vimpltype)
+ k += 200;
+ else if (j <= 200 || !infertypes || j >= 300)
+ k += 300;
+ else {
+ k = j;
+ inferdcl(np, j-200);
+ }
+ goto add2chain;
+
+ case CLUNKNOWN:
+ /* argument may be a scalar variable or a function */
+ if (np->vimpltype && j && infertypes
+ && j < 300) {
+ inferdcl(np, j % 100);
+ k = j;
+ }
+ else
+ k += 400;
+
+ /* to handle procedure args only so far known to be
+ * external, save a pointer to the symbol table entry...
+ */
+ add2chain:
+ at->cp = mkchain((char *)np, at->cp);
+ }
+ }
+ return k;
+ }
+
+ char *
+#ifdef KR_headers
+Argtype(k, buf)
+ int k;
+ char *buf;
+#else
+Argtype(int k, char *buf)
+#endif
+{
+ if (k < 100) {
+ sprintf(buf, "%s variable", ftn_types[k]);
+ return buf;
+ }
+ if (k < 200) {
+ k -= 100;
+ return ftn_types[k];
+ }
+ if (k < 300) {
+ k -= 200;
+ if (k == TYSUBR)
+ return ftn_types[TYSUBR];
+ sprintf(buf, "%s function", ftn_types[k]);
+ return buf;
+ }
+ if (k < 400)
+ return "external argument";
+ k -= 400;
+ sprintf(buf, "%s argument", ftn_types[k]);
+ return buf;
+ }
+
+ static void
+#ifdef KR_headers
+atype_squawk(at, msg)
+ Argtypes *at;
+ char *msg;
+#else
+atype_squawk(Argtypes *at, char *msg)
+#endif
+{
+ register Atype *a, *ae;
+ warn(msg);
+ for(a = at->atypes, ae = a + at->nargs; a < ae; a++)
+ frchain(&a->cp);
+ at->nargs = -1;
+ if (at->changes & 2 && !at->defined)
+ proc_protochanges++;
+ }
+
+ static char inconsist[] = "inconsistent calling sequences for ";
+
+ void
+#ifdef KR_headers
+bad_atypes(at, fname, i, j, k, here, prev)
+ Argtypes *at;
+ char *fname;
+ int i;
+ int j;
+ int k;
+ char *here;
+ char *prev;
+#else
+bad_atypes(Argtypes *at, char *fname, int i, int j, int k, char *here, char *prev)
+#endif
+{
+ char buf[208], buf1[32], buf2[32];
+
+ sprintf(buf, "%s%.90s,\n\targ %d: %s%s%s %s.",
+ inconsist, fname, i, here, Argtype(k, buf1),
+ prev, Argtype(j, buf2));
+ atype_squawk(at, buf);
+ }
+
+ int
+#ifdef KR_headers
+type_fixup(at, a, k)
+ Argtypes *at;
+ Atype *a;
+ int k;
+#else
+type_fixup(Argtypes *at, Atype *a, int k)
+#endif
+{
+ register struct Entrypoint *ep;
+ if (!infertypes)
+ return 0;
+ for(ep = entries; ep; ep = ep->entnextp)
+ if (ep->entryname && at == ep->entryname->arginfo) {
+ a->type = k % 100;
+ return proc_argchanges = 1;
+ }
+ return 0;
+ }
+
+
+ void
+#ifdef KR_headers
+save_argtypes(arglist, at0, at1, ccall, fname, stg, nchargs, type, zap)
+ chainp arglist;
+ Argtypes **at0;
+ Argtypes **at1;
+ int ccall;
+ char *fname;
+ int stg;
+ int nchargs;
+ int type;
+ int zap;
+#else
+save_argtypes(chainp arglist, Argtypes **at0, Argtypes **at1, int ccall, char *fname, int stg, int nchargs, int type, int zap)
+#endif
+{
+ Argtypes *at;
+ chainp cp;
+ int i, i0, j, k, nargs, nbad, *t, *te;
+ Atype *atypes;
+ expptr q;
+ char buf[208], buf1[32], buf2[32];
+ static int initargs[4] = {TYCOMPLEX, TYDCOMPLEX, TYCHAR, TYFTNLEN+100};
+ static int *init_ap[TYSUBR+1] = {0,0,0,0,0,0,0,
+#ifdef TYQUAD
+ 0,
+#endif
+ initargs, initargs+1,0,0,0,initargs+2};
+
+ i0 = init_ac[type];
+ t = init_ap[type];
+ te = t + i0;
+ if (at = *at0) {
+ *at1 = at;
+ nargs = at->nargs;
+ if (nargs < 0 && type && at->changes & 2 && !at->defined)
+ --proc_protochanges;
+ if (at->dnargs >= 0 && zap != 2)
+ type = 0;
+ if (nargs < 0) { /* inconsistent usage seen */
+ if (type)
+ goto newlist;
+ return;
+ }
+ atypes = at->atypes;
+ i = nchargs;
+ for(nbad = 0; t < te; atypes++) {
+ if (++i > nargs) {
+ toomany:
+ i = nchargs + i0;
+ for(cp = arglist; cp; cp = cp->nextp)
+ i++;
+ toofew:
+ switch(zap) {
+ case 2: zap = 6; break;
+ case 1: if (at->defined & 4)
+ return;
+ }
+ sprintf(buf,
+ "%s%.90s:\n\there %d, previously %d args and string lengths.",
+ inconsist, fname, i, nargs);
+ atype_squawk(at, buf);
+ if (type) {
+ t = init_ap[type];
+ goto newlist;
+ }
+ return;
+ }
+ j = atypes->type;
+ k = *t++;
+ if (j != k && j-400 != k) {
+ cp = 0;
+ goto badtypes;
+ }
+ }
+ for(cp = arglist; cp; atypes++, cp = cp->nextp) {
+ if (++i > nargs)
+ goto toomany;
+ j = atypes->type;
+ if (!(q = (expptr)cp->datap))
+ continue;
+ k = typekludge(ccall, q, atypes, j);
+ if (k >= 300 || k == j)
+ continue;
+ if (j >= 300) {
+ if (k >= 200) {
+ if (k == TYUNKNOWN + 200)
+ continue;
+ if (j % 100 != k - 200
+ && k != TYSUBR + 200
+ && j != TYUNKNOWN + 300
+ && !type_fixup(at,atypes,k))
+ goto badtypes;
+ }
+ else if (j % 100 % TYSUBR != k % TYSUBR
+ && !type_fixup(at,atypes,k))
+ goto badtypes;
+ }
+ else if (k < 200 || j < 200)
+ if (j) {
+ if (k == TYUNKNOWN
+ && q->tag == TNAME
+ && q->nameblock.vinfproc) {
+ q->nameblock.vdcldone = 0;
+ impldcl((Namep)q);
+ }
+ goto badtypes;
+ }
+ else ; /* fall through to update */
+ else if (k == TYUNKNOWN+200)
+ continue;
+ else if (j != TYUNKNOWN+200)
+ {
+ badtypes:
+ if (++nbad == 1)
+ bad_atypes(at, fname, i - nchargs,
+ j, k, "here ", ", previously");
+ else
+ fprintf(stderr,
+ "\targ %d: here %s, previously %s.\n",
+ i - nchargs, Argtype(k,buf1),
+ Argtype(j,buf2));
+ if (!cp)
+ break;
+ continue;
+ }
+ /* We've subsequently learned the right type,
+ as in the call on zoo below...
+
+ subroutine foo(x, zap)
+ external zap
+ call goo(zap)
+ x = zap(3)
+ call zoo(zap)
+ end
+ */
+ if (!nbad) {
+ atypes->type = k;
+ at->changes |= 1;
+ }
+ }
+ if (i < nargs)
+ goto toofew;
+ if (nbad) {
+ if (type) {
+ /* we're defining the procedure */
+ t = init_ap[type];
+ te = t + i0;
+ proc_argchanges = 1;
+ goto newlist;
+ }
+ return;
+ }
+ if (zap == 1 && (at->changes & 5) != 5)
+ at->changes = 0;
+ return;
+ }
+ newlist:
+ i = i0 + nchargs;
+ for(cp = arglist; cp; cp = cp->nextp)
+ i++;
+ k = sizeof(Argtypes) + (i-1)*sizeof(Atype);
+ *at0 = *at1 = at = stg == STGEXT ? (Argtypes *)gmem(k,1)
+ : (Argtypes *) mem(k,1);
+ at->dnargs = at->nargs = i;
+ at->defined = zap & 6;
+ at->changes = type ? 0 : 4;
+ atypes = at->atypes;
+ for(; t < te; atypes++) {
+ atypes->type = *t++;
+ atypes->cp = 0;
+ }
+ for(cp = arglist; cp; atypes++, cp = cp->nextp) {
+ atypes->cp = 0;
+ atypes->type = (q = (expptr)cp->datap)
+ ? typekludge(ccall, q, atypes, 0)
+ : 0;
+ }
+ for(; --nchargs >= 0; atypes++) {
+ atypes->type = TYFTNLEN + 100;
+ atypes->cp = 0;
+ }
+ }
+
+ static char*
+#ifdef KR_headers
+get_argtypes(p, pat0, pat1) Exprp p; Argtypes ***pat0, ***pat1;
+#else
+get_argtypes(Exprp p, Argtypes ***pat0, Argtypes ***pat1)
+#endif
+{
+ Addrp a;
+ Argtypes **at0, **at1;
+ Namep np;
+ expptr rp;
+ Extsym *e;
+ char *fname;
+
+ a = (Addrp)p->leftp;
+ switch(a->vstg) {
+ case STGEXT:
+ switch(a->uname_tag) {
+ case UNAM_EXTERN: /* e.g., sqrt() */
+ e = extsymtab + a->memno;
+ at0 = at1 = &e->arginfo;
+ fname = e->fextname;
+ break;
+ case UNAM_NAME:
+ np = a->user.name;
+ at0 = &extsymtab[np->vardesc.varno].arginfo;
+ at1 = &np->arginfo;
+ fname = np->fvarname;
+ break;
+ default:
+ goto bug;
+ }
+ break;
+ case STGARG:
+ if (a->uname_tag != UNAM_NAME)
+ goto bug;
+ np = a->user.name;
+ at0 = at1 = &np->arginfo;
+ fname = np->fvarname;
+ break;
+ default:
+ bug:
+ Fatal("Confusion in saveargtypes");
+ }
+ *pat0 = at0;
+ *pat1 = at1;
+ return fname;
+ }
+
+ void
+#ifdef KR_headers
+saveargtypes(p)
+ register Exprp p;
+#else
+saveargtypes(register Exprp p)
+#endif
+ /* for writing prototypes */
+{
+ Argtypes **at0, **at1;
+ chainp arglist;
+ expptr rp;
+ char *fname;
+
+ fname = get_argtypes(p, &at0, &at1);
+ rp = p->rightp;
+ arglist = rp && rp->tag == TLIST ? rp->listblock.listp : 0;
+ save_argtypes(arglist, at0, at1, p->opcode == OPCCALL,
+ fname, p->leftp->addrblock.vstg, 0, 0, 0);
+ }
+
+/* putcall - fix up the argument list, and write out the invocation. p
+ is expected to be initialized and point to an OPCALL or OPCCALL
+ expression. The return value is a pointer to a temporary holding the
+ result of a COMPLEX or CHARACTER operation, or NULL. */
+
+ LOCAL expptr
+#ifdef KR_headers
+putcall(p0, temp)
+ expptr p0;
+ Addrp *temp;
+#else
+putcall(expptr p0, Addrp *temp)
+#endif
+{
+ register Exprp p = (Exprp)p0;
+ chainp arglist; /* Pointer to actual arguments, if any */
+ chainp charsp; /* List of copies of the variables which
+ hold the lengths of character
+ parameters (other than procedure
+ parameters) */
+ chainp cp; /* Iterator over argument lists */
+ register expptr q; /* Pointer to the current argument */
+ Addrp fval; /* Function return value */
+ int type; /* type of the call - presumably this was
+ set elsewhere */
+ int byvalue; /* True iff we don't want to massage the
+ parameter list, since we're calling a C
+ library routine */
+ char *s;
+ Argtypes *at, **at0, **at1;
+ Atype *At, *Ate;
+
+ type = p -> vtype;
+ charsp = NULL;
+ byvalue = (p->opcode == OPCCALL);
+
+/* Verify the actual parameters */
+
+ if (p == (Exprp) NULL)
+ err ("putcall: NULL call expression");
+ else if (p -> tag != TEXPR)
+ erri ("putcall: expected TEXPR, got '%d'", p -> tag);
+
+/* Find the argument list */
+
+ if(p->rightp && p -> rightp -> tag == TLIST)
+ arglist = p->rightp->listblock.listp;
+ else
+ arglist = NULL;
+
+/* Count the number of explicit arguments, including lengths of character
+ variables */
+
+ if (!byvalue) {
+ get_argtypes(p, &at0, &at1);
+ At = Ate = 0;
+ if ((at = *at0) && at->nargs >= 0) {
+ At = at->atypes;
+ Ate = At + at->nargs;
+ At += init_ac[type];
+ }
+ for(cp = arglist ; cp ; cp = cp->nextp) {
+ q = (expptr) cp->datap;
+ if( ISCONST(q) ) {
+
+/* Even constants are passed by reference, so we need to put them in the
+ literal table */
+
+ q = (expptr) putconst((Constp)q);
+ cp->datap = (char *) q;
+ }
+
+/* Save the length expression of character variables (NOT character
+ procedures) for the end of the argument list */
+
+ if( ISCHAR(q) &&
+ (q->headblock.vclass != CLPROC
+ || q->headblock.vstg == STGARG
+ && q->tag == TADDR
+ && q->addrblock.uname_tag == UNAM_NAME
+ && q->addrblock.user.name->vprocclass == PTHISPROC)
+ && (!At || At->type % 100 % TYSUBR == TYCHAR))
+ {
+ p0 = cpexpr(q->headblock.vleng);
+ charsp = mkchain((char *)p0, charsp);
+ if (q->headblock.vclass == CLUNKNOWN
+ && q->headblock.vstg == STGARG)
+ q->addrblock.user.name->vpassed = 1;
+ else if (q->tag == TADDR
+ && q->addrblock.uname_tag == UNAM_CONST)
+ p0->constblock.Const.ci
+ += q->addrblock.user.Const.ccp1.blanks;
+ }
+ if (At && ++At == Ate)
+ At = 0;
+ }
+ }
+ charsp = revchain(charsp);
+
+/* If the routine is a CHARACTER function ... */
+
+ if(type == TYCHAR)
+ {
+ if( ISICON(p->vleng) )
+ {
+
+/* Allocate a temporary to hold the return value of the function */
+
+ fval = mktmp(TYCHAR, p->vleng);
+ }
+ else {
+ err("adjustable character function");
+ if (temp)
+ *temp = 0;
+ return 0;
+ }
+ }
+
+/* If the routine is a COMPLEX function ... */
+
+ else if( ISCOMPLEX(type) )
+ fval = mktmp(type, ENULL);
+ else
+ fval = NULL;
+
+/* Write the function name, without taking its address */
+
+ p -> leftp = putx(fixtype(putaddr(p->leftp)));
+
+ if(fval)
+ {
+ chainp prepend;
+
+/* Prepend a copy of the function return value buffer out as the first
+ argument. */
+
+ prepend = mkchain((char *)putx(putaddr(cpexpr((expptr)fval))), arglist);
+
+/* If it's a character function, also prepend the length of the result */
+
+ if(type==TYCHAR)
+ {
+
+ prepend->nextp = mkchain((char *)putx(mkconv(TYLENG,
+ p->vleng)), arglist);
+ }
+ if (!(q = p->rightp))
+ p->rightp = q = (expptr)mklist(CHNULL);
+ q->listblock.listp = prepend;
+ }
+
+/* Scan through the fortran argument list */
+
+ for(cp = arglist ; cp ; cp = cp->nextp)
+ {
+ q = (expptr) (cp->datap);
+ if (q == ENULL)
+ err ("putcall: NULL argument");
+
+/* call putaddr only when we've got a parameter for a C routine or a
+ memory resident parameter */
+
+ if (q -> tag == TCONST && !byvalue)
+ q = (expptr) putconst ((Constp)q);
+
+ if(q->tag==TADDR && (byvalue || q->addrblock.vstg!=STGREG) ) {
+ if (q->addrblock.parenused
+ && !byvalue && q->headblock.vtype != TYCHAR)
+ goto make_copy;
+ cp->datap = (char *)putaddr(q);
+ }
+ else if( ISCOMPLEX(q->headblock.vtype) )
+ cp -> datap = (char *) putx (fixtype(putcxop(q)));
+ else if (ISCHAR(q) )
+ cp -> datap = (char *) putx (fixtype((expptr)putchop(q)));
+ else if( ! ISERROR(q) )
+ {
+ if(byvalue) {
+ if (q->tag == TEXPR && q->exprblock.opcode == OPCONV) {
+ if (ISCOMPLEX(q->exprblock.leftp->headblock.vtype)
+ && q->exprblock.leftp->tag == TEXPR)
+ q->exprblock.leftp = putcxop(q->exprblock.leftp);
+ else
+ q->exprblock.leftp = putx(q->exprblock.leftp);
+ }
+ else
+ cp -> datap = (char *) putx(q);
+ }
+ else if (q->tag == TEXPR && q->exprblock.opcode == OPCHARCAST)
+ cp -> datap = (char *) putx(q);
+ else {
+ expptr t, t1;
+
+/* If we've got a register parameter, or (maybe?) a constant, save it in a
+ temporary first */
+ make_copy:
+ t = (expptr) mktmp(q->headblock.vtype, q->headblock.vleng);
+
+/* Assign to temporary variables before invoking the subroutine or
+ function */
+
+ t1 = putassign( cpexpr(t), q );
+ if (doin_setbound)
+ t = mkexpr(OPCOMMA_ARG, t1, t);
+ else
+ putout(t1);
+ cp -> datap = (char *) t;
+ } /* else */
+ } /* if !ISERROR(q) */
+ }
+
+/* Now adjust the lengths of the CHARACTER parameters */
+
+ for(cp = charsp ; cp ; cp = cp->nextp)
+ cp->datap = (char *)addrfix(putx(
+ /* in case MAIN has a character*(*)... */
+ (s = cp->datap) ? mkconv(TYLENG,(expptr)s)
+ : ICON(0)));
+
+/* ... and add them to the end of the argument list */
+
+ hookup (arglist, charsp);
+
+/* Return the name of the temporary used to hold the results, if any was
+ necessary. */
+
+ if (temp) *temp = fval;
+ else frexpr ((expptr)fval);
+
+ saveargtypes(p);
+
+ return (expptr) p;
+}
+
+
+
+/* putmnmx -- Put min or max. p must point to an EXPR, not just a
+ CONST */
+
+ LOCAL expptr
+#ifdef KR_headers
+putmnmx(p)
+ register expptr p;
+#else
+putmnmx(register expptr p)
+#endif
+{
+ int op, op2, type;
+ expptr arg, qp, temp;
+ chainp p0, p1;
+ Addrp sp, tp;
+ char comment_buf[80];
+ char *what;
+
+ if(p->tag != TEXPR)
+ badtag("putmnmx", p->tag);
+
+ type = p->exprblock.vtype;
+ op = p->exprblock.opcode;
+ op2 = op == OPMIN ? OPMIN2 : OPMAX2;
+ p0 = p->exprblock.leftp->listblock.listp;
+ free( (charptr) (p->exprblock.leftp) );
+ free( (charptr) p );
+
+ /* special case for two addressable operands */
+
+ if (addressable((expptr)p0->datap)
+ && (p1 = p0->nextp)
+ && addressable((expptr)p1->datap)
+ && !p1->nextp) {
+ if (type == TYREAL && forcedouble)
+ op2 = op == OPMIN ? OPDMIN : OPDMAX;
+ p = mkexpr(op2, mkconv(type, cpexpr((expptr)p0->datap)),
+ mkconv(type, cpexpr((expptr)p1->datap)));
+ frchain(&p0);
+ return p;
+ }
+
+ /* general case */
+
+ sp = mktmp(type, ENULL);
+
+/* We only need a second temporary if the arg list has an unaddressable
+ value */
+
+ tp = (Addrp) NULL;
+ qp = ENULL;
+ for (p1 = p0 -> nextp; p1; p1 = p1 -> nextp)
+ if (!addressable ((expptr) p1 -> datap)) {
+ tp = mktmp(type, ENULL);
+ qp = mkexpr(op2, cpexpr((expptr)sp), cpexpr((expptr)tp));
+ qp = fixexpr((Exprp)qp);
+ break;
+ } /* if */
+
+/* Now output the appropriate number of assignments and comparisons. Min
+ and max are implemented by the simple O(n) algorithm:
+
+ min (a, b, c, d) ==>
+ { <type> t1, t2;
+
+ t1 = a;
+ t2 = b; t1 = (t1 < t2) ? t1 : t2;
+ t2 = c; t1 = (t1 < t2) ? t1 : t2;
+ t2 = d; t1 = (t1 < t2) ? t1 : t2;
+ }
+*/
+
+ if (!doin_setbound) {
+ switch(op) {
+ case OPLT:
+ case OPMIN:
+ case OPDMIN:
+ case OPMIN2:
+ what = "IN";
+ break;
+ default:
+ what = "AX";
+ }
+ sprintf (comment_buf, "Computing M%s", what);
+ p1_comment (comment_buf);
+ }
+
+ p1 = p0->nextp;
+ temp = (expptr)p0->datap;
+ if (addressable(temp) && addressable((expptr)p1->datap)) {
+ p = mkconv(type, cpexpr(temp));
+ arg = mkconv(type, cpexpr((expptr)p1->datap));
+ temp = mkexpr(op2, p, arg);
+ if (!ISCONST(temp))
+ temp = fixexpr((Exprp)temp);
+ p1 = p1->nextp;
+ }
+ p = putassign (cpexpr((expptr)sp), temp);
+
+ for(; p1 ; p1 = p1->nextp)
+ {
+ if (addressable ((expptr) p1 -> datap)) {
+ arg = mkconv(type, cpexpr((expptr)p1->datap));
+ temp = mkexpr(op2, cpexpr((expptr)sp), arg);
+ temp = fixexpr((Exprp)temp);
+ } else {
+ temp = (expptr) cpexpr (qp);
+ p = mkexpr(OPCOMMA, p,
+ putassign(cpexpr((expptr)tp), (expptr)p1->datap));
+ } /* else */
+
+ if(p1->nextp)
+ p = mkexpr(OPCOMMA, p,
+ putassign(cpexpr((expptr)sp), temp));
+ else {
+ if (type == TYREAL && forcedouble)
+ temp->exprblock.opcode =
+ op == OPMIN ? OPDMIN : OPDMAX;
+ if (doin_setbound)
+ p = mkexpr(OPCOMMA, p, temp);
+ else {
+ putout (p);
+ p = putx(temp);
+ }
+ if (qp)
+ frexpr (qp);
+ } /* else */
+ } /* for */
+
+ frchain( &p0 );
+ return p;
+}
+
+
+ void
+#ifdef KR_headers
+putwhile(p)
+ expptr p;
+#else
+putwhile(expptr p)
+#endif
+{
+ long where;
+ int k, n;
+
+ if (wh_next >= wh_last)
+ {
+ k = wh_last - wh_first;
+ n = k + 100;
+ wh_next = mem(n,0);
+ wh_last = wh_first + n;
+ if (k)
+ memcpy(wh_next, wh_first, k);
+ wh_first = wh_next;
+ wh_next += k;
+ wh_last = wh_first + n;
+ }
+ p1put(P1_WHILE1START);
+ where = ftell(pass1_file);
+ if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype)))
+ {
+ if(k != TYERROR)
+ err("non-logical expression in DO WHILE statement");
+ }
+ else {
+ p = putx(p);
+ *wh_next++ = ftell(pass1_file) > where;
+ p1put(P1_WHILE2START);
+ p1_expr(p);
+ }
+ }
OpenPOWER on IntegriCloud