lang/pc/comp/code.c

   1 /* C O D E   G E N E R A T I O N   R O U T I N E S */
   2
   3 #include        "debug.h"
   4 #include        <assert.h>
   5 #include        <em.h>
   6 #include        <em_reg.h>
   7 #include        <em_abs.h>
   8
   9 #include        "LLlex.h"
  10 #include        "Lpars.h"
  11 #include        "def.h"
  12 #include        "desig.h"
  13 #include        "f_info.h"
  14 #include        "idf.h"
  15 #include        "main.h"
  16 #include        "misc.h"
  17 #include        "node.h"
  18 #include        "required.h"
  19 #include        "scope.h"
  20 #include        "type.h"
  21
  22 int     fp_used;
  23
  24 CodeFil()
  25 {
  26         if ( !options['L'] )
  27                 C_fil_dlb((label) 1, (arith) 0);
  28 }
  29
  30 routine_label(df)
  31         register struct def * df;
  32 {
  33         df->prc_label = ++data_label;
  34         C_df_dlb(df->prc_label);
  35         C_rom_scon(df->df_idf->id_text, (arith)(strlen(df->df_idf->id_text) + 1));
  36 }
  37
  38 RomString(nd)
  39         register struct node *nd;
  40 {
  41         C_df_dlb(++data_label);
  42
  43         /* A string of the string_type is null-terminated. */
  44         if( nd->nd_type == string_type )
  45                 C_rom_scon(nd->nd_STR, nd->nd_SLE + 1); /* with trailing '\0' */
  46         else
  47                 C_rom_scon(nd->nd_STR, nd->nd_SLE);     /* no trailing '\0' */
  48
  49         nd->nd_SLA = data_label;
  50 }
  51
  52 RomReal(nd)
  53         register struct node *nd;
  54 {
  55         if (! nd->nd_RLA) {
  56                 C_df_dlb(++data_label);
  57                 nd->nd_RLA = data_label;
  58                 C_rom_fcon(nd->nd_REL, nd->nd_type->tp_size);
  59         }
  60 }
  61
  62 BssVar()
  63 {
  64         /* generate bss segments for global variables */
  65         register struct def *df = GlobalScope->sc_def;
  66
  67         while( df )     {
  68                 if( df->df_kind == D_VARIABLE ) {
  69                         C_df_dnam(df->var_name);
  70
  71                         /* ??? undefined value ??? */
  72                         C_bss_cst(df->df_type->tp_size, (arith) 0, 0);
  73                 }
  74                 df = df->df_nextinscope;
  75         }
  76 }
  77
  78 arith
  79 CodeGtoDescr(sc)
  80         register struct scope *sc;
  81 {
  82         /*      Create code for goto descriptors
  83         */
  84
  85         register struct node *lb = sc->sc_lablist;
  86         int first = 1;
  87
  88         while( lb )     {
  89                 if( lb->nd_def->lab_descr )     {
  90                         if( first )     {
  91                                 /* create local for target SP */
  92                                 sc->sc_off = -WA(pointer_size - sc->sc_off);
  93                                 C_ms_gto();
  94                                 first = 0;
  95                         }
  96                         C_df_dlb(lb->nd_def->lab_descr);
  97                         C_rom_ilb(lb->nd_def->lab_no);
  98                         C_rom_cst(sc->sc_off);
  99                 }
 100                 lb = lb->nd_next;
 101         }
 102         if( !first )
 103                 return sc->sc_off;
 104         else
 105                 return (arith) 0;
 106 }
 107
 108 arith
 109 CodeBeginBlock(df)
 110         register struct def *df;
 111 {
 112         /*      Generate code at the beginning of the main program,
 113                 procedure or function.
 114         */
 115
 116         arith StackAdjustment = 0;
 117         arith offset = 0;               /* offset to save StackPointer */
 118
 119         TmpOpen(df->prc_vis->sc_scope);
 120
 121         if ( df->df_kind == D_MODULE) /* nothing */ ;
 122         else if (df->df_kind == D_PROGRAM ) {
 123                 C_exp("_m_a_i_n");
 124                 C_pro_narg("_m_a_i_n");
 125                 C_ms_par((arith) 0);
 126                 offset = CodeGtoDescr(df->prc_vis->sc_scope);
 127                 CodeFil();
 128
 129                 /* initialize external files */
 130                 call_ini();
 131                 /* ignore floating point underflow */
 132                 C_lim();
 133                 C_loc((arith) (1 << EFUNFL));
 134                 C_ior(int_size);
 135                 C_sim();
 136         }
 137         else if (df->df_kind & (D_PROCEDURE | D_FUNCTION)) {
 138                 struct type *tp;
 139                 register struct paramlist *param;
 140
 141                 C_pro_narg(df->prc_name);
 142                 C_ms_par(df->df_type->prc_nbpar);
 143
 144                 offset = CodeGtoDescr(df->prc_vis->sc_scope);
 145                 CodeFil();
 146
 147                 if( options['t'] ) {
 148                         C_lae_dlb(df->prc_label,(arith)0);
 149                         C_cal("procentry");
 150                         C_asp(pointer_size);
 151                 }
 152
 153                 /* prc_bool is the local variable that indicates if the
 154                  * function result is assigned. This and can be disabled
 155                  * with the -R option. The variable, however, is always
 156                  * allocated and initialized.
 157                  */
 158                 if( df->prc_res ) {
 159                         C_zer((arith) int_size);
 160                         C_stl(df->prc_bool);
 161                 }
 162                 for( param = ParamList(df->df_type); param; param = param->next) {
 163                         if( !IsVarParam(param) )        {
 164                                 tp = TypeOfParam(param);
 165
 166                                 if( IsConformantArray(tp) )     {
 167                                         /* Here, we have to make a copy of the
 168                                            array. We must also remember how much
 169                                            room is reserved for copies, because
 170                                            we have to adjust the stack pointer
 171                                            before we return.
 172                                         */
 173
 174                                         if( !StackAdjustment )  {
 175                                                 /* First time we get here
 176                                                 */
 177                                                 StackAdjustment = NewInt(0);
 178                                                 C_loc((arith) 0);
 179                                                 C_stl(StackAdjustment);
 180                                         }
 181                                         /* Address of array */
 182                                         C_lol(param->par_def->var_off);
 183
 184                                         /* First compute size of the array */
 185                                         C_lol(tp->arr_cfdescr + word_size);
 186                                         C_inc();
 187                                                 /* gives number of elements */
 188                                         C_lol(tp->arr_cfdescr + 2 * word_size);
 189                                                         /* size of elements */
 190                                         C_mli(word_size);
 191                                         C_loc(word_size - 1);
 192                                         C_adi(word_size);
 193                                         C_loc(word_size - 1);
 194                                         C_com(word_size);
 195                                         C_and(word_size);
 196                                         C_dup(word_size);
 197                                         C_lol(StackAdjustment);
 198                                         C_adi(word_size);
 199                                         C_stl(StackAdjustment);
 200                                                 /* remember stack adjustments */
 201
 202                                         C_los(word_size);       /* copy */
 203                                         C_lor((arith) 1);
 204                                                 /* push new address of array
 205                                                    ... downwards ... ???
 206                                                 */
 207                                         C_stl(param->par_def->var_off);
 208                                 }
 209                         }
 210                 }
 211         }
 212         else {
 213                 crash("(CodeBeginBlock)");
 214                 /*NOTREACHED*/
 215         }
 216
 217         if( offset )    {
 218                 /* save SP for non-local jump */
 219                 C_lor((arith) 1);
 220                 C_stl(offset);
 221         }
 222         return StackAdjustment;
 223 }
 224
 225 CodeEndBlock(df, StackAdjustment)
 226         register struct def *df;
 227         arith StackAdjustment;
 228 {
 229         if( df->df_kind == D_PROGRAM) {
 230                 C_loc((arith) 0);
 231                 C_cal("_hlt");
 232         }
 233         else if (df->df_kind & (D_PROCEDURE | D_FUNCTION)) {
 234                 struct type *tp;
 235
 236                 if( StackAdjustment )   {
 237                         /* remove copies of conformant arrays */
 238                         C_lol(StackAdjustment);
 239                         C_ass(word_size);
 240                         FreeInt(StackAdjustment);
 241                 }
 242                 if( !options['n'] )
 243                         RegisterMessages(df->prc_vis->sc_scope->sc_def);
 244
 245                 if( options['t'] ) {
 246                         C_lae_dlb(df->prc_label,(arith)0);
 247                         C_cal("procexit");
 248                         C_asp(pointer_size);
 249                 }
 250                 if( tp = ResultType(df->df_type) )      {
 251                         if( !options['R'] ) {
 252                                 C_lin((arith)LineNumber);
 253                                 C_lol(df->prc_bool);
 254                                 C_cal("_nfa");
 255                                 C_asp(word_size);
 256                         }
 257                         if( tp->tp_size == word_size )
 258                                 C_lol(-tp->tp_size);
 259                         else if( tp->tp_size == 2 * word_size )
 260                                 C_ldl(-tp->tp_size);
 261                         else {
 262                                 C_lal(-tp->tp_size);
 263                                 C_loi(tp->tp_size);
 264                         }
 265
 266                         C_ret(tp->tp_size);
 267                 }
 268                 else
 269                         C_ret((arith) 0);
 270         }
 271         else {
 272                 crash("(CodeEndBlock)");
 273                 /*NOTREACHED*/
 274         }
 275
 276         C_end(- df->prc_vis->sc_scope->sc_off);
 277         TmpClose();
 278 }
 279
 280 CodeExpr(nd, ds, true_label)
 281         register struct node *nd;
 282         register struct desig *ds;
 283         label true_label;
 284 {
 285         register struct type *tp = nd->nd_type;
 286
 287         if( tp->tp_fund == T_REAL ) fp_used = 1;
 288
 289         switch( nd->nd_class )  {
 290         case Value:
 291                 switch( nd->nd_symb )   {
 292                 case INTEGER:
 293                         C_loc(nd->nd_INT);
 294                         break;
 295                 case REAL:
 296                         RomReal(nd);
 297                         C_lae_dlb(nd->nd_RLA, (arith) 0);
 298                         C_loi(tp->tp_size);
 299                         break;
 300                 case STRING:
 301                         if( tp->tp_fund == T_CHAR )
 302                                 C_loc(nd->nd_INT);
 303                         else
 304                                 C_lae_dlb(nd->nd_SLA, (arith) 0);
 305                         break;
 306                 case NIL:
 307                         C_zer(pointer_size);
 308                         break;
 309                 default:
 310                         crash("(CodeExpr Value)");
 311                         /*NOTREACHED*/
 312                 }
 313                 ds->dsg_kind = DSG_LOADED;
 314                 break;
 315
 316         case Uoper:
 317                 CodeUoper(nd);
 318                 ds->dsg_kind = DSG_LOADED;
 319                 break;
 320
 321         case Boper:
 322                 CodeBoper(nd, true_label);
 323                 ds->dsg_kind = DSG_LOADED;
 324                 true_label = NO_LABEL;
 325                 break;
 326
 327         case Set:       {
 328                 register arith *st = nd->nd_set;
 329                 register int i;
 330
 331                 ds->dsg_kind = DSG_LOADED;
 332                 if( !st )       {
 333                         C_zer(tp->tp_size);
 334                         break;
 335                 }
 336                 for( i = tp->tp_size / word_size, st += i; i > 0; i--)
 337                         C_loc(*--st);
 338
 339                 }
 340                 break;
 341
 342         case Xset:
 343                 CodeSet(nd);
 344                 ds->dsg_kind = DSG_LOADED;
 345                 break;
 346
 347         case Call:
 348                 CodeCall(nd);
 349                 ds->dsg_kind = DSG_LOADED;
 350                 break;
 351
 352         case NameOrCall:        {
 353                 /* actual procedure/function parameter */
 354                 struct node *left = nd->nd_left;
 355                 struct def *df = left->nd_def;
 356
 357                 if( df->df_kind & D_ROUTINE )   {
 358                         int level = df->df_scope->sc_level;
 359
 360                         if( level <= 0 || (df->df_flags & D_EXTERNAL) )
 361                                 C_zer(pointer_size);
 362                         else
 363                                 C_lxl((arith) (proclevel - level));
 364
 365                         C_lpi(df->prc_name);
 366                         ds->dsg_kind = DSG_LOADED;
 367                         break;
 368                 }
 369                 assert(df->df_kind == D_VARIABLE);
 370                 assert(df->df_type->tp_fund & T_ROUTINE);
 371
 372                 CodeDesig(left, ds);
 373                 break;
 374         }
 375
 376         case Arrow:
 377         case Arrsel:
 378         case Def:
 379         case LinkDef:
 380                 CodeDesig(nd, ds);
 381                 break;
 382
 383         case Cast:      {
 384                 /* convert integer to real */
 385                 struct node *right = nd->nd_right;
 386
 387                 CodePExpr(right);
 388                 Int2Real(right->nd_type->tp_size);
 389                 ds->dsg_kind = DSG_LOADED;
 390                 break;
 391         }
 392         case IntCoerc:  {
 393                 /* convert integer to long integer */
 394                 struct node *right = nd->nd_right;
 395
 396                 CodePExpr(right);
 397                 Int2Long();
 398                 ds->dsg_kind = DSG_LOADED;
 399                 break;
 400         }
 401         case IntReduc:  {
 402                 /* convert a long to an integer */
 403                 struct node *right = nd->nd_right;
 404
 405                 CodePExpr(right);
 406                 Long2Int();
 407                 ds->dsg_kind = DSG_LOADED;
 408                 break;
 409         }
 410         default:
 411                 crash("(CodeExpr : bad node type)");
 412                 /*NOTREACHED*/
 413         } /* switch class */
 414
 415         if( true_label )        {
 416                 /* Only for boolean expressions
 417                 */
 418                 CodeValue(ds, tp);
 419                 C_zeq(true_label);
 420         }
 421 }
 422
 423 CodeUoper(nd)
 424         register struct node *nd;
 425 {
 426         register struct type *tp = nd->nd_type;
 427
 428         CodePExpr(nd->nd_right);
 429
 430         switch( nd->nd_symb )   {
 431                 case '-':
 432                         assert(tp->tp_fund & T_NUMERIC);
 433                         if( tp->tp_fund == T_INTEGER || tp->tp_fund == T_LONG )
 434                                 C_ngi(tp->tp_size);
 435                         else
 436                                 C_ngf(tp->tp_size);
 437                         break;
 438
 439                 case NOT:
 440                         C_teq();
 441                         break;
 442
 443                 case '(':
 444                         break;
 445
 446                 default:
 447                         crash("(CodeUoper)");
 448                         /*NOTREACHED*/
 449         }
 450 }
 451
 452 Operands(leftop, rightop)
 453         register struct node *leftop, *rightop;
 454 {
 455         CodePExpr(leftop);
 456         CodePExpr(rightop);
 457 }
 458
 459 CodeBoper(expr, true_label)
 460         register struct node *expr;     /* the expression tree itself   */
 461         label true_label;               /* label to jump to in logical exprs */
 462 {
 463         register struct node *leftop = expr->nd_left;
 464         register struct node *rightop = expr->nd_right;
 465         register struct type *tp = expr->nd_type;
 466
 467         switch( expr->nd_symb ) {
 468                 case '+':
 469                         Operands(leftop, rightop);
 470                         switch( tp->tp_fund )   {
 471                                 case T_INTEGER:
 472                                 case T_LONG:
 473                                         C_adi(tp->tp_size);
 474                                         break;
 475                                 case T_REAL:
 476                                         C_adf(tp->tp_size);
 477                                         break;
 478                                 case T_SET:
 479                                         C_ior(tp->tp_size);
 480                                         break;
 481                                 default:
 482                                         crash("(CodeBoper: bad type +)");
 483                         }
 484                         break;
 485
 486                 case '-':
 487                         Operands(leftop, rightop);
 488                         switch( tp->tp_fund )   {
 489                                 case T_INTEGER:
 490                                 case T_LONG:
 491                                         C_sbi(tp->tp_size);
 492                                         break;
 493                                 case T_REAL:
 494                                         C_sbf(tp->tp_size);
 495                                         break;
 496                                 case T_SET:
 497                                         C_com(tp->tp_size);
 498                                         C_and(tp->tp_size);
 499                                         break;
 500                                 default:
 501                                         crash("(CodeBoper: bad type -)");
 502                         }
 503                         break;
 504
 505                 case '*':
 506                         Operands(leftop, rightop);
 507                         switch( tp->tp_fund )   {
 508                                 case T_INTEGER:
 509                                 case T_LONG:
 510                                         C_mli(tp->tp_size);
 511                                         break;
 512                                 case T_REAL:
 513                                         C_mlf(tp->tp_size);
 514                                         break;
 515                                 case T_SET:
 516                                         C_and(tp->tp_size);
 517                                         break;
 518                                 default:
 519                                         crash("(CodeBoper: bad type *)");
 520                         }
 521                         break;
 522
 523                 case '/':
 524                         Operands(leftop, rightop);
 525                         if( tp->tp_fund == T_REAL )
 526                                 C_dvf(tp->tp_size);
 527                         else
 528                                 crash("(CodeBoper: bad type /)");
 529                         break;
 530
 531                 case DIV:
 532                 case MOD:
 533                         Operands(leftop, rightop);
 534                         if( tp->tp_fund == T_INTEGER ) {
 535                                 C_cal(expr->nd_symb == MOD ? "_mdi" : "_dvi");
 536                                 C_asp(2 * tp->tp_size);
 537                                 C_lfr(tp->tp_size);
 538                         }
 539                         else if( tp->tp_fund == T_LONG) {
 540                                 C_cal(expr->nd_symb == MOD ? "_mdil" : "_dvil");
 541                                 C_asp(2 * tp->tp_size);
 542                                 C_lfr(tp->tp_size);
 543                         }
 544                         else
 545                                 crash("(CodeBoper: bad type MOD)");
 546                         break;
 547
 548                 case '<':
 549                 case LESSEQUAL:
 550                 case '>':
 551                 case GREATEREQUAL:
 552                 case '=':
 553                 case NOTEQUAL:
 554                         CodePExpr(leftop);
 555                         CodePExpr(rightop);
 556                         tp = BaseType(rightop->nd_type);
 557
 558                         switch( tp->tp_fund )   {
 559                                 case T_INTEGER:
 560                                 case T_LONG:
 561                                         C_cmi(tp->tp_size);
 562                                         break;
 563                                 case T_REAL:
 564                                         C_cmf(tp->tp_size);
 565                                         break;
 566                                 case T_ENUMERATION:
 567                                 case T_CHAR:
 568                                         C_cmu(word_size);
 569                                         break;
 570                                 case T_POINTER:
 571                                         C_cmp();
 572                                         break;
 573
 574                                 case T_SET:
 575                                         if( expr->nd_symb == GREATEREQUAL ) {
 576                                         /* A >= B is the same as A equals A + B
 577                                         */
 578                                                 C_dup(2 * tp->tp_size);
 579                                                 C_asp(tp->tp_size);
 580                                                 C_ior(tp->tp_size);
 581                                                 expr->nd_symb = '=';
 582                                         }
 583                                         else if( expr->nd_symb == LESSEQUAL ) {
 584                                         /* A <= B is the same as A - B = []
 585                                         */
 586                                                 C_com(tp->tp_size);
 587                                                 C_and(tp->tp_size);
 588                                                 C_zer(tp->tp_size);
 589                                                 expr->nd_symb = '=';
 590                                         }
 591                                         C_cms(tp->tp_size);
 592                                         break;
 593
 594                                 case T_STRINGCONST:
 595                                 case T_ARRAY:
 596                                         C_loc((arith) IsString(tp));
 597                                         C_cal("_bcp");
 598                                         C_asp(2 * pointer_size + word_size);
 599                                         C_lfr(word_size);
 600                                         break;
 601
 602                                 case T_STRING:
 603                                         C_cmp();
 604                                         break;
 605
 606                                 default:
 607                                         crash("(CodeBoper : bad type COMPARE)");
 608                         }
 609                         truthvalue(expr->nd_symb);
 610                         if( true_label != NO_LABEL )
 611                                 C_zeq(true_label);
 612                         break;
 613
 614                 case IN:
 615                 /* In this case, evaluate right hand side first! The INN
 616                    instruction expects the bit number on top of the stack
 617                 */
 618                         CodePExpr(rightop);
 619                         CodePExpr(leftop);
 620                         if( rightop->nd_type == emptyset_type )
 621                                 C_and(rightop->nd_type->tp_size);
 622                         else
 623                                 C_inn(rightop->nd_type->tp_size);
 624
 625                         if( true_label != NO_LABEL )
 626                                 C_zeq(true_label);
 627                         break;
 628
 629                 case AND:
 630                 case OR:
 631                         Operands(leftop, rightop);
 632                         if( expr->nd_symb == AND )
 633                                 C_and(tp->tp_size);
 634                         else
 635                                 C_ior(tp->tp_size);
 636                         if( true_label != NO_LABEL )
 637                                 C_zeq(true_label);
 638                         break;
 639                 default:
 640                         crash("(CodeBoper Bad operator %s\n)",
 641                                                 symbol2str(expr->nd_symb));
 642         }
 643 }
 644
 645 /*      truthvalue() serves as an auxiliary function of CodeBoper       */
 646 truthvalue(relop)
 647 {
 648         switch( relop ) {
 649                 case '<':
 650                         C_tlt();
 651                         break;
 652                 case LESSEQUAL:
 653                         C_tle();
 654                         break;
 655                 case '>':
 656                         C_tgt();
 657                         break;
 658                 case GREATEREQUAL:
 659                         C_tge();
 660                         break;
 661                 case '=':
 662                         C_teq();
 663                         break;
 664                 case NOTEQUAL:
 665                         C_tne();
 666                         break;
 667                 default:
 668                         crash("(truthvalue)");
 669                         /*NOTREACHED*/
 670         }
 671 }
 672
 673 CodeSet(nd)
 674         register struct node *nd;
 675 {
 676         register struct type *tp = nd->nd_type;
 677
 678         C_zer(tp->tp_size);
 679         nd = nd->nd_right;
 680         while( nd )     {
 681                 assert(nd->nd_class == Link && nd->nd_symb == ',');
 682
 683                 CodeEl(nd->nd_left, tp);
 684                 nd = nd->nd_right;
 685         }
 686 }
 687
 688 CodeEl(nd, tp)
 689         register struct node *nd;
 690         register struct type *tp;
 691 {
 692         if( nd->nd_class == Link && nd->nd_symb == UPTO )       {
 693                 Operands(nd->nd_left, nd->nd_right);
 694                 C_loc(tp->tp_size);     /* push size */
 695                 C_cal("_bts");          /* library routine to fill set */
 696                 C_asp(3 * word_size);
 697         }
 698         else    {
 699                 CodePExpr(nd);
 700                 C_set(tp->tp_size);
 701                 C_ior(tp->tp_size);
 702         }
 703 }
 704
 705 struct type *
 706 CodeParameters(param, arg)
 707         struct paramlist *param;
 708         struct node *arg;
 709 {
 710         register struct type *tp, *left_tp, *last_tp = (struct type *) 0;
 711         struct node *left;
 712         struct desig ds;
 713
 714         assert(param && arg);
 715
 716         if( param->next )
 717                 last_tp = CodeParameters(param->next, arg->nd_right);
 718
 719         tp = TypeOfParam(param);
 720         left = arg->nd_left;
 721         left_tp = left->nd_type;
 722
 723         if( IsConformantArray(tp) )     {
 724                 if( last_tp != tp )
 725                         /* push descriptors only once */
 726                         CodeConfDescr(tp, left_tp);
 727
 728                 CodeDAddress(left);
 729                 return tp;
 730         }
 731         if( IsVarParam(param) ) {
 732                 CodeDAddress(left);
 733                 return tp;
 734         }
 735         if( left_tp->tp_fund == T_STRINGCONST ) {
 736                 CodePString(left, tp);
 737                 return tp;
 738         }
 739
 740         ds = InitDesig;
 741         CodeExpr(left, &ds, NO_LABEL);
 742         CodeValue(&ds, left_tp);
 743
 744         RangeCheck(tp, left_tp);
 745         if( tp == real_type && BaseType(left_tp) == int_type )
 746                 Int2Real(int_size);
 747
 748         return tp;
 749 }
 750
 751 CodeConfDescr(ftp, atp)
 752         register struct type *ftp, *atp;
 753 {
 754         struct type *elemtp = ftp->arr_elem;
 755
 756         if( IsConformantArray(elemtp) )
 757                 CodeConfDescr(elemtp, atp->arr_elem);
 758
 759         if( atp->tp_fund == T_STRINGCONST )     {
 760                 C_loc((arith) 1);
 761                 C_loc(atp->tp_psize - 1);
 762                 C_loc((arith) 1);
 763         }
 764         else if( IsConformantArray(atp) )       {
 765                 if( atp->arr_sclevel < proclevel )      {
 766                         C_lxa((arith) proclevel - atp->arr_sclevel);
 767                         C_adp(atp->arr_cfdescr);
 768                 }
 769                 else
 770                         C_lal(atp->arr_cfdescr);
 771
 772                 C_loi(3 * word_size);
 773         }
 774         else    {               /* normal array */
 775                 assert(atp->tp_fund == T_ARRAY);
 776                 assert(!IsConformantArray(atp));
 777                 C_lae_dlb(atp->arr_ardescr, (arith) 0);
 778                 C_loi( 3 * word_size);
 779         }
 780 }
 781
 782 CodePString(nd, tp)
 783         struct node *nd;
 784         struct type *tp;
 785 {
 786         /* no null padding */
 787         C_lae_dlb(nd->nd_SLA, (arith) 0);
 788         C_loi(tp->tp_size);
 789 }
 790
 791 CodeCall(nd)
 792         register struct node *nd;
 793 {
 794         /*      Generate code for a procedure call. Checking of parameters
 795                 and result is already done.
 796         */
 797         register struct node *left = nd->nd_left;
 798         register struct node *right = nd->nd_right;
 799         register struct def *df = left->nd_def;
 800         register struct type *result_tp;
 801
 802         assert(IsProcCall(left));
 803
 804         if( left->nd_type == std_type ) {
 805                 CodeStd(nd);
 806                 return;
 807         }
 808
 809         if( right )
 810                 (void) CodeParameters(ParamList(left->nd_type), right);
 811
 812         assert(left->nd_class == Def);
 813
 814
 815         if( df->df_kind & D_ROUTINE )   {
 816                 int level = df->df_scope->sc_level;
 817
 818                 if( level > 0 && !(df->df_flags & D_EXTERNAL) )
 819                         C_lxl((arith) (proclevel - level));
 820                 C_cal(df->prc_name);
 821                 C_asp(left->nd_type->prc_nbpar);
 822         }
 823         else    {
 824                 label l1 = ++text_label;
 825                 label l2 = ++text_label;
 826
 827                 assert(df->df_kind == D_VARIABLE);
 828
 829                 /* Push value of procedure/function parameter */
 830                 CodePExpr(left);
 831
 832                 /* Test if value is a global or local procedure/function */
 833                 C_exg(pointer_size);
 834                 C_dup(pointer_size);
 835                 C_zer(pointer_size);
 836                 C_cmp();
 837
 838                 C_zeq(l1);
 839                                 /* At this point, on top of the stack the LB */
 840                 C_exg(pointer_size);
 841                                 /* Now, the name of the procedure/function */
 842                 C_cai();
 843                 C_asp(pointer_size + left->nd_type->prc_nbpar);
 844                 C_bra(l2);
 845
 846                 /* value is a global procedure/function */
 847                 C_df_ilb(l1);
 848                 C_asp(pointer_size);    /* no LB needed */
 849                 C_cai();
 850                 C_asp(left->nd_type->prc_nbpar);
 851                 C_df_ilb(l2);
 852         }
 853
 854         if( result_tp = ResultType(left->nd_type) )
 855                 C_lfr(result_tp->tp_size);
 856 }
 857
 858 CodeStd(nd)
 859         struct node *nd;
 860 {
 861         register struct node *arg = nd->nd_right;
 862         register struct node *left = arg->nd_left;
 863         register struct type *tp = BaseType(left->nd_type);
 864         int req = nd->nd_left->nd_def->df_value.df_reqname;
 865
 866         assert(arg->nd_class == Link && arg->nd_symb == ',');
 867
 868         switch( req )   {
 869                 case R_ABS:
 870                         CodePExpr(left);
 871                         if( tp == int_type )
 872                                 C_cal("_abi");
 873                         else if ( tp == long_type )
 874                                 C_cal("_abl");
 875                         else
 876                                 C_cal("_abr");
 877                         C_asp(tp->tp_size);
 878                         C_lfr(tp->tp_size);
 879                         break;
 880
 881                 case R_SQR:
 882                         CodePExpr(left);
 883                         C_dup(tp->tp_size);
 884                         if( tp == int_type || tp == long_type )
 885                                 C_mli(tp->tp_size);
 886                         else
 887                                 C_mlf(real_size);
 888                         break;
 889
 890                 case R_SIN:
 891                 case R_COS:
 892                 case R_EXP:
 893                 case R_LN:
 894                 case R_SQRT:
 895                 case R_ARCTAN:
 896                         assert(tp == real_type);
 897                         CodePExpr(left);
 898                         switch( req )   {
 899                                 case R_SIN:
 900                                         C_cal("_sin");
 901                                         break;
 902                                 case R_COS:
 903                                         C_cal("_cos");
 904                                         break;
 905                                 case R_EXP:
 906                                         C_cal("_exp");
 907                                         break;
 908                                 case R_LN:
 909                                         C_cal("_log");
 910                                         break;
 911                                 case R_SQRT:
 912                                         C_cal("_sqt");
 913                                         break;
 914                                 case R_ARCTAN:
 915                                         C_cal("_atn");
 916                                         break;
 917                                 default:
 918                                         crash("(CodeStd)");
 919                                         /*NOTREACHED*/
 920                         }
 921                         C_asp(real_size);
 922                         C_lfr(real_size);
 923                         break;
 924
 925                 case R_TRUNC:
 926                         assert(tp == real_type);
 927                         CodePExpr(left);
 928                         Real2Int();
 929                         break;
 930
 931                 case R_ROUND:
 932                         assert(tp == real_type);
 933                         CodePExpr(left);
 934                         C_cal("_rnd");
 935                         C_asp(real_size);
 936                         C_lfr(real_size);
 937                         Real2Int();
 938                         break;
 939
 940                 case R_ORD:
 941                         CodePExpr(left);
 942                         break;
 943
 944                 case R_CHR:
 945                         CodePExpr(left);
 946                         genrck(char_type);
 947                         break;
 948
 949                 case R_SUCC:
 950                 case R_PRED:
 951                         CodePExpr(left);
 952                         C_loc((arith)1);
 953                         if( tp == long_type) Int2Long();
 954
 955                         if( req == R_SUCC )
 956                                 C_adi(tp->tp_size);
 957                         else
 958                                 C_sbi(tp->tp_size);
 959
 960                         if( bounded(left->nd_type) )
 961                                 genrck(left->nd_type);
 962                         break;
 963
 964                 case R_ODD:
 965                         CodePExpr(left);
 966                         C_loc((arith) 1);
 967                         if(  tp == long_type ) Int2Long();
 968                         C_and(tp->tp_size);
 969                         if( tp == long_type ) Long2Int(); /* bool_size == int_size */
 970                         break;
 971
 972                 case R_EOF:
 973                 case R_EOLN:
 974                         CodeDAddress(left);
 975                         if( req == R_EOF )
 976                                 C_cal("_efl");
 977                         else
 978                                 C_cal("_eln");
 979                         C_asp(pointer_size);
 980                         C_lfr(word_size);
 981                         break;
 982
 983                 case R_REWRITE:
 984                 case R_RESET:
 985                         CodeDAddress(left);
 986                         if( tp == text_type )
 987                                 C_loc((arith) 0);
 988                         else
 989                                 C_loc(tp->next->tp_psize);
 990                                         /* ??? elements of packed size ??? */
 991                         if( req == R_REWRITE )
 992                                 C_cal("_cre");
 993                         else
 994                                 C_cal("_opn");
 995                         C_asp(pointer_size + word_size);
 996                         break;
 997
 998                 case R_PUT:
 999                 case R_GET:
1000                         CodeDAddress(left);
1001                         if( req == R_PUT )
1002                                 C_cal("_put");
1003                         else
1004                                 C_cal("_get");
1005                         C_asp(pointer_size);
1006                         break;
1007
1008                 case R_PAGE:
1009                         CodeDAddress(left);
1010                         C_cal("_pag");
1011                         C_asp(pointer_size);
1012                         break;
1013
1014                 case R_PACK:    {
1015                         label lba = tp->arr_ardescr;
1016
1017
1018                         CodeDAddress(left);
1019                         arg = arg->nd_right;
1020                         left = arg->nd_left;
1021                         CodePExpr(left);
1022                         arg = arg->nd_right;
1023                         left = arg->nd_left;
1024                         CodeDAddress(left);
1025                         C_lae_dlb(left->nd_type->arr_ardescr, (arith) 0);
1026                         C_lae_dlb(lba, (arith) 0);
1027                         C_cal("_pac");
1028                         C_asp(4 * pointer_size + word_size);
1029                         break;
1030                 }
1031
1032                 case R_UNPACK:  {
1033                         /* change sequence of arguments of the library routine
1034                            _unp to merge code of R_PACK and R_UNPACK.
1035                         */
1036                         label lba, lbz = tp->arr_ardescr;
1037
1038                         tp = tp->arr_elem;
1039                         if (tp->tp_fund == T_SUBRANGE &&
1040                             tp->sub_lb >= 0) {
1041                                 C_loc((arith) 1);
1042                         }
1043                         else    C_loc((arith) 0);
1044                         CodeDAddress(left);
1045                         arg = arg->nd_right;
1046                         left = arg->nd_left;
1047                         CodeDAddress(left);
1048                         lba = left->nd_type->arr_ardescr;
1049                         arg = arg->nd_right;
1050                         left = arg->nd_left;
1051                         CodePExpr(left);
1052                         C_lae_dlb(lbz, (arith) 0);
1053                         C_lae_dlb(lba, (arith) 0);
1054                         C_cal("_unp");
1055                         C_asp(4 * pointer_size + 2 * word_size);
1056                         break;
1057                 }
1058
1059                 case R_NEW:
1060                 case R_DISPOSE:
1061                         CodeDAddress(left);
1062                         C_loc(PointedtoType(tp)->tp_size);
1063                         if( req == R_NEW )
1064                                 C_cal("_new");
1065                         else
1066                                 C_cal("_dis");
1067                         C_asp(pointer_size + word_size);
1068                         break;
1069
1070                 case R_MARK:
1071                 case R_RELEASE:
1072                         CodeDAddress(left);
1073                         if( req == R_MARK )
1074                                 C_cal("_sav");
1075                         else
1076                                 C_cal("_rst");
1077                         C_asp(pointer_size);
1078                         break;
1079
1080                 case R_HALT:
1081                         if( left )
1082                                 CodePExpr(left);
1083                         else
1084                                 C_zer(int_size);
1085                         C_cal("_hlt");                  /* can't return */
1086                         C_asp(int_size);        /* help the optimizer(s) */
1087                         break;
1088
1089                 default:
1090                         crash("(CodeStd)");
1091                         /*NOTREACHED*/
1092         }
1093 }
1094
1095 Long2Int()
1096 {
1097         /* convert a long to integer */
1098
1099         if (int_size == long_size) return;
1100
1101         C_loc(long_size);
1102         C_loc(int_size);
1103         C_cii();
1104 }
1105
1106 Int2Long()
1107 {
1108         /* convert integer to long */
1109
1110         if (int_size == long_size) return;
1111         C_loc(int_size);
1112         C_loc(long_size);
1113         C_cii();
1114 }
1115
1116 Int2Real(size)          /* size is different for integers and longs */
1117 arith size;
1118 {
1119         /* convert integer to real */
1120         C_loc(size);
1121         C_loc(real_size);
1122         C_cif();
1123 }
1124
1125 Real2Int()
1126 {
1127         /* convert real to integer */
1128         C_loc(real_size);
1129         C_loc(int_size);
1130         C_cfi();
1131 }
1132
1133 RangeCheck(tpl, tpr)
1134         register struct type *tpl, *tpr;
1135 {
1136         /*      Generate a range check if neccessary
1137         */
1138
1139         arith llo, lhi, rlo, rhi;
1140
1141         if( bounded(tpl) )      {
1142                 /* in this case we might need a range check */
1143                 if( !bounded(tpr) )
1144                         /* yes, we need one */
1145                         genrck(tpl);
1146                 else    {
1147                         /* both types are restricted. check the bounds to see
1148                            whether we need a range check.  We don't need one
1149                            if the range of values of the right hand side is a
1150                            subset of the range of values of the left hand side.
1151                         */
1152                         getbounds(tpl, &llo, &lhi);
1153                         getbounds(tpr, &rlo, &rhi);
1154                         if( llo > rlo || lhi < rhi )
1155                                 genrck(tpl);
1156                 }
1157         }
1158 }
1159
1160 genrck(tp)
1161         register struct type *tp;
1162 {
1163         /*      Generate a range check descriptor for type "tp" when
1164                 necessary. Return its label.
1165         */
1166
1167         arith lb, ub;
1168         register label o1;
1169         int newlabel = 0;
1170
1171         if( options['R'] ) return;
1172
1173         getbounds(tp, &lb, &ub);
1174
1175         if( tp->tp_fund == T_SUBRANGE ) {
1176                 if( !(o1 = tp->sub_rck) )       {
1177                         tp->sub_rck = o1 = ++data_label;
1178                         newlabel = 1;
1179                 }
1180         }
1181         else if( !(o1 = tp->enm_rck) )  {
1182                 tp->enm_rck = o1 = ++data_label;
1183                 newlabel = 1;
1184         }
1185         if( newlabel )  {
1186                 C_df_dlb(o1);
1187                 C_rom_cst(lb);
1188                 C_rom_cst(ub);
1189         }
1190         C_lae_dlb(o1, (arith) 0);
1191         C_rck(word_size);
1192 }
1193
1194 CodePExpr(nd)
1195         register struct node *nd;
1196 {
1197         /*      Generate code to push the value of the expression "nd"
1198                 on the stack.
1199         */
1200
1201         struct desig designator;
1202         struct type *tp = BaseType(nd->nd_type);
1203
1204         designator = InitDesig;
1205         CodeExpr(nd, &designator, NO_LABEL);
1206         if( tp->tp_fund & (T_ARRAY | T_RECORD) )
1207                 CodeAddress(&designator);
1208         else
1209                 CodeValue(&designator, nd->nd_type);
1210 }
1211
1212 CodeDAddress(nd)
1213         struct node *nd;
1214 {
1215         /*      Generate code to push the address of the designator "nd"
1216                 on the stack.
1217         */
1218
1219         struct desig designator;
1220
1221         designator = InitDesig;
1222         CodeDesig(nd, &designator);
1223         CodeAddress(&designator);
1224 }
1225
1226 CodeDStore(nd)
1227         register struct node *nd;
1228 {
1229         /*      Generate code to store the expression on the stack
1230                 into the designator "nd".
1231         */
1232
1233         struct desig designator;
1234
1235         designator = InitDesig;
1236         CodeDesig(nd, &designator);
1237         CodeStore(&designator, nd->nd_type);
1238 }
1239
1240 RegisterMessages(df)
1241         register struct def *df;
1242 {
1243         register struct type *tp;
1244
1245         for( ; df; df = df->df_nextinscope )    {
1246                 if( df->df_kind == D_VARIABLE && !(df->df_flags & D_NOREG) ) {
1247                         /* Examine type and size
1248                         */
1249                         tp = BaseType(df->df_type);
1250                         if( df->df_flags & D_VARPAR || tp->tp_fund & T_POINTER )
1251                                 C_ms_reg(df->var_off, pointer_size,
1252                                          reg_pointer, 0);
1253
1254                         else if( df->df_flags & D_LOOPVAR )
1255                                 C_ms_reg(df->var_off, tp->tp_size, reg_loop,2);
1256                         else if( tp->tp_fund & T_NUMERIC )
1257                                 C_ms_reg(df->var_off, tp->tp_size,
1258                                 tp->tp_fund == T_REAL ? reg_float : reg_any, 0);
1259                 }
1260         }
1261 }