lang/fortran/comp/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, len, type;
 239         int litflavor;
 240         double cd[2];
 241         ftnint nblanks;
 242         char *strp;
 243         char cdsbuf0[64], cdsbuf1[64], *ds[2];
 244
 245         if (p->tag != TCONST)
 246                 badtag("putconst", p->tag);
 247
 248         q = ALLOC(Addrblock);
 249         q->tag = TADDR;
 250         type = p->vtype;
 251         q->vtype = ( type==TYADDR ? tyint : type );
 252         q->vleng = (expptr) cpexpr(p->vleng);
 253         q->vstg = STGCONST;
 254
 255 /* Create the new label for the constant.  This is wasteful of labels
 256    because when the constant value already exists in the literal pool,
 257    this label gets thrown away and is never reclaimed.  It might be
 258    cleaner to move this down past the first   switch()   statement below */
 259
 260         q->memno = newlabel();
 261         q->memoffset = ICON(0);
 262         q -> uname_tag = UNAM_CONST;
 263
 264 /* Copy the constant info into the Addrblock; do this by copying the
 265    largest storage elts */
 266
 267         q -> user.Const = p -> Const;
 268         q->user.kludge.vstg1 = p->vstg; /* distinguish string from binary fp */
 269
 270         /* check for value in literal pool, and update pool if necessary */
 271
 272         k = 1;
 273         switch(type)
 274         {
 275         case TYCHAR:
 276                 if (halign) {
 277                         strp = p->Const.ccp;
 278                         nblanks = p->Const.ccp1.blanks;
 279                         len = p->vleng->constblock.Const.ci;
 280                         litflavor = LIT_CHAR;
 281                         goto loop;
 282                         }
 283                 else
 284                         q->memno = BAD_MEMNO;
 285                 break;
 286         case TYCOMPLEX:
 287         case TYDCOMPLEX:
 288                 k = 2;
 289                 if (p->vstg)
 290                         cd[1] = atof(ds[1] = p->Const.cds[1]);
 291                 else
 292                         ds[1] = cds(dtos(cd[1] = p->Const.cd[1]), cdsbuf1);
 293         case TYREAL:
 294         case TYDREAL:
 295                 litflavor = LIT_FLOAT;
 296                 if (p->vstg)
 297                         cd[0] = atof(ds[0] = p->Const.cds[0]);
 298                 else
 299                         ds[0] = cds(dtos(cd[0] = p->Const.cd[0]), cdsbuf0);
 300                 goto loop;
 301
 302         case TYLOGICAL:
 303                 type = tylogical;
 304                 goto lit_int_flavor;
 305         case TYLONG:
 306                 type = tyint;
 307         case TYSHORT:
 308  lit_int_flavor:
 309                 litflavor = LIT_INT;
 310
 311 /* Scan the literal pool for this constant value.  If this same constant
 312    has been assigned before, use the same label.  Note that this routine
 313    does NOT consider two differently-typed constants with the same bit
 314    pattern to be the same constant */
 315
 316  loop:
 317                 lastlit = litpool + nliterals;
 318                 for(litp = litpool ; litp<lastlit ; ++litp)
 319
 320 /* Remove this type checking to ensure that all bit patterns are reused */
 321
 322                         if(type == litp->littype) switch(litflavor)
 323                         {
 324                         case LIT_CHAR:
 325                                 if (len == (int)litp->litval.litival2[0]
 326                                 && nblanks == litp->litval.litival2[1]
 327                                 && !memcmp(strp, litp->cds[0], len)) {
 328                                         q->memno = litp->litnum;
 329                                         frexpr((expptr)p);
 330                                         return(q);
 331                                         }
 332                                 break;
 333                         case LIT_FLOAT:
 334                                 if(cd[0] == litp->litval.litdval[0]
 335                                 && !strcmp(ds[0], litp->cds[0])
 336                                 && (k == 1 ||
 337                                     cd[1] == litp->litval.litdval[1]
 338                                     && !strcmp(ds[1], litp->cds[1]))) {
 339 ret:
 340                                         q->memno = litp->litnum;
 341                                         frexpr((expptr)p);
 342                                         return(q);
 343                                         }
 344                                 break;
 345
 346                         case LIT_INT:
 347                                 if(p->Const.ci == litp->litval.litival)
 348                                         goto ret;
 349                                 break;
 350                         }
 351
 352 /* If there's room in the literal pool, add this new value to the pool */
 353
 354                 if(nliterals < maxliterals)
 355                 {
 356                         ++nliterals;
 357
 358                         /* litp   now points to the next free elt */
 359
 360                         litp->littype = type;
 361                         litp->litnum = q->memno;
 362                         switch(litflavor)
 363                         {
 364                         case LIT_CHAR:
 365                                 litp->litval.litival2[0] = len;
 366                                 litp->litval.litival2[1] = nblanks;
 367                                 q->user.Const.ccp = litp->cds[0] =
 368                                         memcpy(gmem(len,0), strp, len);
 369                                 break;
 370
 371                         case LIT_FLOAT:
 372                                 litp->litval.litdval[0] = cd[0];
 373                                 litp->cds[0] = copys(ds[0]);
 374                                 if (k == 2) {
 375                                         litp->litval.litdval[1] = cd[1];
 376                                         litp->cds[1] = copys(ds[1]);
 377                                         }
 378                                 break;
 379
 380                         case LIT_INT:
 381                                 litp->litval.litival = p->Const.ci;
 382                                 break;
 383                         } /* switch (litflavor) */
 384                 }
 385                 else
 386                         many("literal constants", 'L', maxliterals);
 387
 388                 break;
 389         case TYADDR:
 390             break;
 391         default:
 392                 badtype ("putconst", p -> vtype);
 393                 break;
 394         } /* switch */
 395
 396         if (type != TYCHAR || halign)
 397             frexpr((expptr)p);
 398         return( q );
 399 }