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.c1843
1 files changed, 0 insertions, 1843 deletions
diff --git a/usr.bin/f2c/putpcc.c b/usr.bin/f2c/putpcc.c
deleted file mode 100644
index d96e5e2..0000000
--- a/usr.bin/f2c/putpcc.c
+++ /dev/null
@@ -1,1843 +0,0 @@
-/****************************************************************
-Copyright 1990, 1991, 1992, 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.
-****************************************************************/
-
-/* 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"
-
-Addrp realpart();
-LOCAL Addrp intdouble(), putcx1(), putcxeq (), putch1 ();
-LOCAL putct1 ();
-
-expptr putcxop();
-LOCAL expptr putcall (), putmnmx (), putcheq(), putcat ();
-LOCAL expptr putaddr(), putchcmp (), putpower(), putop();
-LOCAL expptr putcxcmp ();
-expptr imagpart();
-ftnint lencat();
-
-#define FOUR 4
-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 */
-
-puthead(s, class)
-char *s;
-int class;
-{
- if (headerdone == NO) {
- if (class == CLMAIN)
- s = "MAIN__";
- p1_head (class, s);
- headerdone = YES;
- }
-}
-
-putif(p, else_if_p)
- register expptr p;
- int else_if_p;
-{
- 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);
- }
- }
- }
-
-
-putout(p)
-expptr p;
-{
- 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). */
-}
-
-
-
-putcmgo(index, nlab, labs)
-expptr index;
-int nlab;
-struct Labelblock *labs[];
-{
- if(! ISINT(index->headblock.vtype) )
- {
- execerr("computed goto index must be integer", CNULL);
- return;
- }
-
- p1comp_goto (index, nlab, labs);
-}
-
- static expptr
-krput(p)
- register expptr p;
-{
- 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 putx(p)
- register expptr p;
-{
- 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:
-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 putop(p)
-expptr p;
-{
- expptr lp, tp;
- int pt, lt, lt1;
- int comma;
-
- 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) {
- p->exprblock.leftp = putx(p->exprblock.leftp);
- return p;
- }
- 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);
- p -> exprblock.leftp = putx (p -> exprblock.leftp);
- if (p -> exprblock.rightp)
- p -> exprblock.rightp = putx (p -> exprblock.rightp);
- return p;
-}
-
-LOCAL expptr putpower(p)
-expptr p;
-{
- 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 intdouble(p)
-Addrp p;
-{
- register Addrp t;
-
- t = mktmp(TYDREAL, ENULL);
- putout (putassign(cpexpr((expptr)t), (expptr)p));
- return(t);
-}
-
-
-
-
-
-/* Complex-type variable assignment */
-
-LOCAL Addrp putcxeq(p)
-register expptr p;
-{
- 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 putcxop(p)
-expptr p;
-{
- return (expptr)putaddr((expptr)putcx1(p));
-}
-
-#define PAIR(x,y) mkexpr (OPCOMMA, (x), (y))
-
-LOCAL Addrp putcx1(p)
-register expptr p;
-{
- expptr q;
- Addrp lp, rp;
- register Addrp resp;
- int opcode;
- int ltype, rtype;
- long ts, tskludge;
- expptr mkrealcon();
-
- 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(TYDREAL, ENULL);
- putout (putassign( cpexpr((expptr)resp), p));
- return(resp);
-
- 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( 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 putcxcmp(p)
-register expptr p;
-{
- 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 putch1(p)
-register expptr p;
-{
- 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 putchop(p)
-expptr p;
-{
- p = putaddr((expptr)putch1(p));
- return (Addrp)p;
-}
-
-
-
-
-LOCAL expptr putcheq(p)
-register expptr p;
-{
- 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 putchcmp(p)
-register expptr p;
-{
- 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 putcat(lhs0, rhs)
- expptr lhs0;
- register expptr rhs;
-{
- 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 putct1(q, length_var, string_var, ip)
-register expptr q;
-register Addrp length_var, string_var;
-int *ip;
-{
- 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 putaddr(p0)
- expptr p0;
-{
- 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
-addrfix(e) /* fudge character string length if it's a TADDR */
- expptr e;
-{
- return e->tag == TADDR ? mkexpr(OPIDENTITY, e, ENULL) : e;
- }
-
- LOCAL int
-typekludge(ccall, q, at, j)
- int ccall;
- register expptr q;
- Atype *at;
- int 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 *
-Argtype(k, buf)
- int k;
- char *buf;
-{
- 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
-atype_squawk(at, msg)
- Argtypes *at;
- char *msg;
-{
- 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
-bad_atypes(at, fname, i, j, k, here, prev)
- Argtypes *at;
- char *fname, *here, *prev;
- int i, j, k;
-{
- 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
-type_fixup(at,a,k)
- Argtypes *at;
- Atype *a;
- int k;
-{
- register struct Entrypoint *ep;
- if (!infertypes)
- return 0;
- for(ep = entries; ep; ep = ep->entnextp)
- if (at == ep->entryname->arginfo) {
- a->type = k % 100;
- return proc_argchanges = 1;
- }
- return 0;
- }
-
-
- void
-save_argtypes(arglist, at0, at1, ccall, fname, stg, nchargs, type, zap)
- chainp arglist;
- Argtypes **at0, **at1;
- int ccall, stg, nchargs, type, zap;
- char *fname;
-{
- 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};
- extern int init_ac[TYSUBR+1];
-
- 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)
- goto newlist;
- return;
- }
- j = atypes->type;
- k = *t++;
- if (j != k)
- 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, j, k, "here ",
- ", previously");
- else
- fprintf(stderr,
- "\targ %d: here %s, previously %s.\n",
- i, Argtype(k,buf1),
- Argtype(j,buf2));
- 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;
- }
- }
-
- void
-saveargtypes(p) /* for writing prototypes */
- register Exprp p;
-{
- Addrp a;
- Argtypes **at0, **at1;
- Namep np;
- chainp arglist;
- 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");
- }
- rp = p->rightp;
- arglist = rp && rp->tag == TLIST ? rp->listblock.listp : 0;
- save_argtypes(arglist, at0, at1, p->opcode == OPCCALL,
- fname, a->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 putcall(p0, temp)
- expptr p0;
- Addrp *temp;
-{
- 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;
- extern struct Listblock *mklist();
-
- 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 */
-
- for(cp = arglist ; cp ; cp = cp->nextp)
- if(!byvalue) {
- 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))
- {
- 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;
- }
- }
- 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
- || 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 putmnmx(p)
-register expptr p;
-{
- 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
-putwhile(p)
- expptr p;
-{
- 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