BSD 4_4 release

[unix-history] / usr / src / usr.bin / f77 / pass1.vax / put.c

/*-
* Copyright (c) 1980 The Regents of the University of California.
* All rights reserved.
*
* This module is believed to contain source code proprietary to AT&T.
* Use and redistribution is subject to the Berkeley Software License
* Agreement and your Software Agreement with AT&T (Western Electric).
*/

#ifndef lint
static char sccsid[] = "@(#)put.c       5.3 (Berkeley) 4/12/91";
#endif /* not lint */

/*
* put.c
*
* Intermediate code generation procedures common to both
* Johnson (Portable) and Ritchie families of second passes
*
* University of Utah CS Dept modification history:
*
* $Log:        put.c,v $
* Revision 3.2  85/05/04  15:41:24  mckusick
* Fix alignment problem -- change code to match comment...
* 
* Revision 3.2  85/04/29  21:36:07  donn
* Fix alignment problem -- change code to match comment...
* 
* Revision 3.1  85/02/27  19:12:04  donn
* Changed to use pcc.h instead of pccdefs.h.
* 
* Revision 2.1  84/07/19  12:04:21  donn
* Changed comment headers for UofU.
* 
* Revision 1.2  84/04/02  14:40:21  donn
* Added fixes from Conrad Huang at UCSF for calculating the length of a
* concatenation of strings correctly.
* 
*/

#include "defs.h"

#if FAMILY == PCC
#       include <pcc.h>
#else
#       include "dmrdefs.h"
#endif

/*
char *ops [ ] =
       {
       "??", "+", "-", "*", "/", "**", "-",
       "OR", "AND", "EQV", "NEQV", "NOT",
       "CONCAT",
       "<", "==", ">", "<=", "!=", ">=",
       " of ", " ofC ", " = ", " += ", " *= ", " CONV ", " << ", " % ",
       " , ", " ? ", " : "
       " abs ", " min ", " max ", " addr ", " indirect ",
       " bitor ", " bitand ", " bitxor ", " bitnot ", " >> ", " () "
       };
*/

int ops2 [ ] =
       {
       PCC_ERROR, PCC_PLUS, PCC_MINUS, PCC_MUL, PCC_DIV, PCC_ERROR, PCC_UMINUS,
       PCC_OROR, PCC_ANDAND, PCC_EQ, PCC_NE, PCC_NOT,
       PCC_ERROR,
       PCC_LT, PCC_EQ, PCC_GT, PCC_LE, PCC_NE, PCC_GE,
       PCC_CALL, PCC_CALL, PCC_ASSIGN, PCC_PLUSEQ, PCC_MULEQ, PCC_SCONV, PCC_LS, PCC_MOD,
       PCC_COMOP, PCC_QUEST, PCC_COLON,
       PCC_ERROR, PCC_ERROR, PCC_ERROR, PCC_ERROR, PCC_DEREF,
       PCC_OR, PCC_AND, PCC_ER, PCC_COMPL, PCC_RS, PCC_ERROR
       };


int types2 [ ] =
       {
       PCC_ERROR, PCCT_INT|PCCTM_PTR, PCCT_SHORT, PCCT_LONG, PCCT_FLOAT, PCCT_DOUBLE,
#if TARGET == INTERDATA
       PCC_ERROR, PCC_ERROR, PCCT_LONG, PCCT_CHAR, PCCT_INT, PCC_ERROR
#else
       PCCT_FLOAT, PCCT_DOUBLE, PCCT_LONG, PCCT_CHAR, PCCT_INT, PCC_ERROR
#endif
       };


setlog()
{
types2[TYLOGICAL] = types2[tylogical];
typesize[TYLOGICAL] = typesize[tylogical];
typealign[TYLOGICAL] = typealign[tylogical];
}


putex1(p)
expptr p;
{
putx( fixtype(p) );

if (!optimflag)
       {
       templist = hookup(templist, holdtemps);
       holdtemps = NULL;
       }
}





putassign(lp, rp)
expptr lp, rp;
{
putx( fixexpr( mkexpr(OPASSIGN, lp, rp) ));
}




puteq(lp, rp)
expptr lp, rp;
{
putexpr( mkexpr(OPASSIGN, lp, rp) );
}




/* put code for  a *= b */

putsteq(a, b)
expptr a, b;
{
putx( fixexpr( mkexpr(OPSTAREQ, cpexpr(a), cpexpr(b)) ));
}





Addrp realpart(p)
register Addrp p;
{
register Addrp q;

q = (Addrp) cpexpr(p);
if( ISCOMPLEX(p->vtype) )
       q->vtype += (TYREAL-TYCOMPLEX);
return(q);
}




expptr imagpart(p)
register expptr p;
{
register Addrp q;
expptr mkrealcon();

if (ISCONST(p))
       {
       if (ISCOMPLEX(p->constblock.vtype))
               return(mkrealcon(p->constblock.vtype == TYCOMPLEX ?
                                       TYREAL : TYDREAL,
                               p->constblock.constant.cd[1]));
       else if (p->constblock.vtype == TYDREAL)
               return(mkrealcon(TYDREAL, 0.0));
       else
               return(mkrealcon(TYREAL, 0.0));
       }
else if (p->tag == TADDR)
       {
       if( ISCOMPLEX(p->addrblock.vtype) )
               {
               q = (Addrp) cpexpr(p);
               q->vtype += (TYREAL-TYCOMPLEX);
               q->memoffset = mkexpr(OPPLUS, q->memoffset,
                                       ICON(typesize[q->vtype]));
               return( (expptr) q );
               }
       else
               return( mkrealcon( ISINT(p->addrblock.vtype) ?
                       TYDREAL : p->addrblock.vtype , 0.0));
       }
else
       badtag("imagpart", p->tag);
}




ncat(p)
register expptr p;
{
if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT)
       return( ncat(p->exprblock.leftp) + ncat(p->exprblock.rightp) );
else    return(1);
}




ftnint lencat(p)
register expptr p;
{
if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT)
       return( lencat(p->exprblock.leftp) + lencat(p->exprblock.rightp) );
else if( p->headblock.vleng!=NULL && ISICON(p->headblock.vleng) )
       return(p->headblock.vleng->constblock.constant.ci);
else if(p->tag==TADDR && p->addrblock.varleng!=0)
       return(p->addrblock.varleng);
else if(p->tag==TTEMP && p->tempblock.varleng!=0)
       return(p->tempblock.varleng);
else
       {
       err("impossible element in concatenation");
       return(0);
       }
}
\f
Addrp putconst(p)
register Constp p;
{
register Addrp q;
struct Literal *litp, *lastlit;
int i, k, type;
int litflavor;

if( p->tag != TCONST )
       badtag("putconst", p->tag);

q = ALLOC(Addrblock);
q->tag = TADDR;
type = p->vtype;
q->vtype = ( type==TYADDR ? TYINT : type );
q->vleng = (expptr) cpexpr(p->vleng);
q->vstg = STGCONST;
q->memno = newlabel();
q->memoffset = ICON(0);

/* check for value in literal pool, and update pool if necessary */

switch(type = p->vtype)
       {
       case TYCHAR:
               if(p->vleng->constblock.constant.ci > XL)
                       break;  /* too long for literal table */
               litflavor = 1;
               goto loop;

       case TYREAL:
       case TYDREAL:
               litflavor = 2;
               goto loop;

       case TYLOGICAL:
               type = tylogical;
       case TYSHORT:
       case TYLONG:
               litflavor = 3;

       loop:
               lastlit = litpool + nliterals;
               for(litp = litpool ; litp<lastlit ; ++litp)
                       if(type == litp->littype) switch(litflavor)
                               {
                       case 1:
                               if(p->vleng->constblock.constant.ci != litp->litval.litcval.litclen)
                                       break;
                               if(! eqn( (int) p->vleng->constblock.constant.ci, p->constant.ccp,
                                       litp->litval.litcval.litcstr) )
                                               break;

                       ret:
                               q->memno = litp->litnum;
                               frexpr(p);
                               return(q);

                       case 2:
                               if(p->constant.cd[0] == litp->litval.litdval)
                                       goto ret;
                               break;

                       case 3:
                               if(p->constant.ci == litp->litval.litival)
                                       goto ret;
                               break;
                               }
               if(nliterals < MAXLITERALS)
                       {
                       ++nliterals;
                       litp->littype = type;
                       litp->litnum = q->memno;
                       switch(litflavor)
                               {
                               case 1:
                                       litp->litval.litcval.litclen =
                                               p->vleng->constblock.constant.ci;
                                       cpn( (int) litp->litval.litcval.litclen,
                                               p->constant.ccp,
                                               litp->litval.litcval.litcstr);
                                       break;

                               case 2:
                                       litp->litval.litdval = p->constant.cd[0];
                                       break;

                               case 3:
                                       litp->litval.litival = p->constant.ci;
                                       break;
                               }
                       }
       default:
               break;
       }

preven(typealign[ type==TYCHAR ? TYLONG : type ]);
prlabel(asmfile, q->memno);

k = 1;
switch(type)
       {
       case TYLOGICAL:
       case TYSHORT:
       case TYLONG:
               prconi(asmfile, type, p->constant.ci);
               break;

       case TYCOMPLEX:
               k = 2;
       case TYREAL:
               type = TYREAL;
               goto flpt;

       case TYDCOMPLEX:
               k = 2;
       case TYDREAL:
               type = TYDREAL;

       flpt:
               for(i = 0 ; i < k ; ++i)
                       prconr(asmfile, type, p->constant.cd[i]);
               break;

       case TYCHAR:
               putstr(asmfile, p->constant.ccp,
                       (int) (p->vleng->constblock.constant.ci) );
               break;

       case TYADDR:
               prcona(asmfile, p->constant.ci);
               break;

       default:
               badtype("putconst", p->vtype);
       }

frexpr(p);
return( q );
}
\f
/*
* put out a character string constant.  begin every one on
* a long integer boundary, and pad with nulls
*/
putstr(fp, s, n)
FILEP fp;
register char *s;
register int n;
{
int b[SZLONG];
register int i;

i = 0;
while(--n >= 0)
       {
       b[i++] = *s++;
       if(i == SZLONG)
               {
               prchars(fp, b);
               prchars(fp, b+SZSHORT);
               i = 0;
               }
       }

while(i < SZLONG)
       b[i++] = '\0';
prchars(fp, b);
prchars(fp, b+SZSHORT);
}