sources/f2c/put.c

   1 /****************************************************************
   2 Copyright 1990 by AT&T Bell Laboratories and Bellcore.
   3
   4 Permission to use, copy, modify, and distribute this software
   5 and its documentation for any purpose and without fee is hereby
   6 granted, provided that the above copyright notice appear in all
   7 copies and that both that the copyright notice and this
   8 permission notice and warranty disclaimer appear in supporting
   9 documentation, and that the names of AT&T Bell Laboratories or
  10 Bellcore or any of their entities not be used in advertising or
  11 publicity pertaining to distribution of the software without
  12 specific, written prior permission.
  13
  14 AT&T and Bellcore disclaim all warranties with regard to this
  15 software, including all implied warranties of merchantability
  16 and fitness.  In no event shall AT&T or Bellcore be liable for
  17 any special, indirect or consequential damages or any damages
  18 whatsoever resulting from loss of use, data or profits, whether
  19 in an action of contract, negligence or other tortious action,
  20 arising out of or in connection with the use or performance of
  21 this software.
  22 ****************************************************************/
  23
  24 /*
  25  * INTERMEDIATE CODE GENERATION PROCEDURES COMMON TO BOTH
  26  * JOHNSON (PORTABLE) AND RITCHIE FAMILIES OF SECOND PASSES
  27 */
  28
  29 #include "defs.h"
  30 #include "names.h"              /* For LOCAL_CONST_NAME */
  31 #include "pccdefs.h"
  32 #include "p1defs.h"
  33
  34 /* Definitions for   putconst()   */
  35
  36 #define LIT_CHAR 1
  37 #define LIT_FLOAT 2
  38 #define LIT_INT 3
  39
  40
  41 /*
  42 char *ops [ ] =
  43         {
  44         "??", "+", "-", "*", "/", "**", "-",
  45         "OR", "AND", "EQV", "NEQV", "NOT",
  46         "CONCAT",
  47         "<", "==", ">", "<=", "!=", ">=",
  48         " of ", " ofC ", " = ", " += ", " *= ", " CONV ", " << ", " % ",
  49         " , ", " ? ", " : "
  50         " abs ", " min ", " max ", " addr ", " indirect ",
  51         " bitor ", " bitand ", " bitxor ", " bitnot ", " >> ",
  52         };
  53 */
  54
  55 /* Each of these values is defined in   pccdefs   */
  56
  57 int ops2 [ ] =
  58 {
  59         P2BAD, P2PLUS, P2MINUS, P2STAR, P2SLASH, P2BAD, P2NEG,
  60         P2OROR, P2ANDAND, P2EQ, P2NE, P2NOT,
  61         P2BAD,
  62         P2LT, P2EQ, P2GT, P2LE, P2NE, P2GE,
  63         P2CALL, P2CALL, P2ASSIGN, P2PLUSEQ, P2STAREQ, P2CONV, P2LSHIFT, P2MOD,
  64         P2COMOP, P2QUEST, P2COLON,
  65         1, P2BAD, P2BAD, P2BAD, P2BAD,
  66         P2BITOR, P2BITAND, P2BITXOR, P2BITNOT, P2RSHIFT,
  67         P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD,
  68         P2BAD, P2BAD, P2BAD, P2BAD,
  69         1,1,1,1,1, /* OPNEG1, OPDMIN, OPDMAX, OPASSIGNI, OPIDENTITY */
  70         1,1,1,1 /* OPCHARCAST, OPDABS, OPMIN2, OPMAX2 */
  71 };
  72
  73
  74 int types2 [ ] =
  75 {
  76         P2BAD, P2INT|P2PTR, P2SHORT, P2LONG, P2REAL, P2DREAL,
  77         P2REAL, P2DREAL, P2LONG, P2CHAR, P2INT, P2BAD
  78 };
  79
  80
  81 setlog()
  82 {
  83         types2[TYLOGICAL] = types2[tylogical];
  84         typesize[TYLOGICAL] = typesize[tylogical];
  85         typealign[TYLOGICAL] = typealign[tylogical];
  86 }
  87
  88
  89 void putex1(p)
  90 expptr p;
  91 {
  92 /* Write the expression to the p1 file */
  93
  94         p = (expptr) putx (fixtype (p));
  95         p1_expr (p);
  96 }
  97
  98
  99
 100
 101
 102 expptr putassign(lp, rp)
 103 expptr lp, rp;
 104 {
 105         return putx(fixexpr((Exprp)mkexpr(OPASSIGN, lp, rp)));
 106 }
 107
 108
 109
 110
 111 void puteq(lp, rp)
 112 expptr lp, rp;
 113 {
 114         putexpr(mkexpr(OPASSIGN, lp, rp) );
 115 }
 116
 117
 118
 119
 120 /* put code for  a *= b */
 121
 122 expptr putsteq(a, b)
 123 Addrp a, b;
 124 {
 125         return putx( fixexpr((Exprp)
 126                 mkexpr(OPSTAREQ, cpexpr((expptr)a), cpexpr((expptr)b))));
 127 }
 128
 129
 130
 131
 132 Addrp mkfield(res, f, ty)
 133 register Addrp res;
 134 char *f;
 135 int ty;
 136 {
 137     res -> vtype = ty;
 138     res -> Field = f;
 139     return res;
 140 } /* mkfield */
 141
 142
 143 Addrp realpart(p)
 144 register Addrp p;
 145 {
 146         register Addrp q;
 147         expptr mkrealcon();
 148
 149         if (p -> uname_tag == UNAM_CONST && ISCOMPLEX (p->vtype)) {
 150                 return (Addrp)mkrealcon (p -> vtype + TYREAL - TYCOMPLEX,
 151                         p->user.kludge.vstg1 ? p->user.Const.cds[0]
 152                                 : cds(dtos(p->user.Const.cd[0]),CNULL));
 153         } /* if p -> uname_tag */
 154
 155         q = (Addrp) cpexpr((expptr) p);
 156         if( ISCOMPLEX(p->vtype) )
 157                 q = mkfield (q, "r", p -> vtype + TYREAL - TYCOMPLEX);
 158
 159         return(q);
 160 }
 161
 162
 163
 164
 165 expptr imagpart(p)
 166 register Addrp p;
 167 {
 168         register Addrp q;
 169         expptr mkrealcon();
 170
 171         if( ISCOMPLEX(p->vtype) )
 172         {
 173                 if (p -> uname_tag == UNAM_CONST)
 174                         return mkrealcon (p -> vtype + TYREAL - TYCOMPLEX,
 175                                 p->user.kludge.vstg1 ? p->user.Const.cds[1]
 176                                 : cds(dtos(p->user.Const.cd[1]),CNULL));
 177                 q = (Addrp) cpexpr((expptr) p);
 178                 q = mkfield (q, "i", p -> vtype + TYREAL - TYCOMPLEX);
 179                 return( (expptr) q );
 180         }
 181         else
 182
 183 /* Cast an integer type onto a Double Real type */
 184
 185                 return( mkrealcon( ISINT(p->vtype) ? TYDREAL : p->vtype , "0"));
 186 }
 187
 188
 189
 190
 191
 192 /* ncat -- computes the number of adjacent concatenation operations */
 193
 194 ncat(p)
 195 register expptr p;
 196 {
 197         if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT)
 198                 return( ncat(p->exprblock.leftp) + ncat(p->exprblock.rightp) );
 199         else    return(1);
 200 }
 201
 202
 203
 204
 205 /* lencat -- returns the length of the concatenated string.  Each
 206    substring must have a static (i.e. compile-time) fixed length */
 207
 208 ftnint lencat(p)
 209 register expptr p;
 210 {
 211         if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT)
 212                 return( lencat(p->exprblock.leftp) + lencat(p->exprblock.rightp) );
 213         else if( p->headblock.vleng!=NULL && ISICON(p->headblock.vleng) )
 214                 return(p->headblock.vleng->constblock.Const.ci);
 215         else if(p->tag==TADDR && p->addrblock.varleng!=0)
 216                 return(p->addrblock.varleng);
 217         else
 218         {
 219                 err("impossible element in concatenation");
 220                 return(0);
 221         }
 222 }
 223
 224 /* putconst -- Creates a new Addrp value which maps onto the input
 225    constant value.  The Addrp doesn't retain the value of the constant,
 226    instead that value is copied into a table of constants (called
 227    litpool,   for pool of literal values).  The only way to retrieve the
 228    actual value of the constant is to look at the   memno   field of the
 229    Addrp result.  You know that the associated literal is the one referred
 230    to by   q   when   (q -> memno == litp -> litnum).
 231 */
 232
 233 Addrp putconst(p)
 234 register Constp p;
 235 {
 236         register Addrp q;
 237         struct Literal *litp, *lastlit;
 238         int k, type;
 239         int litflavor;
 240         double cd[2];
 241         char cdsbuf0[64], cdsbuf1[64], *ds[2];
 242
 243         if( p->tag != TCONST )
 244                 badtag("putconst", p->tag);
 245
 246         q = ALLOC(Addrblock);
 247         q->tag = TADDR;
 248         type = p->vtype;
 249         q->vtype = ( type==TYADDR ? tyint : type );
 250         q->vleng = (expptr) cpexpr(p->vleng);
 251         q->vstg = STGCONST;
 252
 253 /* Create the new label for the constant.  This is wasteful of labels
 254    because when the constant value already exists in the literal pool,
 255    this label gets thrown away and is never reclaimed.  It might be
 256    cleaner to move this down past the first   switch()   statement below */
 257
 258         q->memno = newlabel();
 259         q->memoffset = ICON(0);
 260         q -> uname_tag = UNAM_CONST;
 261
 262 /* Copy the constant info into the Addrblock; do this by copying the
 263    largest storage elts */
 264
 265         q -> user.Const = p -> Const;
 266         q->user.kludge.vstg1 = p->vstg; /* distinguish string from binary fp */
 267
 268         /* check for value in literal pool, and update pool if necessary */
 269
 270         k = 1;
 271         switch(type = p->vtype)
 272         {
 273         case TYCHAR:
 274                 /* Treat all character strings as too long for literal table */
 275                 q -> memno = BAD_MEMNO;
 276                 break;
 277         case TYCOMPLEX:
 278         case TYDCOMPLEX:
 279                 k = 2;
 280                 if (p->vstg)
 281                         cd[1] = atof(ds[1] = p->Const.cds[1]);
 282                 else
 283                         ds[1] = cds(dtos(cd[1] = p->Const.cd[1]), cdsbuf1);
 284         case TYREAL:
 285         case TYDREAL:
 286                 litflavor = LIT_FLOAT;
 287                 if (p->vstg)
 288                         cd[0] = atof(ds[0] = p->Const.cds[0]);
 289                 else
 290                         ds[0] = cds(dtos(cd[0] = p->Const.cd[0]), cdsbuf0);
 291                 goto loop;
 292
 293         case TYLOGICAL:
 294                 type = tylogical;
 295                 goto lit_int_flavor;
 296         case TYLONG:
 297                 type = tyint;
 298         case TYSHORT:
 299  lit_int_flavor:
 300                 litflavor = LIT_INT;
 301
 302 /* Scan the literal pool for this constant value.  If this same constant
 303    has been assigned before, use the same label.  Note that this routine
 304    does NOT consider two differently-typed constants with the same bit
 305    pattern to be the same constant */
 306
 307 loop:
 308                 lastlit = litpool + nliterals;
 309                 for(litp = litpool ; litp<lastlit ; ++litp)
 310
 311 /* Remove this type checking to ensure that all bit patterns are reused */
 312
 313                         if(type == litp->littype) switch(litflavor)
 314                         {
 315                         case LIT_FLOAT:
 316                                 if(cd[0] == litp->litval.litdval[0]
 317                                 && !strcmp(ds[0], litp->cds[0])
 318                                 && (k == 1 ||
 319                                     cd[1] == litp->litval.litdval[1]
 320                                     && !strcmp(ds[1], litp->cds[1]))) {
 321 ret:
 322                                         q->memno = litp->litnum;
 323                                         frexpr((expptr)p);
 324                                         return(q);
 325                                         }
 326                                 break;
 327
 328                         case LIT_INT:
 329                                 if(p->Const.ci == litp->litval.litival)
 330                                         goto ret;
 331                                 break;
 332                         }
 333
 334 /* If there's room in the literal pool, add this new value to the pool */
 335
 336                 if(nliterals < MAXLITERALS)
 337                 {
 338                         ++nliterals;
 339
 340                         /* litp   now points to the next free elt */
 341
 342                         litp->littype = type;
 343                         litp->litnum = q->memno;
 344                         switch(litflavor)
 345                         {
 346                         case LIT_FLOAT:
 347                                 litp->litval.litdval[0] = cd[0];
 348                                 litp->cds[0] = copys(ds[0]);
 349                                 if (k == 2) {
 350                                         litp->litval.litdval[1] = cd[1];
 351                                         litp->cds[1] = copys(ds[1]);
 352                                         }
 353                                 break;
 354
 355                         case LIT_INT:
 356                                 litp->litval.litival = p->Const.ci;
 357                                 break;
 358                         } /* switch (litflavor) */
 359                 } /* if (nliternals < MAXLITERALS) */
 360                   else {
 361                     Addrp t = Mktemp(type, q -> vleng);
 362                     puteq (cpexpr((expptr)t), (expptr)p);
 363                     free ((char *) q);
 364                     return t;
 365                 } /* else */
 366
 367                 break;
 368         case TYADDR:
 369             break;
 370         default:
 371                 badtype ("putconst", p -> vtype);
 372                 break;
 373         } /* switch */
 374
 375         if (type != TYCHAR)
 376             frexpr((expptr)p);
 377         return( q );
 378 }