lang/m2/comp/cstoper.c

   1 /*
   2  * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
   3  * See the copyright notice in the ACK home directory, in the file "Copyright".
   4  *
   5  * Author: Ceriel J.H. Jacobs
   6  */
   7
   8 /* C O N S T A N T   E X P R E S S I O N   H A N D L I N G */
   9
  10 /* $Id: cstoper.c,v 1.57 1996/08/14 07:42:31 ceriel Exp $ */
  11
  12 #include        "debug.h"
  13 #include        "target_sizes.h"
  14 #include        "uns_arith.h"
  15
  16 #include        <em_arith.h>
  17 #include        <em_label.h>
  18 #include        <assert.h>
  19 #include        <alloc.h>
  20
  21 #include        "idf.h"
  22 #include        "type.h"
  23 #include        "LLlex.h"
  24 #include        "node.h"
  25 #include        "Lpars.h"
  26 #include        "standards.h"
  27 #include        "warning.h"
  28
  29 extern char     *symbol2str();
  30
  31 #define arith_sign      ((arith) (1L << (sizeof(arith) * 8 - 1)))
  32
  33 #ifndef NOCROSS
  34 arith full_mask[MAXSIZE+1];/* full_mask[1] == 0xFF, full_mask[2] == 0xFFFF, .. */
  35 arith max_int[MAXSIZE+1]; /* max_int[1] == 0x7F, max_int[2] == 0x7FFF, .. */
  36 arith min_int[MAXSIZE+1]; /* min_int[1] == 0xFFFFFF80, min_int[2] = 0xFFFF8000,
  37                              ...
  38                           */
  39 unsigned int wrd_bits;  /* number of bits in a word */
  40 #else
  41 arith full_mask[] = { 0L, 0xFFL, 0xFFFFL, 0L, 0xFFFFFFFFL };
  42 arith max_int[] =   { 0L, 0x7FL, 0x7FFFL, 0L, 0x7FFFFFFFL };
  43 arith min_int[] =   { 0L, -128L, -32768L, 0L, -2147483647L-1 };
  44 #endif
  45
  46 extern char options[];
  47
  48 overflow(expp)
  49         t_node *expp;
  50 {
  51         if (expp->nd_type != address_type) {
  52             node_warning(expp, W_ORDINARY, "overflow in constant expression");
  53         }
  54 }
  55
  56 STATIC
  57 commonbin(expp)
  58         t_node **expp;
  59 {
  60         register t_node *exp = *expp;
  61         t_type *tp = exp->nd_type;
  62         register t_node *right = exp->nd_RIGHT;
  63
  64         exp->nd_RIGHT = 0;
  65         FreeNode(exp);
  66         *expp = right;
  67         right->nd_type = tp;
  68 }
  69
  70 cstunary(expp)
  71         t_node **expp;
  72 {
  73         /*      The unary operation in "expp" is performed on the constant
  74                 expression below it, and the result restored in expp.
  75         */
  76         register t_node *exp = *expp;
  77         register t_node *right = exp->nd_RIGHT;
  78         register arith o1 = right->nd_INT;
  79
  80         switch(exp->nd_symb) {
  81         /* Should not get here
  82         case '+':
  83                 break;
  84         */
  85
  86         case '-':
  87                 if (! options['s'] &&
  88                     o1 == min_int[(int)(right->nd_type->tp_size)]) {
  89                         overflow(exp);
  90                 }
  91                 o1 = -o1;
  92                 break;
  93
  94         case NOT:
  95         case '~':
  96                 o1 = !o1;
  97                 break;
  98
  99         default:
 100                 crash("(cstunary)");
 101         }
 102
 103         commonbin(expp);
 104         (*expp)->nd_INT = o1;
 105         CutSize(*expp);
 106 }
 107
 108 STATIC
 109 divide(pdiv, prem)
 110         arith *pdiv, *prem;
 111 {
 112         /*      Unsigned divide *pdiv by *prem, and store result in *pdiv,
 113                 remainder in *prem
 114         */
 115         register arith o1 = *pdiv;
 116         register arith o2 = *prem;
 117
 118 #ifndef UNSIGNED_ARITH
 119         /*      this is more of a problem than you might
 120                 think on C compilers which do not have
 121                 unsigned long.
 122         */
 123         if (o2 & arith_sign)    {/* o2 > max_arith */
 124                 if (! (o1 >= 0 || o1 < o2)) {
 125                         /*      this is the unsigned test
 126                                 o1 < o2 for o2 > max_arith
 127                         */
 128                         *prem = o2 - o1;
 129                         *pdiv = 1;
 130                 }
 131                 else {
 132                         *pdiv = 0;
 133                 }
 134         }
 135         else    {               /* o2 <= max_arith */
 136                 arith half, bit, hdiv, hrem, rem;
 137
 138                 half = (o1 >> 1) & ~arith_sign;
 139                 bit = o1 & 01;
 140                 /*      now o1 == 2 * half + bit
 141                         and half <= max_arith
 142                         and bit <= max_arith
 143                 */
 144                 hdiv = half / o2;
 145                 hrem = half % o2;
 146                 rem = 2 * hrem + bit;
 147                 *pdiv = 2*hdiv;
 148                 *prem = rem;
 149                 if (rem < 0 || rem >= o2) {
 150                         /*      that is the unsigned compare
 151                                 rem >= o2 for o2 <= max_arith
 152                         */
 153                         *pdiv += 1;
 154                         *prem -= o2;
 155                 }
 156         }
 157 #else
 158         *pdiv = (UNSIGNED_ARITH) o1 / (UNSIGNED_ARITH) o2;
 159         *prem = (UNSIGNED_ARITH) o1 % (UNSIGNED_ARITH) o2;
 160 #endif
 161 }
 162
 163 cstibin(expp)
 164         t_node **expp;
 165 {
 166         /*      The binary operation in "expp" is performed on the constant
 167                 expressions below it, and the result restored in expp.
 168                 This version is for INTEGER expressions.
 169         */
 170         register t_node *exp = *expp;
 171         register arith o1 = exp->nd_LEFT->nd_INT;
 172         register arith o2 = exp->nd_RIGHT->nd_INT;
 173         register int sz = exp->nd_type->tp_size;
 174
 175         assert(exp->nd_class == Oper);
 176         assert(exp->nd_LEFT->nd_class == Value);
 177         assert(exp->nd_RIGHT->nd_class == Value);
 178
 179         switch (exp->nd_symb)   {
 180         case '*':
 181                 if (o1 > 0) {
 182                         if (o2 > 0) {
 183                                 if (max_int[sz] / o1 < o2) overflow(exp);
 184                         }
 185                         else if (min_int[sz] / o1 > o2) overflow(exp);
 186                 }
 187                 else if (o1 < 0) {
 188                         if (o2 < 0) {
 189                                 if (o1 == min_int[sz] || o2 == min_int[sz] ||
 190                                    max_int[sz] / (-o1) < (-o2)) overflow(exp);
 191                         }
 192                         else if (o2 > 0) {
 193                                 if (min_int[sz] / o2 > o1) overflow(exp);
 194                         }
 195                 }
 196                 o1 *= o2;
 197                 break;
 198
 199         case DIV:
 200         case MOD:
 201                 if (o2 == 0)    {
 202                         node_error(exp, exp->nd_symb == DIV ?
 203                                         "division by 0" :
 204                                         "modulo by 0");
 205                         return;
 206                 }
 207                 if ((o1 < 0) != (o2 < 0)) {
 208                         if (o1 < 0) o1 = -o1;
 209                         else o2 = -o2;
 210                         if (exp->nd_symb == DIV) o1 = -((o1+o2-1)/o2);
 211                         else o1 = ((o1+o2-1)/o2) * o2 - o1;
 212                 }
 213                 else {
 214                         if (exp->nd_symb == DIV) o1 /= o2;
 215                         else o1 %= o2;
 216                 }
 217                 break;
 218
 219         case '+':
 220                 if (  (o1 > 0 && o2 > 0 && max_int[sz] - o1 < o2)
 221                    || (o1 < 0 && o2 < 0 && min_int[sz] - o1 > o2)
 222                    ) overflow(exp);
 223                 o1 += o2;
 224                 break;
 225
 226         case '-':
 227                 if (  (o1 >= 0 && o2 < 0 && max_int[sz] + o2 < o1)
 228                    || (o1 < 0 && o2 >= 0 && min_int[sz] + o2 > o1)
 229                    ) overflow(exp);
 230                 o1 -= o2;
 231                 break;
 232
 233         case '<':
 234                 o1 = (o1 < o2);
 235                 break;
 236
 237         case '>':
 238                 o1 = (o1 > o2);
 239                 break;
 240
 241         case LESSEQUAL:
 242                 o1 = (o1 <= o2);
 243                 break;
 244
 245         case GREATEREQUAL:
 246                 o1 = (o1 >= o2);
 247                 break;
 248
 249         case '=':
 250                 o1 = (o1 == o2);
 251                 break;
 252
 253         case '#':
 254                 o1 = (o1 != o2);
 255                 break;
 256
 257         default:
 258                 crash("(cstibin)");
 259         }
 260
 261         commonbin(expp);
 262         (*expp)->nd_INT = o1;
 263         CutSize(*expp);
 264 }
 265
 266 cstfbin(expp)
 267         t_node **expp;
 268 {
 269         /*      The binary operation in "expp" is performed on the constant
 270                 expressions below it, and the result restored in expp.
 271                 This version is for REAL expressions.
 272         */
 273         register t_node *exp = *expp;
 274         register struct real *p = exp->nd_LEFT->nd_REAL;
 275         register flt_arith *o1 = &p->r_val;
 276         register flt_arith *o2 = &exp->nd_RIGHT->nd_RVAL;
 277         int compar = 0;
 278         int cmpval = 0;
 279
 280         assert(exp->nd_class == Oper);
 281         assert(exp->nd_LEFT->nd_class == Value);
 282         assert(exp->nd_RIGHT->nd_class == Value);
 283
 284         switch (exp->nd_symb)   {
 285         case '*':
 286                 flt_mul(o1, o2, o1);
 287                 break;
 288
 289         case '/':
 290                 flt_div(o1, o2, o1);
 291                 break;
 292
 293         case '+':
 294                 flt_add(o1, o2, o1);
 295                 break;
 296
 297         case '-':
 298                 flt_sub(o1, o2, o1);
 299                 break;
 300
 301         case '<':
 302         case '>':
 303         case LESSEQUAL:
 304         case GREATEREQUAL:
 305         case '=':
 306         case '#':
 307                 compar++;
 308                 cmpval = flt_cmp(o1, o2);
 309                 switch(exp->nd_symb) {
 310                 case '<':               cmpval = (cmpval < 0); break;
 311                 case '>':               cmpval = (cmpval > 0); break;
 312                 case LESSEQUAL:         cmpval = (cmpval <= 0); break;
 313                 case GREATEREQUAL:      cmpval = (cmpval >= 0); break;
 314                 case '=':               cmpval = (cmpval == 0); break;
 315                 case '#':               cmpval = (cmpval != 0); break;
 316                 }
 317                 if (exp->nd_RIGHT->nd_RSTR) free(exp->nd_RIGHT->nd_RSTR);
 318                 free_real(exp->nd_RIGHT->nd_REAL);
 319                 break;
 320
 321         default:
 322                 crash("(cstfbin)");
 323         }
 324
 325         switch(flt_status) {
 326         case FLT_OVFL:
 327                 node_warning(exp, "floating point overflow on %s",
 328                                 symbol2str(exp->nd_symb));
 329                 break;
 330         case FLT_DIV0:
 331                 node_error(exp, "division by 0.0");
 332                 break;
 333         }
 334
 335         if (p->r_real) {
 336                 free(p->r_real);
 337                 p->r_real = 0;
 338         }
 339         if (compar) {
 340                 free_real(p);
 341         }
 342         commonbin(expp);
 343         exp = *expp;
 344         if (compar) {
 345                 exp->nd_symb = INTEGER;
 346                 exp->nd_INT = cmpval;
 347         }
 348         else {
 349                 exp->nd_REAL = p;
 350         }
 351         CutSize(exp);
 352 }
 353
 354 cstubin(expp)
 355         t_node **expp;
 356 {
 357         /*      The binary operation in "expp" is performed on the constant
 358                 expressions below it, and the result restored in
 359                 expp.
 360         */
 361         register t_node *exp = *expp;
 362         arith o1 = exp->nd_LEFT->nd_INT;
 363         arith o2 = exp->nd_RIGHT->nd_INT;
 364         register int sz = exp->nd_type->tp_size;
 365         arith tmp1, tmp2;
 366
 367         assert(exp->nd_class == Oper);
 368         assert(exp->nd_LEFT->nd_class == Value);
 369         assert(exp->nd_RIGHT->nd_class == Value);
 370
 371         switch (exp->nd_symb)   {
 372         case '*':
 373                 if (o1 == 0 || o2 == 0) {
 374                         o1 = 0;
 375                         break;
 376                 }
 377                 tmp1 = full_mask[sz];
 378                 tmp2 = o2;
 379                 divide(&tmp1, &tmp2);
 380                 if (! chk_bounds(o1, tmp1, T_CARDINAL)) overflow(exp);
 381                 o1 *= o2;
 382                 break;
 383
 384         case DIV:
 385         case MOD:
 386                 if (o2 == 0)    {
 387                         node_error(exp, exp->nd_symb == DIV ?
 388                                         "division by 0" :
 389                                         "modulo by 0");
 390                         return;
 391                 }
 392                 divide(&o1, &o2);
 393                 if (exp->nd_symb == MOD) o1 = o2;
 394                 break;
 395
 396         case '+':
 397                 if (! chk_bounds(o2, full_mask[sz] - o1, T_CARDINAL)) {
 398                         overflow(exp);
 399                 }
 400                 o1 += o2;
 401                 break;
 402
 403         case '-':
 404                 if (  exp->nd_type != address_type
 405                    && !chk_bounds(o2, o1, T_CARDINAL)
 406                    && (  exp->nd_type->tp_fund != T_INTORCARD
 407                       || ( exp->nd_type = int_type
 408                          , !chk_bounds(min_int[sz], o1 - o2, T_CARDINAL) ) )
 409                    ) {
 410                         node_warning(exp, W_ORDINARY,
 411                                 "underflow in constant expression");
 412                 }
 413                 o1 -= o2;
 414                 break;
 415
 416         case '<':
 417                 o1 = ! chk_bounds(o2, o1, T_CARDINAL);
 418                 break;
 419
 420         case '>':
 421                 o1 = ! chk_bounds(o1, o2, T_CARDINAL);
 422                 break;
 423
 424         case LESSEQUAL:
 425                 o1 = chk_bounds(o1, o2, T_CARDINAL);
 426                 break;
 427
 428         case GREATEREQUAL:
 429                 o1 = chk_bounds(o2, o1, T_CARDINAL);
 430                 break;
 431
 432         case '=':
 433                 o1 = (o1 == o2);
 434                 break;
 435
 436         case '#':
 437                 o1 = (o1 != o2);
 438                 break;
 439
 440         case AND:
 441         case '&':
 442                 o1 = (o1 && o2);
 443                 break;
 444
 445         case OR:
 446                 o1 = (o1 || o2);
 447                 break;
 448
 449         default:
 450                 crash("(cstubin)");
 451         }
 452
 453         commonbin(expp);
 454         exp = *expp;
 455         exp->nd_INT = o1;
 456         if (exp->nd_type == bool_type) exp->nd_symb = INTEGER;
 457         CutSize(exp);
 458 }
 459
 460 cstset(expp)
 461         t_node **expp;
 462 {
 463         extern arith *MkSet();
 464         register t_node *exp = *expp;
 465         register arith *set1, *set2, *set3;
 466         register unsigned int setsize;
 467         register int j;
 468
 469         assert(exp->nd_RIGHT->nd_class == Set);
 470         assert(exp->nd_symb == IN || exp->nd_LEFT->nd_class == Set);
 471
 472         set2 = exp->nd_RIGHT->nd_set;
 473         setsize = (unsigned) (exp->nd_RIGHT->nd_type->tp_size) / (unsigned) word_size;
 474
 475         if (exp->nd_symb == IN) {
 476                 /*      The setsize must fit in an unsigned, as it is
 477                         allocated with Malloc, so we can do the arithmetic
 478                         in an unsigned too.
 479                 */
 480                 unsigned i;
 481
 482                 assert(exp->nd_LEFT->nd_class == Value);
 483
 484                 exp->nd_LEFT->nd_INT -= exp->nd_RIGHT->nd_type->set_low;
 485                 exp = exp->nd_LEFT;
 486                 i = exp->nd_INT;
 487                 /*      Careful here; use exp->nd_LEFT->nd_INT to see if
 488                         it falls in the range of the set. Do not use i
 489                         for this, as i may be truncated.
 490                 */
 491                 i = (exp->nd_INT >= 0 &&
 492                      exp->nd_INT < setsize * wrd_bits &&
 493                     (set2[i / wrd_bits] & (1 << (i % wrd_bits))));
 494                 FreeSet(set2);
 495                 exp = getnode(Value);
 496                 exp->nd_symb = INTEGER;
 497                 exp->nd_lineno = (*expp)->nd_lineno;
 498                 exp->nd_INT = i;
 499                 exp->nd_type = bool_type;
 500                 FreeNode(*expp);
 501                 *expp = exp;
 502                 return;
 503         }
 504
 505         set1 = exp->nd_LEFT->nd_set;
 506         *expp = getnode(Set);
 507         (*expp)->nd_type = exp->nd_type;
 508         (*expp)->nd_lineno = exp->nd_lineno;
 509         switch(exp->nd_symb) {
 510         case '+': /* Set union */
 511         case '-': /* Set difference */
 512         case '*': /* Set intersection */
 513         case '/': /* Symmetric set difference */
 514                 (*expp)->nd_set = set3 = MkSet(exp->nd_type->set_sz);
 515                 for (j = 0; j < setsize; j++) {
 516                         switch(exp->nd_symb) {
 517                         case '+':
 518                                 *set3++ = *set1++ | *set2++;
 519                                 break;
 520                         case '-':
 521                                 *set3++ = *set1++ & ~*set2++;
 522                                 break;
 523                         case '*':
 524                                 *set3++ = *set1++ & *set2++;
 525                                 break;
 526                         case '/':
 527                                 *set3++ = *set1++ ^ *set2++;
 528                                 break;
 529                         }
 530                 }
 531                 break;
 532
 533         case GREATEREQUAL:
 534         case LESSEQUAL:
 535         case '=':
 536         case '#':
 537                 /* Constant set comparisons
 538                 */
 539                 for (j = 0; j < setsize; j++) {
 540                         switch(exp->nd_symb) {
 541                         case GREATEREQUAL:
 542                                 if ((*set1 | *set2++) != *set1) break;
 543                                 set1++;
 544                                 continue;
 545                         case LESSEQUAL:
 546                                 if ((*set2 | *set1++) != *set2) break;
 547                                 set2++;
 548                                 continue;
 549                         case '=':
 550                         case '#':
 551                                 if (*set1++ != *set2++) break;
 552                                 continue;
 553                         }
 554                         break;
 555                 }
 556                 if (j < setsize) {
 557                         j = exp->nd_symb == '#';
 558                 }
 559                 else {
 560                         j = exp->nd_symb != '#';
 561                 }
 562                 *expp = getnode(Value);
 563                 (*expp)->nd_symb = INTEGER;
 564                 (*expp)->nd_INT = j;
 565                 (*expp)->nd_type = bool_type;
 566                 (*expp)->nd_lineno = (*expp)->nd_lineno;
 567                 break;
 568         default:
 569                 crash("(cstset)");
 570         }
 571         FreeSet(exp->nd_LEFT->nd_set);
 572         FreeSet(exp->nd_RIGHT->nd_set);
 573         FreeNode(exp);
 574 }
 575
 576 cstcall(expp, call)
 577         t_node **expp;
 578 {
 579         /*      a standard procedure call is found that can be evaluated
 580                 compile time, so do so.
 581         */
 582         register t_node *expr;
 583         register t_type *tp;
 584
 585         assert((*expp)->nd_class == Call);
 586         expr = (*expp)->nd_RIGHT->nd_LEFT;
 587         tp = expr->nd_type;
 588         expr->nd_type = (*expp)->nd_type;
 589
 590         (*expp)->nd_RIGHT->nd_LEFT = 0;
 591         FreeNode(*expp);
 592         *expp = expr;
 593         expr->nd_symb = INTEGER;
 594         expr->nd_class = Value;
 595         switch(call) {
 596         case S_ABS:
 597                 if (expr->nd_INT < 0) {
 598                         if (! options['s'] &&
 599                             expr->nd_INT <= min_int[(int)(tp->tp_size)]) {
 600                                 overflow(expr);
 601                         }
 602                         expr->nd_INT = - expr->nd_INT;
 603                 }
 604                 CutSize(expr);
 605                 break;
 606
 607         case S_CAP:
 608                 if (expr->nd_INT >= 'a' && expr->nd_INT <= 'z') {
 609                         expr->nd_INT += ('A' - 'a');
 610                 }
 611                 break;
 612
 613         case S_HIGH:
 614         case S_MAX:
 615                 if (tp->tp_fund == T_INTEGER) {
 616                         expr->nd_INT = max_int[(int)(tp->tp_size)];
 617                 }
 618                 else if (tp->tp_fund == T_CARDINAL) {
 619                         expr->nd_INT = full_mask[(int)(tp->tp_size)];
 620                 }
 621                 else if (tp->tp_fund == T_SUBRANGE) {
 622                         expr->nd_INT = tp->sub_ub;
 623                 }
 624                 else    expr->nd_INT = tp->enm_ncst - 1;
 625                 break;
 626
 627         case S_MIN:
 628                 if (tp->tp_fund == T_INTEGER) {
 629                         expr->nd_INT = min_int[(int)(tp->tp_size)];
 630                 }
 631                 else if (tp->tp_fund == T_SUBRANGE) {
 632                         expr->nd_INT = tp->sub_lb;
 633                 }
 634                 else    expr->nd_INT = 0;
 635                 break;
 636
 637         case S_ODD:
 638                 expr->nd_INT &= 1;
 639                 break;
 640
 641         case S_TSIZE:
 642         case S_SIZE:
 643                 expr->nd_INT = tp->tp_size;
 644                 break;
 645
 646         default:
 647                 crash("(cstcall)");
 648         }
 649 }
 650
 651 CutSize(expr)
 652         register t_node *expr;
 653 {
 654         /*      The constant value of the expression expr is made to
 655                 conform to the size of the type of the expression.
 656         */
 657         register t_type *tp = BaseType(expr->nd_type);
 658
 659         assert(expr->nd_class == Value);
 660         if (tp->tp_fund == T_REAL) return;
 661         if (tp->tp_fund != T_INTEGER) {
 662                 expr->nd_INT &= full_mask[(int)(tp->tp_size)];
 663         }
 664         else {
 665                 int nbits = (int) (sizeof(arith) - tp->tp_size) * 8;
 666
 667                 expr->nd_INT = (expr->nd_INT << nbits) >> nbits;
 668         }
 669 }
 670
 671 InitCst()
 672 {
 673         register int i = 0;
 674 #ifndef NOCROSS
 675         register arith bt = (arith)0;
 676
 677         while (!(bt < 0))       {
 678                 i++;
 679                 bt = (bt << 8) + 0377;
 680                 if (i == MAXSIZE+1)
 681                         fatal("array full_mask too small for this machine");
 682                 full_mask[i] = bt;
 683                 max_int[i] = bt & ~(1L << ((8 * i) - 1));
 684                 min_int[i] = - max_int[i];
 685                 if (! options['s']) min_int[i]--;
 686         }
 687         if ((int)long_size > sizeof(arith)) {
 688                 fatal("sizeof (arith) insufficient on this machine");
 689         }
 690
 691         wrd_bits = 8 * (int) word_size;
 692 #else
 693         if (options['s']) {
 694                 for (i = 0; i < sizeof(long); i++) min_int[i] = - max_int[i];
 695         }
 696 #endif
 697 }