lang/m2/comp/code.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 D E   G E N E R A T I O N   R O U T I N E S */
   9
  10 /* $Id: code.c,v 1.80 1996/11/19 09:12:36 ceriel Exp $ */
  11
  12 /*      Code generation for expressions and coercions
  13 */
  14
  15 #include        "debug.h"
  16
  17 #include        <em_arith.h>
  18 #include        <em_label.h>
  19 #include        <em_code.h>
  20 #include        <em_abs.h>
  21 #include        <assert.h>
  22 #include        <alloc.h>
  23
  24 #include        "type.h"
  25 #include        "LLlex.h"
  26 #include        "def.h"
  27 #include        "scope.h"
  28 #include        "desig.h"
  29 #include        "node.h"
  30 #include        "Lpars.h"
  31 #include        "standards.h"
  32 #include        "walk.h"
  33 #include        "bigresult.h"
  34
  35 extern int      proclevel;
  36 extern char     options[];
  37 extern t_desig  null_desig;
  38 int             fp_used;
  39
  40 CodeConst(cst, size)
  41         arith cst;
  42         int size;
  43 {
  44         /*      Generate code to push constant "cst" with size "size"
  45         */
  46
  47         if (size <= (int) word_size) {
  48                 C_loc(cst);
  49         }
  50         else if (size == (int) dword_size) {
  51                 C_ldc(cst);
  52         }
  53         else {
  54                 crash("(CodeConst)");
  55         }
  56 }
  57
  58 CodeString(nd)
  59         register t_node *nd;
  60 {
  61         if (nd->nd_type->tp_fund != T_STRING) {
  62                 /* Character constant */
  63                 CodeConst(nd->nd_INT, nd->nd_type->tp_size);
  64                 return;
  65         }
  66         C_df_dlb(++data_label);
  67         C_rom_scon(nd->nd_STR, WA((arith)(nd->nd_SLE + 1)));
  68         c_lae_dlb(data_label);
  69 }
  70
  71 CodeExpr(nd, ds, true_label, false_label)
  72         register t_node *nd;
  73         register t_desig *ds;
  74         label true_label, false_label;
  75 {
  76         register t_type *tp = nd->nd_type;
  77
  78         DoLineno(nd);
  79         if (tp->tp_fund == T_REAL) fp_used = 1;
  80         switch(nd->nd_class) {
  81         case Def:
  82                 if (nd->nd_def->df_kind & (D_PROCEDURE|D_PROCHEAD)) {
  83                         C_lpi(nd->nd_def->prc_name);
  84                         ds->dsg_kind = DSG_LOADED;
  85                         break;
  86                 }
  87                 /* Fall through */
  88
  89         case Link:
  90         case Arrsel:
  91         case Arrow:
  92                 CodeDesig(nd, ds);
  93                 break;
  94
  95         case Oper:
  96                 CodeOper(nd, true_label, false_label);
  97                 ds->dsg_kind = DSG_LOADED;
  98                 true_label = NO_LABEL;
  99                 break;
 100
 101         case Uoper:
 102                 CodeUoper(nd);
 103                 ds->dsg_kind = DSG_LOADED;
 104                 break;
 105
 106         case Value:
 107                 switch(nd->nd_symb) {
 108                 case REAL:
 109                         C_df_dlb(++data_label);
 110                         if (! nd->nd_RSTR) {
 111                                 static char buf[FLT_STRLEN];
 112
 113                                 flt_flt2str(&nd->nd_RVAL, buf, FLT_STRLEN);
 114                                 C_rom_fcon(buf, tp->tp_size);
 115                         }
 116                         else C_rom_fcon(nd->nd_RSTR, tp->tp_size);
 117                         c_lae_dlb(data_label);
 118                         C_loi(tp->tp_size);
 119                         break;
 120                 case STRING:
 121                         CodeString(nd);
 122                         break;
 123                 case INTEGER:
 124                         CodeConst(nd->nd_INT, (int) (tp->tp_size));
 125                         break;
 126                 default:
 127                         crash("Value error");
 128                 }
 129                 ds->dsg_kind = DSG_LOADED;
 130                 break;
 131
 132         case Call:
 133                 CodeCall(nd);
 134                 ds->dsg_kind = DSG_LOADED;
 135                 break;
 136
 137         case Set: {
 138                 register unsigned i = (unsigned) (tp->tp_size) / (int) word_size;
 139                 register arith *st = nd->nd_set + i;
 140                 int null_set = 1;
 141
 142                 ds->dsg_kind = DSG_LOADED;
 143                 for (; i; i--) {
 144                         if (*--st != 0) null_set = 0;
 145                 }
 146                 if (! null_set) {
 147                         i = (unsigned) (tp->tp_size) / (int) word_size;
 148                         st = nd->nd_set + i;
 149                         for (; i; i--) {
 150                                 C_loc(*--st);
 151                         }
 152                 }
 153                 FreeSet(nd->nd_set);
 154                 CodeSet(nd, null_set);
 155                 }
 156                 break;
 157
 158         default:
 159                 crash("(CodeExpr) bad node type");
 160         }
 161
 162         if (true_label != NO_LABEL) {
 163                 /* Only for boolean expressions
 164                 */
 165                 CodeValue(ds, tp);
 166                 C_zne(true_label);
 167                 c_bra(false_label);
 168         }
 169 }
 170
 171 CodeCoercion(t1, t2)
 172         t_type *t1, *t2;
 173 {
 174         int fund1, fund2;
 175         int sz1 = t1->tp_size;
 176         int sz2;
 177
 178         t1 = BaseType(t1);
 179         t2 = BaseType(t2);
 180         sz2 = t2->tp_size;
 181         switch(fund1 = t1->tp_fund) {
 182         case T_WORD:
 183                 fund1 = T_INTEGER;
 184                 break;
 185         case T_CHAR:
 186         case T_ENUMERATION:
 187         case T_CARDINAL:
 188         case T_INTORCARD:
 189                 if (sz1 < (int) word_size) sz1 = word_size;
 190                 /* fall through */
 191         case T_EQUAL:
 192         case T_POINTER:
 193                 fund1 = T_CARDINAL;
 194                 break;
 195         }
 196         switch(fund2 = t2->tp_fund) {
 197         case T_WORD:
 198                 fund2 = T_INTEGER;
 199                 break;
 200         case T_CHAR:
 201         case T_ENUMERATION:
 202                 sz2 = word_size;
 203                 /* fall through */
 204         case T_EQUAL:
 205         case T_POINTER:
 206                 fund2 = T_CARDINAL;
 207                 break;
 208         }
 209
 210         switch(fund1) {
 211         case T_INTEGER:
 212                 if (sz1 < (int) word_size) {
 213                         c_loc(sz1);
 214                         c_loc((int) word_size);
 215                         C_cii();
 216                         sz1 = word_size;
 217                 }
 218                 c_loc(sz1);
 219                 c_loc(sz2);
 220                 switch(fund2) {
 221                 case T_REAL:
 222                         C_cif();
 223                         break;
 224                 case T_INTEGER:
 225                         C_cii();
 226                         break;
 227                 case T_CARDINAL:
 228                         C_ciu();
 229                         break;
 230                 default:
 231                         crash("Funny integer conversion");
 232                 }
 233                 break;
 234
 235         case T_CARDINAL:
 236         case T_INTORCARD:
 237                 c_loc(sz1);
 238                 c_loc(sz2);
 239                 switch(fund2) {
 240                 case T_REAL:
 241                         C_cuf();
 242                         break;
 243                 case T_CARDINAL:
 244                 case T_INTORCARD:
 245                         C_cuu();
 246                         break;
 247                 case T_INTEGER:
 248                         C_cui();
 249                         break;
 250                 default:
 251                         crash("Funny cardinal conversion");
 252                 }
 253                 break;
 254
 255         case T_REAL:
 256                 switch(fund2) {
 257                 case T_REAL:
 258                         c_loc(sz1);
 259                         c_loc(sz2);
 260                         C_cff();
 261                         break;
 262                 case T_INTEGER:
 263                         c_loc(sz1);
 264                         c_loc(sz2);
 265                         C_cfi();
 266                         break;
 267                 case T_CARDINAL:
 268                         if (! options['R']) {
 269                                 label lb = ++text_label;
 270                                 arith asz1 = sz1;
 271
 272                                 C_dup(asz1);
 273                                 C_zrf(asz1);
 274                                 C_cmf(asz1);
 275                                 C_zge(lb);
 276                                 c_loc(ECONV);
 277                                 C_trp();
 278                                 def_ilb(lb);
 279                         }
 280                         c_loc(sz1);
 281                         c_loc(sz2);
 282                         C_cfu();
 283                         break;
 284                 default:
 285                         crash("Funny REAL conversion");
 286                 }
 287                 break;
 288         }
 289 }
 290
 291 CodeCall(nd)
 292         register t_node *nd;
 293 {
 294         /*      Generate code for a procedure call. Checking of parameters
 295                 and result is already done.
 296         */
 297         register t_node *left = nd->nd_LEFT;
 298         t_type *result_tp;
 299         int needs_fn;
 300
 301         if (left->nd_type == std_type) {
 302                 CodeStd(nd);
 303                 return;
 304         }
 305
 306         assert(IsProc(left));
 307
 308         result_tp = ResultType(left->nd_type);
 309 #ifdef BIG_RESULT_ON_STACK
 310         if (result_tp && TooBigForReturnArea(result_tp)) {
 311                 C_asp(-WA(result_tp->tp_size));
 312         }
 313 #endif
 314
 315         if (nd->nd_RIGHT) {
 316                 CodeParameters(ParamList(left->nd_type), nd->nd_RIGHT);
 317         }
 318
 319         switch(left->nd_class) {
 320         case Def: {
 321                 register t_def *df = left->nd_def;
 322
 323                 if (df->df_kind == D_CONST) {
 324                         /* a procedure address */
 325                         df = df->con_const.tk_data.tk_def;
 326                 }
 327                 if (df->df_kind & (D_PROCEDURE|D_PROCHEAD)) {
 328                         int level = df->df_scope->sc_level;
 329
 330                         if (level > 0) {
 331                                 C_lxl((arith) (proclevel - level));
 332                         }
 333                         needs_fn = df->df_scope->sc_defmodule;
 334                         C_cal(df->prc_name);
 335                         break;
 336                 }}
 337                 /* Fall through */
 338         default:
 339                 needs_fn = 1;
 340                 CodePExpr(left);
 341                 C_cai();
 342         }
 343         C_asp(left->nd_type->prc_nbpar);
 344         if (result_tp) {
 345                 arith sz = WA(result_tp->tp_size);
 346                 if (TooBigForReturnArea(result_tp)) {
 347 #ifndef BIG_RESULT_ON_STACK
 348                         C_lfr(pointer_size);
 349                         C_loi(sz);
 350 #endif
 351                 }
 352                 else    C_lfr(sz);
 353         }
 354         DoFilename(needs_fn);
 355         DoLineno(nd);
 356 }
 357
 358 CodeParameters(param, arg)
 359         t_param *param;
 360         register t_node *arg;
 361 {
 362         register t_type *tp;
 363         register t_type *arg_type;
 364
 365         assert(param != 0 && arg != 0);
 366
 367         if (param->par_next) {
 368                 CodeParameters(param->par_next, arg->nd_RIGHT);
 369         }
 370
 371         tp = TypeOfParam(param);
 372         arg = arg->nd_LEFT;
 373         arg_type = arg->nd_type;
 374         if (IsConformantArray(tp)) {
 375                 register t_type *elem = tp->arr_elem;
 376
 377                 C_loc(tp->arr_elsize);
 378                 if (IsConformantArray(arg_type)) {
 379                         DoHIGH(arg->nd_def);
 380                         if (elem->tp_size != arg_type->arr_elem->tp_size) {
 381                                 /* This can only happen if the formal type is
 382                                    ARRAY OF (WORD|BYTE)
 383                                 */
 384                                 C_loc(arg_type->arr_elem->tp_size);
 385                                 C_mlu(word_size);
 386                                 if (elem == word_type) {
 387                                         c_loc((int) word_size - 1);
 388                                         C_adu(word_size);
 389                                         c_loc((int) word_size - 1);
 390                                         C_and(word_size);
 391                                 }
 392                                 else {
 393                                         assert(elem == byte_type);
 394                                 }
 395                         }
 396                 }
 397                 else if (arg->nd_symb == STRING) {
 398                         c_loc((int) arg->nd_SLE - 1);
 399                 }
 400                 else if (elem == word_type) {
 401                         C_loc((arg_type->tp_size+word_size-1) / word_size - 1);
 402                 }
 403                 else if (elem == byte_type) {
 404                         C_loc(arg_type->tp_size - 1);
 405                 }
 406                 else {
 407                         C_loc(arg_type->arr_high - arg_type->arr_low);
 408                 }
 409                 c_loc(0);
 410         }
 411         if (IsConformantArray(tp) || IsVarParam(param)) {
 412                 if (arg->nd_symb == STRING) {
 413                         CodeString(arg);
 414                 }
 415                 else switch(arg->nd_class) {
 416                 case Arrsel:
 417                 case Arrow:
 418                 case Def:
 419                         CodeDAddress(arg, IsVarParam(param));
 420                         break;
 421                 default:{
 422                         arith tmp, TmpSpace();
 423                         arith sz = WA(arg->nd_type->tp_size);
 424
 425                         CodePExpr(arg);
 426                         tmp = TmpSpace(sz, arg->nd_type->tp_align);
 427                         STL(tmp, sz);
 428                         C_lal(tmp);
 429                         }
 430                         break;
 431                 }
 432                 return;
 433         }
 434         if (arg_type->tp_fund == T_STRING) {
 435                 CodePString(arg, tp);
 436                 return;
 437         }
 438         CodePExpr(arg);
 439 }
 440
 441 CodePString(nd, tp)
 442         t_node *nd;
 443         t_type *tp;
 444 {
 445         arith szarg = WA(nd->nd_type->tp_size);
 446         register arith zersz = WA(tp->tp_size) - szarg;
 447
 448         if (zersz) {
 449                 /* null padding required */
 450                 assert(zersz > 0);
 451                 C_zer(zersz);
 452         }
 453         CodeString(nd); /* push address of string */
 454         C_loi(szarg);
 455 }
 456
 457 static
 458 subu(sz)
 459         int sz;
 460 {
 461         if (! options['R']) {
 462                 C_cal(sz == (int) word_size ? "subuchk" : "subulchk");
 463         }
 464         C_sbu((arith) sz);
 465 }
 466
 467 static
 468 addu(sz)
 469         int sz;
 470 {
 471         if (! options['R']) {
 472                 C_cal(sz == (int) word_size ? "adduchk" : "addulchk");
 473         }
 474         C_adu((arith)sz);
 475 }
 476
 477 static int
 478 complex_lhs(nd)
 479         register t_node *nd;
 480 {
 481         switch(nd->nd_class) {
 482         case Value:
 483         case Name:
 484         case Set:
 485         case Def:
 486                 return 0;
 487         case Select:
 488                 return complex_lhs(nd->nd_NEXT);
 489         default:
 490                 return 1;
 491         }
 492 }
 493
 494 CodeStd(nd)
 495         t_node *nd;
 496 {
 497         register t_node *arg = nd->nd_RIGHT;
 498         register t_node *left = 0;
 499         register t_type *tp = 0;
 500         int std = nd->nd_LEFT->nd_def->df_value.df_stdname;
 501
 502         if (arg) {
 503                 left = arg->nd_LEFT;
 504                 tp = BaseType(left->nd_type);
 505                 arg = arg->nd_RIGHT;
 506         }
 507
 508         switch(std) {
 509         case S_ORD:
 510         case S_VAL:
 511                 CodePExpr(left);
 512                 break;
 513
 514         case S_ABS:
 515                 CodePExpr(left);
 516                 if (tp->tp_fund == T_INTEGER) {
 517                         CAL((int)(tp->tp_size) == (int)int_size ? "absi" : "absl", (int)(tp->tp_size));
 518                 }
 519                 else if (tp->tp_fund == T_REAL) {
 520                         CAL((int)(tp->tp_size) == (int)float_size ? "absf" : "absd", (int)(tp->tp_size));
 521                 }
 522                 C_lfr(tp->tp_size);
 523                 break;
 524
 525         case S_CAP:
 526                 CodePExpr(left);
 527                 C_cal("cap");
 528                 break;
 529
 530         case S_HIGH:
 531                 assert(IsConformantArray(tp));
 532                 DoHIGH(left->nd_def);
 533                 break;
 534
 535         case S_SIZE:
 536         case S_TSIZE:
 537                 assert(IsConformantArray(tp));
 538                 DoHIGH(left->nd_def);
 539                 C_inc();
 540                 C_loc(tp->arr_elem->tp_size);
 541                 C_mlu(word_size);
 542                 break;
 543
 544         case S_ODD:
 545                 CodePExpr(left);
 546                 if ((int) tp->tp_size == (int) word_size) {
 547                         c_loc(1);
 548                         C_and(word_size);
 549                 }
 550                 else {
 551                         assert(tp->tp_size == dword_size);
 552                         C_ldc((arith) 1);
 553                         C_and(dword_size);
 554                         C_ior(word_size);
 555                 }
 556                 break;
 557
 558         case S_ADR:
 559                 CodeDAddress(left, 1);
 560                 break;
 561
 562         case S_DEC:
 563         case S_INC: {
 564                 register arith size;
 565                 int compl = complex_lhs(left);
 566                 arith tmp = 0;
 567
 568                 size = left->nd_type->tp_size;
 569                 if ((int) size < (int) word_size) size = word_size;
 570                 if (compl) {
 571                         tmp = NewPtr();
 572                         CodeDAddress(left, 1);
 573                         STL(tmp, pointer_size);
 574                         LOL(tmp, pointer_size);
 575                         C_loi(left->nd_type->tp_size);
 576                 }
 577                 else CodePExpr(left);
 578                 CodeCoercion(left->nd_type, tp);
 579                 if (arg) {
 580                         CodePExpr(arg->nd_LEFT);
 581                         CodeCoercion(arg->nd_LEFT->nd_type, tp);
 582                 }
 583                 else    {
 584                         c_loc(1);
 585                         CodeCoercion(intorcard_type, tp);
 586                 }
 587                 if (std == S_DEC) {
 588                         if (tp->tp_fund == T_INTEGER) C_sbi(size);
 589                         else    subu((int) size);
 590                 }
 591                 else {
 592                         if (tp->tp_fund == T_INTEGER) C_adi(size);
 593                         else    addu((int) size);
 594                 }
 595                 if ((int) size == (int) word_size) {
 596                         RangeCheck(left->nd_type, tp->tp_fund == T_INTEGER ?
 597                                                 int_type : card_type);
 598                 }
 599                 if (compl) {
 600                         LOL(tmp, pointer_size);
 601                         C_sti(left->nd_type->tp_size);
 602                         FreePtr(tmp);
 603                 }
 604                 else CodeDStore(left);
 605                 break;
 606                 }
 607
 608         case S_HALT:
 609                 C_cal("halt");
 610                 break;
 611
 612         case S_INCL:
 613         case S_EXCL: {
 614                 int compl = complex_lhs(left);
 615                 arith tmp = 0;
 616
 617                 if (compl) {
 618                         tmp = NewPtr();
 619                         CodeDAddress(left, 1);
 620                         STL(tmp, pointer_size);
 621                         LOL(tmp, pointer_size);
 622                         C_loi(left->nd_type->tp_size);
 623                 }
 624                 else CodePExpr(left);
 625                 CodePExpr(arg->nd_LEFT);
 626                 C_loc(tp->set_low);
 627                 C_sbi(word_size);
 628                 C_set(tp->tp_size);
 629                 if (std == S_INCL) {
 630                         C_ior(tp->tp_size);
 631                 }
 632                 else {
 633                         C_com(tp->tp_size);
 634                         C_and(tp->tp_size);
 635                 }
 636                 if (compl) {
 637                         LOL(tmp, pointer_size);
 638                         C_sti(left->nd_type->tp_size);
 639                         FreePtr(tmp);
 640                 }
 641                 else CodeDStore(left);
 642                 break;
 643                 }
 644
 645         default:
 646                 crash("(CodeStd)");
 647         }
 648 }
 649
 650 int
 651 needs_rangecheck(tpl, tpr)
 652         register t_type *tpl, *tpr;
 653 {
 654         arith rlo, rhi;
 655
 656         if (bounded(tpl)) {
 657                 /* In this case we might need a range check.
 658                    If both types are restricted. check the bounds
 659                    to see wether we need a range check.
 660                    We don't need one if the range of values of the
 661                    right hand side is a subset of the range of values
 662                    of the left hand side.
 663                 */
 664                 if (bounded(tpr)) {
 665                         getbounds(tpr, &rlo, &rhi);
 666                         if (in_range(rlo, tpl) && in_range(rhi, tpl)) {
 667                                 return 0;
 668                         }
 669                 }
 670                 return 1;
 671         }
 672         return 0;
 673 }
 674
 675 RangeCheck(tpl, tpr)
 676         register t_type *tpl, *tpr;
 677 {
 678         /*      Generate a range check if neccessary
 679         */
 680
 681         arith rlo, rhi;
 682
 683         if (options['R']) return;
 684
 685         if (needs_rangecheck(tpl, tpr)) {
 686                 genrck(tpl);
 687                 return;
 688         }
 689         tpr = BaseType(tpr);
 690         if ((tpl->tp_fund == T_INTEGER && tpr->tp_fund == T_CARDINAL) ||
 691              (tpr->tp_fund == T_INTEGER && tpl->tp_fund == T_CARDINAL)) {
 692                 label lb = ++text_label;
 693
 694                 C_dup(tpr->tp_size);
 695                 C_zer(tpr->tp_size);
 696                 C_cmi(tpr->tp_size);
 697                 C_zge(lb);
 698                 c_loc(ECONV);
 699                 C_trp();
 700                 def_ilb(lb);
 701         }
 702 }
 703
 704 Operands(nd)
 705         register t_node *nd;
 706 {
 707
 708         CodePExpr(nd->nd_LEFT);
 709         CodePExpr(nd->nd_RIGHT);
 710         DoLineno(nd);
 711 }
 712
 713 CodeOper(expr, true_label, false_label)
 714         register t_node *expr;  /* the expression tree itself   */
 715         label true_label;
 716         label false_label;      /* labels to jump to in logical expr's  */
 717 {
 718         register t_node *leftop = expr->nd_LEFT;
 719         register t_node *rightop = expr->nd_RIGHT;
 720         int fund = expr->nd_type->tp_fund;
 721         arith size = expr->nd_type->tp_size;
 722
 723         switch (expr->nd_symb)  {
 724         case '+':
 725                 Operands(expr);
 726                 switch (fund)   {
 727                 case T_INTEGER:
 728                         C_adi(size);
 729                         break;
 730                 case T_REAL:
 731                         C_adf(size);
 732                         break;
 733                 case T_POINTER:
 734                 case T_EQUAL:
 735                         C_ads(rightop->nd_type->tp_size);
 736                         break;
 737                 case T_CARDINAL:
 738                 case T_INTORCARD:
 739                         addu((int) size);
 740                         break;
 741                 case T_SET:
 742                         C_ior(size);
 743                         break;
 744                 default:
 745                         crash("bad type +");
 746                 }
 747                 break;
 748         case '-':
 749                 Operands(expr);
 750                 switch (fund)   {
 751                 case T_INTEGER:
 752                         C_sbi(size);
 753                         break;
 754                 case T_REAL:
 755                         C_sbf(size);
 756                         break;
 757                 case T_POINTER:
 758                 case T_EQUAL:
 759                         if (rightop->nd_type == address_type) {
 760                                 C_sbs(size);
 761                                 break;
 762                         }
 763                         C_ngi(rightop->nd_type->tp_size);
 764                         C_ads(rightop->nd_type->tp_size);
 765                         break;
 766                 case T_INTORCARD:
 767                 case T_CARDINAL:
 768                         subu((int) size);
 769                         break;
 770                 case T_SET:
 771                         C_com(size);
 772                         C_and(size);
 773                         break;
 774                 default:
 775                         crash("bad type -");
 776                 }
 777                 break;
 778         case '*':
 779                 Operands(expr);
 780                 switch (fund)   {
 781                 case T_INTEGER:
 782                         C_mli(size);
 783                         break;
 784                 case T_POINTER:
 785                 case T_EQUAL:
 786                 case T_CARDINAL:
 787                 case T_INTORCARD:
 788                         if (! options['R']) {
 789                                 C_cal((int)(size) <= (int)word_size ?
 790                                         "muluchk" :
 791                                         "mululchk");
 792                         }
 793                         C_mlu(size);
 794                         break;
 795                 case T_REAL:
 796                         C_mlf(size);
 797                         break;
 798                 case T_SET:
 799                         C_and(size);
 800                         break;
 801                 default:
 802                         crash("bad type *");
 803                 }
 804                 break;
 805         case '/':
 806                 Operands(expr);
 807                 switch (fund)   {
 808                 case T_REAL:
 809                         C_dvf(size);
 810                         break;
 811                 case T_SET:
 812                         C_xor(size);
 813                         break;
 814                 default:
 815                         crash("bad type /");
 816                 }
 817                 break;
 818         case DIV:
 819                 Operands(expr);
 820                 switch(fund)    {
 821                 case T_INTEGER:
 822                         C_cal((int)(size) == (int)word_size
 823                                 ? "dvi"
 824                                 : "dvil");
 825                         C_asp(2*size);
 826                         C_lfr(size);
 827                         break;
 828                 case T_POINTER:
 829                 case T_EQUAL:
 830                 case T_CARDINAL:
 831                 case T_INTORCARD:
 832                         C_dvu(size);
 833                         break;
 834                 default:
 835                         crash("bad type DIV");
 836                 }
 837                 break;
 838         case MOD:
 839                 Operands(expr);
 840                 switch(fund)    {
 841                 case T_INTEGER:
 842                         C_cal((int)(size) == (int)word_size
 843                                 ? "rmi"
 844                                 : "rmil");
 845                         C_asp(2*size);
 846                         C_lfr(size);
 847                         break;
 848                 case T_POINTER:
 849                 case T_EQUAL:
 850                 case T_CARDINAL:
 851                 case T_INTORCARD:
 852                         C_rmu(size);
 853                         break;
 854                 default:
 855                         crash("bad type MOD");
 856                 }
 857                 break;
 858         case '<':
 859         case LESSEQUAL:
 860         case '>':
 861         case GREATEREQUAL:
 862         case '=':
 863         case '#': {
 864                 t_type *tp;
 865
 866                 Operands(expr);
 867                 tp = BaseType(leftop->nd_type);
 868                 if (tp->tp_fund == T_INTORCARD) tp = BaseType(rightop->nd_type);
 869                 size = tp->tp_size;
 870                 switch (tp->tp_fund)    {
 871                 case T_INTEGER:
 872                         C_cmi(size);
 873                         break;
 874                 case T_POINTER:
 875                 case T_HIDDEN:
 876                 case T_EQUAL:
 877                         C_cmp();
 878                         break;
 879                 case T_CARDINAL:
 880                 case T_INTORCARD:
 881                         C_cmu(size);
 882                         break;
 883                 case T_ENUMERATION:
 884                 case T_CHAR:
 885                         C_cmu(word_size);
 886                         break;
 887                 case T_REAL:
 888                         C_cmf(size);
 889                         break;
 890                 case T_SET:
 891                         if (expr->nd_symb == GREATEREQUAL) {
 892                                 /* A >= B is the same as A equals A + B
 893                                 */
 894                                 C_dup(size << 1);
 895                                 C_asp(size);
 896                                 C_ior(size);
 897                                 expr->nd_symb = '=';
 898                         }
 899                         else if (expr->nd_symb == LESSEQUAL) {
 900                                 /* A <= B is the same as A - B = {}
 901                                 */
 902                                 C_com(size);
 903                                 C_and(size);
 904                                 C_zer(size);
 905                                 expr->nd_symb = '=';
 906                         }
 907                         C_cms(size);
 908                         break;
 909                 default:
 910                         crash("bad type COMPARE");
 911                 }
 912                 if (true_label != NO_LABEL)     {
 913                         compare(expr->nd_symb, true_label);
 914                         c_bra(false_label);
 915                         break;
 916                 }
 917                 truthvalue(expr->nd_symb);
 918                 break;
 919                 }
 920
 921         case IN: {
 922                 /* In this case, evaluate right hand side first! The
 923                    INN instruction expects the bit number on top of the
 924                    stack
 925                 */
 926                 label l_toolarge = NO_LABEL, l_cont = NO_LABEL;
 927                 t_type *ltp = leftop->nd_type;
 928
 929                 if (leftop->nd_symb == COERCION) {
 930                         /* Could be coercion to word_type. */
 931                         ltp = leftop->nd_RIGHT->nd_type;
 932                 }
 933                 if (leftop->nd_class == Value) {
 934                         if (! in_range(leftop->nd_INT, ElementType(rightop->nd_type))) {
 935                                 if (true_label != NO_LABEL) {
 936                                         c_bra(false_label);
 937                                 }
 938                                 else    c_loc(0);
 939                                 break;
 940                         }
 941                         CodePExpr(rightop);
 942                         C_loc(leftop->nd_INT - rightop->nd_type->set_low);
 943                 }
 944                 else {
 945                         CodePExpr(rightop);
 946                         CodePExpr(leftop);
 947                         C_loc(rightop->nd_type->set_low);
 948                         C_sbu(word_size);
 949                         if (needs_rangecheck(ElementType(rightop->nd_type), ltp)) {
 950                                 l_toolarge = ++text_label;
 951                                 C_dup(word_size);
 952                                 C_loc(rightop->nd_type->tp_size*8);
 953                                 C_cmu(word_size);
 954                                 C_zge(l_toolarge);
 955                         }
 956                 }
 957                 C_inn(rightop->nd_type->tp_size);
 958                 if (true_label != NO_LABEL) {
 959                         C_zne(true_label);
 960                         c_bra(false_label);
 961                 }
 962                 else {
 963                         l_cont =  ++text_label;
 964                         c_bra(l_cont);
 965                 }
 966                 if (l_toolarge != NO_LABEL) {
 967                         def_ilb(l_toolarge);
 968                         C_asp(word_size+rightop->nd_type->tp_size);
 969                         if (true_label != NO_LABEL) {
 970                                 c_bra(false_label);
 971                         }
 972                         else    c_loc(0);
 973                 }
 974                 if (l_cont != NO_LABEL) {
 975                         def_ilb(l_cont);
 976                 }
 977                 break;
 978                 }
 979         case OR:
 980         case AND: {
 981                 label  l_maybe = ++text_label, l_end = NO_LABEL;
 982                 t_desig Des;
 983
 984                 Des = null_desig;
 985
 986                 if (true_label == NO_LABEL)     {
 987                         true_label = ++text_label;
 988                         false_label = ++text_label;
 989                         l_end = ++text_label;
 990                 }
 991
 992                 if (expr->nd_symb == OR) {
 993                         CodeExpr(leftop, &Des, true_label, l_maybe);
 994                 }
 995                 else    CodeExpr(leftop, &Des, l_maybe, false_label);
 996                 def_ilb(l_maybe);
 997                 Des = null_desig;
 998                 CodeExpr(rightop, &Des, true_label, false_label);
 999                 if (l_end != NO_LABEL) {
1000                         def_ilb(true_label);
1001                         c_loc(1);
1002                         c_bra(l_end);
1003                         def_ilb(false_label);
1004                         c_loc(0);
1005                         def_ilb(l_end);
1006                 }
1007                 break;
1008                 }
1009         default:
1010                 crash("(CodeOper) Bad operator");
1011         }
1012 }
1013
1014 /*      compare() serves as an auxiliary function of CodeOper   */
1015 compare(relop, lbl)
1016         int relop;
1017         register label lbl;
1018 {
1019         switch (relop)  {
1020         case '<':
1021                 C_zlt(lbl);
1022                 break;
1023         case LESSEQUAL:
1024                 C_zle(lbl);
1025                 break;
1026         case '>':
1027                 C_zgt(lbl);
1028                 break;
1029         case GREATEREQUAL:
1030                 C_zge(lbl);
1031                 break;
1032         case '=':
1033                 C_zeq(lbl);
1034                 break;
1035         case '#':
1036                 C_zne(lbl);
1037                 break;
1038         default:
1039                 crash("(compare)");
1040         }
1041 }
1042
1043 /*      truthvalue() serves as an auxiliary function of CodeOper        */
1044 truthvalue(relop)
1045         int relop;
1046 {
1047         switch (relop)  {
1048         case '<':
1049                 C_tlt();
1050                 break;
1051         case LESSEQUAL:
1052                 C_tle();
1053                 break;
1054         case '>':
1055                 C_tgt();
1056                 break;
1057         case GREATEREQUAL:
1058                 C_tge();
1059                 break;
1060         case '=':
1061                 C_teq();
1062                 break;
1063         case '#':
1064                 C_tne();
1065                 break;
1066         default:
1067                 crash("(truthvalue)");
1068         }
1069 }
1070
1071 CodeUoper(nd)
1072         register t_node *nd;
1073 {
1074         register t_type *tp = nd->nd_type;
1075
1076         CodePExpr(nd->nd_RIGHT);
1077         switch(nd->nd_symb) {
1078         case NOT:
1079                 C_teq();
1080                 break;
1081         case '-':
1082                 switch(tp->tp_fund) {
1083                 case T_INTEGER:
1084                 case T_INTORCARD:
1085                         C_ngi(tp->tp_size);
1086                         break;
1087                 case T_REAL:
1088                         C_ngf(tp->tp_size);
1089                         break;
1090                 default:
1091                         crash("Bad operand to unary -");
1092                 }
1093                 break;
1094         case COERCION:
1095                 CodeCoercion(nd->nd_RIGHT->nd_type, tp);
1096                 RangeCheck(tp, nd->nd_RIGHT->nd_type);
1097                 break;
1098         case CAST:
1099                 break;
1100         default:
1101                 crash("Bad unary operator");
1102         }
1103 }
1104
1105 CodeSet(nd, null_set)
1106         register t_node *nd;
1107 {
1108         register t_type *tp = nd->nd_type;
1109
1110         nd = nd->nd_NEXT;
1111         while (nd) {
1112                 assert(nd->nd_class == Link && nd->nd_symb == ',');
1113
1114                 if (nd->nd_LEFT) {
1115                         CodeEl(nd->nd_LEFT, tp, null_set);
1116                         null_set = 0;
1117                 }
1118                 nd = nd->nd_RIGHT;
1119         }
1120         if (null_set) C_zer(tp->tp_size);
1121 }
1122
1123 CodeEl(nd, tp, null_set)
1124         register t_node *nd;
1125         register t_type *tp;
1126 {
1127         register t_type *eltype = ElementType(tp);
1128
1129         if (nd->nd_class == Link && nd->nd_symb == UPTO) {
1130                 if (null_set) C_zer(tp->tp_size);
1131                 C_loc(tp->set_low);
1132                 C_loc(tp->tp_size);     /* push size */
1133                 if (eltype->tp_fund == T_SUBRANGE) {
1134                         C_loc(eltype->sub_ub);
1135                 }
1136                 else    C_loc(eltype->enm_ncst - 1);
1137                 Operands(nd);
1138                 CAL("LtoUset", 5 * (int) word_size);
1139                 /* library routine to fill set */
1140         }
1141         else {
1142                 CodePExpr(nd);
1143                 C_loc(tp->set_low);
1144                 C_sbi(word_size);
1145                 C_set(tp->tp_size);
1146                 if (! null_set) C_ior(tp->tp_size);
1147         }
1148 }
1149
1150 CodePExpr(nd)
1151         register t_node *nd;
1152 {
1153         /*      Generate code to push the value of the expression "nd"
1154                 on the stack.
1155         */
1156         t_desig designator;
1157
1158         designator = null_desig;
1159         CodeExpr(nd, &designator, NO_LABEL, NO_LABEL);
1160         CodeValue(&designator, nd->nd_type);
1161 }
1162
1163 CodeDAddress(nd, chk_controlvar)
1164         t_node *nd;
1165 {
1166         /*      Generate code to push the address of the designator "nd"
1167                 on the stack.
1168         */
1169
1170         t_desig designator;
1171         int chkptr;
1172
1173         designator = null_desig;
1174         if (chk_controlvar) ChkForFOR(nd);
1175         CodeDesig(nd, &designator);
1176         chkptr = designator.dsg_kind==DSG_PLOADED ||
1177                  designator.dsg_kind==DSG_PFIXED;
1178         CodeAddress(&designator);
1179
1180         /*      Generate dummy use of pointer, to get possible error message
1181                 as soon as possible
1182         */
1183         if (chkptr && ! options['R']) {
1184                 C_dup(pointer_size);
1185                 C_loi((arith) 1);
1186                 C_asp(word_size);
1187         }
1188 }
1189
1190 CodeDStore(nd)
1191         register t_node *nd;
1192 {
1193         /*      Generate code to store the expression on the stack into the
1194                 designator "nd".
1195         */
1196
1197         t_desig designator;
1198
1199         designator = null_desig;
1200         ChkForFOR(nd);
1201         CodeDesig(nd, &designator);
1202         CodeStore(&designator, nd->nd_type);
1203 }
1204
1205 DoHIGH(df)
1206         register t_def *df;
1207 {
1208         /*      Get the high index of a conformant array, indicated by "nd".
1209                 The high index is the second field in the descriptor of
1210                 the array, so it is easily found.
1211         */
1212         register arith highoff;
1213
1214         assert(df->df_kind == D_VARIABLE);
1215         assert(IsConformantArray(df->df_type));
1216
1217         highoff = df->var_off           /* base address and descriptor */
1218                   + word_size + pointer_size;
1219                                         /* skip base and first field of
1220                                            descriptor
1221                                         */
1222         if (df->df_scope->sc_level < proclevel) {
1223                 C_lxa((arith) (proclevel - df->df_scope->sc_level));
1224                 C_lof(highoff);
1225         }
1226         else    C_lol(highoff);
1227 }
1228
1229 #ifdef SQUEEZE
1230 c_bra(l)
1231         label l;
1232 {
1233         C_bra((label) l);
1234 }
1235
1236 c_loc(n)
1237 {
1238         C_loc((arith) n);
1239 }
1240
1241 c_lae_dlb(l)
1242         label l;
1243 {
1244         C_lae_dlb(l, (arith) 0);
1245 }
1246
1247 CAL(name, ssp)
1248         char *name;
1249         int ssp;
1250 {
1251         C_cal(name);
1252         C_asp((arith) ssp);
1253 }
1254 #endif