lang/m2/comp/walk.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 /* P A R S E   T R E E   W A L K E R */
   9
  10 /* $Id: walk.c,v 1.104 1996/06/06 07:47:00 ceriel Exp $ */
  11
  12 /*      Routines to walk through parts of the parse tree, and generate
  13         code for these parts.
  14 */
  15
  16 #include        "debug.h"
  17
  18 #include        <em_arith.h>
  19 #include        <em_label.h>
  20 #include        <em_reg.h>
  21 #include        <em_code.h>
  22 #include        <m2_traps.h>
  23 #include        <assert.h>
  24 #include        <alloc.h>
  25 #include        <stb.h>
  26
  27 #include        "strict3rd.h"
  28 #include        "dbsymtab.h"
  29 #include        "LLlex.h"
  30 #include        "def.h"
  31 #include        "type.h"
  32 #include        "scope.h"
  33 #include        "main.h"
  34 #include        "node.h"
  35 #include        "Lpars.h"
  36 #include        "desig.h"
  37 #include        "f_info.h"
  38 #include        "idf.h"
  39 #include        "chk_expr.h"
  40 #include        "walk.h"
  41 #include        "misc.h"
  42 #include        "warning.h"
  43 #include        "bigresult.h"
  44 #include        "use_insert.h"
  45
  46 extern arith            NewPtr();
  47 extern arith            NewInt();
  48 extern arith            TmpSpace();
  49
  50 extern int              proclevel;
  51 extern int              gdb_flag;
  52
  53 label                   text_label;
  54 label                   data_label = 1;
  55 struct withdesig        *WithDesigs;
  56 t_node                  *Modules;
  57
  58 static t_type           *func_type;
  59 static t_node           *priority;
  60 static int              oldlineno;
  61
  62 static int              RegisterMessage();
  63 static int              WalkDef();
  64 #ifdef DBSYMTAB
  65 static int              stabdef();
  66 #endif
  67 static int              MkCalls();
  68 static int              UseWarnings();
  69
  70 #define NO_EXIT_LABEL   ((label) 0)
  71 #define RETURN_LABEL    ((label) 1)
  72
  73 #define REACH_FLAG      1
  74 #define EXIT_FLAG       2
  75
  76 int
  77 LblWalkNode(lbl, nd, exit, reach)
  78         label lbl, exit;
  79         t_node *nd;
  80 {
  81         /*      Generate code for node "nd", after generating instruction
  82                 label "lbl". "exit" is the exit label for the closest
  83                 enclosing LOOP.
  84         */
  85
  86         def_ilb(lbl);
  87         return WalkNode(nd, exit, reach);
  88 }
  89
  90 static arith tmpprio;
  91
  92 STATIC
  93 DoPriority()
  94 {
  95         /*      For the time being (???), handle priorities by calls to
  96                 the runtime system
  97         */
  98         if (priority) {
  99                 tmpprio = NewInt();
 100                 C_loc(priority->nd_INT);
 101                 CAL("stackprio", (int) word_size);
 102                 C_lfr(word_size);
 103                 C_stl(tmpprio);
 104         }
 105 }
 106
 107 STATIC
 108 EndPriority()
 109 {
 110         if (priority) {
 111                 C_lol(tmpprio);
 112                 CAL("unstackprio", (int) word_size);
 113                 FreeInt(tmpprio);
 114         }
 115 }
 116
 117 def_ilb(l)
 118         label l;
 119 {
 120         /*      Instruction label definition. Forget about line number.
 121         */
 122         C_df_ilb(l);
 123         oldlineno = 0;
 124 }
 125
 126 DoLineno(nd)
 127         register t_node *nd;
 128 {
 129         /*      Generate line number information, if necessary.
 130         */
 131         if ((! options['L']
 132 #ifdef DBSYMTAB
 133              || options['g']
 134 #endif /* DBSYMTAB */
 135             ) &&
 136             nd->nd_lineno &&
 137             nd->nd_lineno != oldlineno) {
 138                 oldlineno = nd->nd_lineno;
 139                 if (! options['L']) C_lin((arith) nd->nd_lineno);
 140 #ifdef DBSYMTAB
 141                 if ( options['g']) {
 142                         static int      ms_lineno;
 143
 144                         if (ms_lineno != nd->nd_lineno) {
 145                                 ms_lineno = nd->nd_lineno;
 146                                 C_ms_std((char *) 0, N_SLINE, ms_lineno);
 147                         }
 148                 }
 149 #endif /* DBSYMTAB */
 150         }
 151 }
 152
 153 DoFilename(needed)
 154 {
 155         /*      Generate filename information, when needed.
 156                 This routine is called at the generation of a
 157                 procedure entry, and after generating a call to
 158                 another procedure.
 159         */
 160         static label    filename_label = 0;
 161
 162         oldlineno = 0;  /* always invalidate remembered line number */
 163         if (needed && ! options['L']) {
 164
 165                 if (! filename_label) {
 166                         filename_label = 1;
 167                         C_df_dlb((label) 1);
 168                         C_rom_scon(FileName, (arith) (strlen(FileName) + 1));
 169                 }
 170
 171                 C_fil_dlb((label) 1, (arith) 0);
 172         }
 173 }
 174
 175 WalkModule(module)
 176         register t_def *module;
 177 {
 178         /*      Walk through a module, and all its local definitions.
 179                 Also generate code for its body.
 180                 This code is collected in an initialization routine.
 181         */
 182         register t_scope *sc;
 183         t_scopelist *savevis = CurrVis;
 184
 185         CurrVis = module->mod_vis;
 186         priority = module->mod_priority;
 187         sc = CurrentScope;
 188
 189         /* Walk through it's local definitions
 190         */
 191         WalkDefList(sc->sc_def, WalkDef);
 192
 193         /* Now, generate initialization code for this module.
 194            First call initialization routines for modules defined within
 195            this module.
 196         */
 197         sc->sc_off = 0;         /* no locals (yet) */
 198         text_label = 1;         /* label at end of initialization routine */
 199         TmpOpen(sc);            /* Initialize for temporaries */
 200         C_pro_narg(sc->sc_name);
 201 #ifdef DBSYMTAB
 202         if (options['g']) {
 203                 stb_string(module, D_MODULE);
 204                 WalkDefList(sc->sc_def, stabdef);
 205                 if (state == PROGRAM && module == Defined) {
 206                         C_ms_stb_cst(module->df_idf->id_text,
 207                                      N_MAIN,
 208                                      0,
 209                                      (arith) 0);
 210                 }
 211                 stb_string(module, D_END);
 212         }
 213 #endif
 214         DoPriority();
 215         if (module == Defined) {
 216                 /* Body of implementation or program module.
 217                    Call initialization routines of imported modules.
 218                    Also prevent recursive calls of this one.
 219                 */
 220                 register t_node *nd = Modules;
 221
 222                 if (state == IMPLEMENTATION) {
 223                         /* We don't actually prevent recursive calls,
 224                            but do nothing if called recursively
 225                         */
 226                         C_df_dlb(++data_label);
 227                         C_con_cst((arith) 0);
 228                         /* if this one is set to non-zero, the initialization
 229                            was already done.
 230                         */
 231                         C_loe_dlb(data_label, (arith) 0);
 232                         C_zne(RETURN_LABEL);
 233                         C_ine_dlb(data_label, (arith) 0);
 234                 }
 235                 else if (! options['R']) {
 236                         /* put funny value in BSS, in an attempt to detect
 237                            uninitialized variables
 238                         */
 239                         C_cal("killbss");
 240                 }
 241
 242                 for (; nd; nd = nd->nd_NEXT) {
 243                         C_cal(nd->nd_def->mod_vis->sc_scope->sc_name);
 244                 }
 245                 DoFilename(1);
 246         }
 247         WalkDefList(sc->sc_def, MkCalls);
 248         proclevel++;
 249 #ifdef DBSYMTAB
 250         if (options['g']) {
 251                 C_ms_std((char *) 0, N_LBRAC, gdb_flag ? 0 : proclevel);
 252         }
 253 #endif /* DBSYMTAB */
 254         WalkNode(module->mod_body, NO_EXIT_LABEL, REACH_FLAG);
 255         DO_DEBUG(options['X'], PrNode(module->mod_body, 0));
 256         def_ilb(RETURN_LABEL);
 257         EndPriority();
 258         C_ret((arith) 0);
 259 #ifdef DBSYMTAB
 260         if (options['g']) {
 261                 C_ms_std((char *) 0, N_RBRAC, gdb_flag ? 0 : proclevel);
 262         }
 263 #endif /* DBSYMTAB */
 264         C_end(-sc->sc_off);
 265         proclevel--;
 266         TmpClose();
 267
 268         CurrVis = savevis;
 269         WalkDefList(sc->sc_def, UseWarnings);
 270 }
 271
 272 WalkProcedure(procedure)
 273         register t_def *procedure;
 274 {
 275         /*      Walk through the definition of a procedure and all its
 276                 local definitions, checking and generating code.
 277         */
 278         t_scopelist *savevis = CurrVis;
 279         register t_type *tp;
 280         register t_param *param;
 281         register t_scope *procscope = procedure->prc_vis->sc_scope;
 282         label too_big = 0;              /* returnsize larger than returnarea */
 283         arith StackAdjustment = 0;      /* space for conformant arrays */
 284         arith retsav = 0;               /* temporary space for return value */
 285         arith func_res_size = 0;
 286 #ifdef USE_INSERT
 287         int partno = C_getid();
 288         int partno2 = C_getid();
 289 #else
 290         label cd_init;
 291         label cd_body;
 292 #endif
 293
 294         proclevel++;
 295         CurrVis = procedure->prc_vis;
 296
 297         /* Generate code for all local modules and procedures
 298         */
 299         WalkDefList(procscope->sc_def, WalkDef);
 300
 301         func_type = tp = RemoveEqual(ResultType(procedure->df_type));
 302
 303         if (tp) {
 304                 func_res_size = WA(tp->tp_size);
 305                 if (TooBigForReturnArea(tp)) {
 306 #ifdef BIG_RESULT_ON_STACK
 307                         /* The result type of this procedure is too big.
 308                            The caller will have reserved space on its stack,
 309                            above the parameters, to store the result.
 310                         */
 311                         too_big = 1;
 312 #else
 313                         /* The result type of this procedure is too big.
 314                            The actual procedure will return a pointer to a
 315                            global data area in which the function result is
 316                            stored.
 317                            Notice that this makes the code non-reentrant.
 318                            Here, we create the data area for the function
 319                            result.
 320                         */
 321                         too_big = ++data_label;
 322                         C_df_dlb(too_big);
 323                         C_bss_cst(func_res_size, (arith)0, 0);
 324 #endif /* BIG_RESULT_ON_STACK */
 325                 }
 326         }
 327
 328         /* Generate code for this procedure
 329         */
 330         TmpOpen(procscope);
 331 #ifdef USE_INSERT
 332         C_insertpart(partno2);  /* procedure header */
 333 #else
 334         C_pro_narg(procedure->prc_name);
 335 #ifdef DBSYMTAB
 336         if (options['g']) {
 337                 stb_string(procedure, D_PROCEDURE);
 338                 WalkDefList(procscope->sc_def, stabdef);
 339                 stb_string(procedure, D_PEND);
 340                 C_ms_std((char *) 0, N_LBRAC, gdb_flag ? 0 : proclevel);
 341         }
 342 #endif /* DBSYMTAB */
 343         C_ms_par(procedure->df_type->prc_nbpar
 344 #ifdef BIG_RESULT_ON_STACK
 345                 + (too_big ? func_res_size : 0)
 346 #endif
 347                 );
 348 #endif
 349         /* generate code for filename only when the procedure can be
 350            exported, either directly or by taking the address.
 351            This cannot be done if the level is bigger than one (because in
 352            this case it is a nested procedure).
 353         */
 354         DoFilename(procscope->sc_level == 1);
 355         DoPriority();
 356
 357         text_label = 1;         /* label at end of procedure */
 358
 359         /* Check if we must save the stack pointer */
 360         for (param = ParamList(procedure->df_type);
 361              param;
 362              param = param->par_next) {
 363                 if (! IsVarParam(param)) {
 364                         tp = TypeOfParam(param);
 365
 366                         if ( IsConformantArray(tp)) {
 367                                 /* First time we get here
 368                                 */
 369                                 if (func_type && !too_big) {
 370                                         /* Some local space, only
 371                                            needed if the value itself
 372                                            is returned
 373                                         */
 374                                         retsav= TmpSpace(func_res_size, 1);
 375                                 }
 376                                 StackAdjustment = NewPtr();
 377                                 C_lor((arith) 1);
 378                                 STL(StackAdjustment, pointer_size);
 379                         }
 380                 }
 381         }
 382
 383 #ifdef USE_INSERT
 384         C_insertpart(partno);
 385 #else
 386         cd_init = ++text_label;
 387         cd_body = ++text_label;
 388         c_bra(cd_init);
 389         def_ilb(cd_body);
 390 #endif
 391
 392         if ((WalkNode(procedure->prc_body, NO_EXIT_LABEL, REACH_FLAG) & REACH_FLAG)) {
 393                 if (func_res_size) {
 394                         node_warning(procscope->sc_end,
 395                                      W_ORDINARY,
 396                                      "function procedure \"%s\" does not always return a value",
 397                                      procedure->df_idf->id_text);
 398                         c_loc(M2_NORESULT);
 399                         C_trp();
 400                         C_asp(-func_res_size);
 401                 }
 402 #ifndef USE_INSERT
 403                 c_bra(RETURN_LABEL);
 404 #endif
 405         }
 406
 407 #ifdef USE_INSERT
 408         C_beginpart(partno);
 409 #else
 410         def_ilb(cd_init);
 411 #endif
 412
 413         /* Generate calls to initialization routines of modules defined within
 414            this procedure
 415         */
 416         WalkDefList(procscope->sc_def, MkCalls);
 417
 418         /* Make sure that arguments of size < word_size are on a
 419            fixed place.
 420            Also make copies of parameters when neccessary.
 421         */
 422         for (param = ParamList(procedure->df_type);
 423              param;
 424              param = param->par_next) {
 425                 if (! IsVarParam(param)) {
 426                         tp = TypeOfParam(param);
 427
 428                         if (! IsConformantArray(tp)) {
 429                                 if (tp->tp_size < word_size &&
 430                                     (int) word_size % (int) tp->tp_size == 0) {
 431                                         C_lol(param->par_def->var_off);
 432                                         STL(param->par_def->var_off,
 433                                             tp->tp_size);
 434                                 }
 435                                 continue;
 436                         }
 437                         /* Here, we have to make a copy of the
 438                            array. We must also remember how much
 439                            room is reserved for copies, because
 440                            we have to adjust the stack pointer before
 441                            a RET is done. This is even more complicated
 442                            when the procedure returns a value.
 443                            Then, the value must be saved,
 444                            the stack adjusted, the return value pushed
 445                            again, and then RET
 446                         */
 447                         /* First compute new stackpointer */
 448                         C_lal(param->par_def->var_off);
 449                         CAL("new_stackptr", (int)pointer_size);
 450                         C_lfr(pointer_size);
 451                         C_ass(pointer_size);
 452                                         /* adjusted stack pointer */
 453                         LOL(param->par_def->var_off, pointer_size);
 454                                         /* push source address */
 455                         CAL("copy_array", (int)pointer_size);
 456                                         /* copy */
 457                 }
 458         }
 459 #ifdef USE_INSERT
 460         C_endpart(partno);
 461 #else
 462         c_bra(cd_body);
 463 #endif
 464         DO_DEBUG(options['X'], PrNode(procedure->prc_body, 0));
 465         def_ilb(RETURN_LABEL);  /* label at end */
 466         if (too_big) {
 467                 /* Fill the data area reserved for the function result
 468                    with the result
 469                 */
 470 #ifdef BIG_RESULT_ON_STACK
 471                 C_lal(procedure->df_type->prc_nbpar);
 472 #else
 473                 c_lae_dlb(too_big);
 474 #endif /* BIG_RESULT_ON_STACK */
 475                 C_sti(func_res_size);
 476                 if (StackAdjustment) {
 477                         /* Remove copies of conformant arrays
 478                         */
 479                         LOL(StackAdjustment, pointer_size);
 480                         C_str((arith) 1);
 481                 }
 482 #ifdef BIG_RESULT_ON_STACK
 483                 func_res_size = 0;
 484 #else
 485                 c_lae_dlb(too_big);
 486                 func_res_size = pointer_size;
 487 #endif /* BIG_RESULT_ON_STACK */
 488         }
 489         else if (StackAdjustment) {
 490                 /* First save the function result in a safe place.
 491                    Then remove copies of conformant arrays,
 492                    and put function result back on the stack
 493                 */
 494                 if (func_type) {
 495                         STL(retsav, func_res_size);
 496                 }
 497                 LOL(StackAdjustment, pointer_size);
 498                 C_str((arith) 1);
 499                 if (func_type) {
 500                         LOL(retsav, func_res_size);
 501                 }
 502         }
 503         EndPriority();
 504         C_ret(func_res_size);
 505 #ifdef USE_INSERT
 506         C_beginpart(partno2);
 507         C_pro(procedure->prc_name, -procscope->sc_off);
 508 #ifdef DBSYMTAB
 509         if (options['g']) {
 510                 stb_string(procedure, D_PROCEDURE);
 511                 WalkDefList(procscope->sc_def, stabdef);
 512                 stb_string(procedure, D_PEND);
 513                 C_ms_std((char *) 0, N_LBRAC, gdb_flag ? 0 : proclevel);
 514         }
 515 #endif /* DBSYMTAB */
 516         C_ms_par(procedure->df_type->prc_nbpar
 517 #ifdef BIG_RESULT_ON_STACK
 518                 + (too_big ? func_res_size : 0)
 519 #endif
 520                 );
 521 #endif
 522         if (! options['n']) WalkDefList(procscope->sc_def, RegisterMessage);
 523 #ifdef USE_INSERT
 524         C_endpart(partno2);
 525 #endif
 526 #ifdef DBSYMTAB
 527         if (options['g']) {
 528                 C_ms_std((char *) 0, N_RBRAC, gdb_flag ? 0 : proclevel);
 529         }
 530 #endif /* DBSYMTAB */
 531         C_end(-procscope->sc_off);
 532         if (! fit(procscope->sc_off, (int) word_size)) {
 533                 node_error(procedure->prc_body,
 534                            "maximum local byte count exceeded");
 535         }
 536         TmpClose();
 537         CurrVis = savevis;
 538         proclevel--;
 539         WalkDefList(procscope->sc_def, UseWarnings);
 540 }
 541
 542 static
 543 WalkDef(df)
 544         register t_def *df;
 545 {
 546         /*      Walk through a list of definitions
 547         */
 548
 549         switch(df->df_kind) {
 550         case D_MODULE:
 551                 WalkModule(df);
 552                 break;
 553         case D_PROCEDURE:
 554                 WalkProcedure(df);
 555                 break;
 556         case D_VARIABLE:
 557                 if (!proclevel  && !(df->df_flags & D_ADDRGIVEN)) {
 558                         C_df_dnam(df->var_name);
 559                         C_bss_cst(
 560                                 WA(df->df_type->tp_size),
 561                                 (arith) 0, 0);
 562                 }
 563                 break;
 564         default:
 565                 /* nothing */
 566                 ;
 567         }
 568 }
 569
 570 static
 571 MkCalls(df)
 572         register t_def *df;
 573 {
 574         /*      Generate calls to initialization routines of modules
 575         */
 576
 577         if (df->df_kind == D_MODULE) {
 578                 C_lxl((arith) 0);
 579                 CAL(df->mod_vis->sc_scope->sc_name, (int)pointer_size);
 580         }
 581 }
 582
 583 WalkLink(nd, exit_label, end_reached)
 584         register t_node *nd;
 585         label exit_label;
 586 {
 587         /*      Walk node "nd", which is a link.
 588                 "exit_label" is set to a label number when inside a LOOP.
 589                 "end_reached" maintains info about reachability (REACH_FLAG),
 590                 and whether an EXIT statement was seen (EXIT_FLAG).
 591         */
 592
 593         while (nd && nd->nd_class == Link) {     /* statement list */
 594                 end_reached = WalkNode(nd->nd_LEFT, exit_label, end_reached);
 595                 nd = nd->nd_RIGHT;
 596         }
 597
 598         return WalkNode(nd, exit_label, end_reached);
 599 }
 600
 601 STATIC
 602 ForLoopVarExpr(nd)
 603         register t_node *nd;
 604 {
 605         register t_type *tp = nd->nd_type;
 606
 607         CodePExpr(nd);
 608         CodeCoercion(tp, BaseType(tp));
 609 }
 610
 611 int
 612 WalkStat(nd, exit_label, end_reached)
 613         register t_node *nd;
 614         label exit_label;
 615 {
 616         /*      Walk through a statement, generating code for it.
 617         */
 618         register t_node *left = nd->nd_LEFT;
 619         register t_node *right = nd->nd_RIGHT;
 620
 621         assert(nd->nd_class == Stat);
 622
 623         if (nd->nd_symb == ';') return 1;
 624
 625         if (! end_reached & REACH_FLAG) {
 626                 node_warning(nd, W_ORDINARY, "statement not reached");
 627         }
 628         if (nd->nd_symb != WHILE ||
 629             nd->nd_lineno != left->nd_lineno) {
 630                 /* Avoid double linenumber generation in while statements */
 631                 DoLineno(nd);
 632         }
 633         options['R'] = (nd->nd_flags & ROPTION);
 634         options['A'] = (nd->nd_flags & AOPTION);
 635         switch(nd->nd_symb) {
 636         case '(': {
 637                 t_node *nd1 = nd;
 638                 if (ChkCall(&nd1)) {
 639                         assert(nd == nd1);
 640                         if (nd->nd_type != 0) {
 641                                 node_error(nd, "procedure call expected instead of function call");
 642                                 break;
 643                         }
 644                         CodeCall(nd);
 645                 }
 646                 }
 647                 break;
 648
 649         case BECOMES:
 650                 DoAssign(nd);
 651                 break;
 652
 653         case IF:
 654                 {       label l1 = ++text_label, l3 = ++text_label;
 655                         int end_r;
 656
 657                         ExpectBool(&(nd->nd_LEFT), l3, l1);
 658                         assert(right->nd_symb == THEN);
 659                         end_r = LblWalkNode(l3, right->nd_LEFT, exit_label, end_reached);
 660
 661                         if (right->nd_RIGHT) {  /* ELSE part */
 662                                 label l2 = ++text_label;
 663
 664                                 c_bra(l2);
 665                                 end_reached = end_r | LblWalkNode(l1, right->nd_RIGHT, exit_label, end_reached);
 666                                 l1 = l2;
 667                         }
 668                         else    end_reached |= end_r;
 669                         def_ilb(l1);
 670                         break;
 671                 }
 672
 673         case CASE:
 674                 end_reached = CaseCode(nd, exit_label, end_reached);
 675                 break;
 676
 677         case WHILE:
 678                 {       label   loop = ++text_label,
 679                                 exit = ++text_label,
 680                                 dummy = ++text_label;
 681
 682                         c_bra(dummy);
 683                         end_reached |= LblWalkNode(loop, right, exit_label, end_reached);
 684                         def_ilb(dummy);
 685                         ExpectBool(&(nd->nd_LEFT), loop, exit);
 686                         def_ilb(exit);
 687                         break;
 688                 }
 689
 690         case REPEAT:
 691                 {       label loop = ++text_label, exit = ++text_label;
 692
 693                         end_reached = LblWalkNode(loop, left, exit_label, end_reached);
 694                         ExpectBool(&(nd->nd_RIGHT), exit, loop);
 695                         def_ilb(exit);
 696                         break;
 697                 }
 698
 699         case LOOP:
 700                 {       label loop = ++text_label, exit = ++text_label;
 701
 702                         if (LblWalkNode(loop, right, exit, end_reached) & EXIT_FLAG) {
 703                                 end_reached &= REACH_FLAG;
 704                         }
 705                         else    end_reached = 0;
 706                         c_bra(loop);
 707                         def_ilb(exit);
 708                         break;
 709                 }
 710
 711         case FOR:
 712                 {
 713                         arith tmp = NewInt();
 714                         arith tmp2 = NewInt();
 715                         int good_forvar;
 716                         label l1 = ++text_label;
 717                         label l2 = ++text_label;
 718                         int uns = 0;
 719                         arith stepsize;
 720                         t_type *bstp;
 721                         t_node *loopid;
 722
 723                         good_forvar = DoForInit(left);
 724                         loopid = left->nd_LEFT;
 725                         if ((stepsize = right->nd_LEFT->nd_INT) == 0) {
 726                                 node_warning(right->nd_LEFT,
 727                                              W_ORDINARY,
 728                                              "zero stepsize in FOR loop");
 729                         }
 730                         if (good_forvar) {
 731                                 bstp = BaseType(loopid->nd_type);
 732                                 uns = bstp->tp_fund != T_INTEGER;
 733                                 CodePExpr(left->nd_RIGHT->nd_RIGHT);
 734                                 C_stl(tmp);
 735                                 CodePExpr(left->nd_RIGHT->nd_LEFT);
 736                                 C_dup(int_size);
 737                                 C_stl(tmp2);
 738                                 C_lol(tmp);
 739                                 if (uns) C_cmu(int_size);
 740                                 else C_cmi(int_size);
 741                                 if (stepsize >= 0) C_zgt(l2);
 742                                 else C_zlt(l2);
 743                                 C_lol(tmp2);
 744                                 RangeCheck(loopid->nd_type,
 745                                            left->nd_RIGHT->nd_LEFT->nd_type);
 746                                 CodeDStore(loopid);
 747                                 if (stepsize >= 0) {
 748                                         C_lol(tmp);
 749                                         ForLoopVarExpr(loopid);
 750                                 }
 751                                 else {
 752                                         stepsize = -stepsize;
 753                                         ForLoopVarExpr(loopid);
 754                                         C_lol(tmp);
 755                                 }
 756                                 C_sbu(int_size);
 757                                 if (stepsize) {
 758                                         C_loc(stepsize);
 759                                         C_dvu(int_size);
 760                                 }
 761                                 C_stl(tmp);
 762                                 loopid->nd_def->df_flags |= D_FORLOOP;
 763                                 def_ilb(l1);
 764                                 if (! options['R']) {
 765                                         ForLoopVarExpr(loopid);
 766                                         C_stl(tmp2);
 767                                 }
 768                                 end_reached |= WalkNode(right->nd_RIGHT, exit_label, end_reached);
 769                                 if (! options['R']) {
 770                                         label x = ++text_label;
 771                                         C_lol(tmp2);
 772                                         ForLoopVarExpr(loopid);
 773                                         C_beq(x);
 774                                         c_loc(M2_FORCH);
 775                                         C_trp();
 776                                         def_ilb(x);
 777                                 }
 778                                 loopid->nd_def->df_flags &= ~D_FORLOOP;
 779                                 FreeInt(tmp2);
 780                                 if (stepsize) {
 781                                         C_lol(tmp);
 782                                         C_zeq(l2);
 783                                         C_lol(tmp);
 784                                         c_loc(1);
 785                                         C_sbu(int_size);
 786                                         C_stl(tmp);
 787                                         C_loc(right->nd_LEFT->nd_INT);
 788                                         ForLoopVarExpr(loopid);
 789                                         C_adu(int_size);
 790                                         RangeCheck(loopid->nd_type, bstp);
 791                                         CodeDStore(loopid);
 792                                 }
 793                         }
 794                         else {
 795                                 end_reached |= WalkNode(right->nd_RIGHT, exit_label, end_reached);
 796                                 loopid->nd_def->df_flags &= ~D_FORLOOP;
 797                         }
 798                         c_bra(l1);
 799                         def_ilb(l2);
 800                         FreeInt(tmp);
 801                 }
 802                 break;
 803
 804         case WITH:
 805                 {
 806                         t_scopelist link;
 807                         struct withdesig wds;
 808                         t_desig ds;
 809
 810                         if (! WalkDesignator(&(nd->nd_LEFT), &ds, D_USED)) break;
 811                         left = nd->nd_LEFT;
 812                         if (left->nd_type->tp_fund != T_RECORD) {
 813                                 node_error(left, "record variable expected");
 814                                 break;
 815                         }
 816
 817                         wds.w_next = WithDesigs;
 818                         wds.w_flags = D_USED;
 819                         WithDesigs = &wds;
 820                         wds.w_scope = left->nd_type->rec_scope;
 821                         CodeAddress(&ds);
 822                         ds.dsg_kind = DSG_FIXED;
 823                         /* Create a designator structure for the temporary.
 824                         */
 825                         ds.dsg_offset = NewPtr();
 826                         ds.dsg_name = 0;
 827                         CodeStore(&ds, address_type);
 828                         ds.dsg_kind = DSG_PFIXED;
 829                         /* the record is indirectly available */
 830                         wds.w_desig = ds;
 831                         link.sc_scope = wds.w_scope;
 832                         link.sc_next = CurrVis;
 833                         CurrVis = &link;
 834                         end_reached = WalkNode(right, exit_label, end_reached);
 835                         CurrVis = link.sc_next;
 836                         WithDesigs = wds.w_next;
 837                         FreePtr(ds.dsg_offset);
 838                         ChkDesig(&(nd->nd_LEFT), wds.w_flags & (D_USED|D_DEFINED));
 839                         break;
 840                 }
 841
 842         case EXIT:
 843                 assert(exit_label != 0);
 844
 845                 if (end_reached & REACH_FLAG) end_reached = EXIT_FLAG;
 846                 c_bra(exit_label);
 847                 break;
 848
 849         case RETURN:
 850                 end_reached &= ~REACH_FLAG;
 851                 if (right) {
 852                         if (! ChkExpression(&(nd->nd_RIGHT))) break;
 853                         /* The type of the return-expression must be
 854                            assignment compatible with the result type of the
 855                            function procedure (See Rep. 9.11).
 856                         */
 857                         if (!ChkAssCompat(&(nd->nd_RIGHT), func_type, "RETURN")) {
 858                                 break;
 859                         }
 860                         right = nd->nd_RIGHT;
 861                         if (right->nd_type->tp_fund == T_STRING) {
 862                                 CodePString(right, func_type);
 863                         }
 864                         else    CodePExpr(right);
 865                 }
 866                 c_bra(RETURN_LABEL);
 867                 break;
 868
 869         default:
 870                 crash("(WalkStat)");
 871         }
 872         return end_reached;
 873 }
 874
 875 extern int      NodeCrash();
 876
 877 int (*WalkTable[])() = {
 878         NodeCrash,
 879         NodeCrash,
 880         NodeCrash,
 881         NodeCrash,
 882         NodeCrash,
 883         NodeCrash,
 884         NodeCrash,
 885         NodeCrash,
 886         NodeCrash,
 887         NodeCrash,
 888         WalkStat,
 889         NodeCrash,
 890         WalkLink,
 891 };
 892
 893 extern t_desig null_desig;
 894
 895 ExpectBool(pnd, true_label, false_label)
 896         register t_node **pnd;
 897         label true_label, false_label;
 898 {
 899         /*      "pnd" must indicate a boolean expression. Check this and
 900                 generate code to evaluate the expression.
 901         */
 902         t_desig ds;
 903
 904         ds = null_desig;
 905         if (ChkExpression(pnd)) {
 906                 if ((*pnd)->nd_type != bool_type &&
 907                     (*pnd)->nd_type != error_type) {
 908                         node_error(*pnd, "boolean expression expected");
 909                 }
 910
 911                 CodeExpr(*pnd, &ds,  true_label, false_label);
 912         }
 913 }
 914
 915 int
 916 WalkDesignator(pnd, ds, flags)
 917         t_node **pnd;
 918         t_desig *ds;
 919 {
 920         /*      Check designator and generate code for it
 921         */
 922
 923         if (! ChkVariable(pnd, flags)) return 0;
 924
 925         *ds = null_desig;
 926         CodeDesig(*pnd, ds);
 927         return 1;
 928 }
 929
 930 DoForInit(nd)
 931         t_node *nd;
 932 {
 933         register t_node *right = nd->nd_RIGHT;
 934         register t_def *df;
 935         t_type *base_tp;
 936         t_type *tpl, *tpr;
 937         int r;
 938
 939         r = ChkVariable(&(nd->nd_LEFT), D_USED|D_DEFINED);
 940         r &= ChkExpression(&(right->nd_LEFT));
 941         r &= ChkExpression(&(right->nd_RIGHT));
 942         if (!r) return 0;
 943
 944         df = nd->nd_LEFT->nd_def;
 945         if (df->df_kind == D_FIELD) {
 946                 node_error(nd,
 947                            "FOR-loop variable may not be a field of a record");
 948                 return 1;
 949         }
 950
 951         if (!df->var_name && df->var_off >= 0) {
 952                 node_error(nd, "FOR-loop variable may not be a parameter");
 953                 return 1;
 954         }
 955
 956         if (df->df_scope != CurrentScope) {
 957                 register t_scopelist *sc = CurrVis;
 958
 959                 for (;;) {
 960                         if (!sc) {
 961                                 node_error(nd,
 962                                       "FOR-loop variable may not be imported");
 963                                 return 1;
 964                         }
 965                         if (sc->sc_scope == df->df_scope) break;
 966                         sc = nextvisible(sc);
 967                 }
 968         }
 969
 970         if (df->df_type->tp_size > word_size ||
 971             !(df->df_type->tp_fund & T_DISCRETE)) {
 972                 node_error(nd, "illegal type of FOR loop variable");
 973                 return 1;
 974         }
 975
 976         base_tp = BaseType(df->df_type);
 977         tpl = right->nd_LEFT->nd_type;
 978         tpr = right->nd_RIGHT->nd_type;
 979 #ifndef STRICT_3RD_ED
 980         if (! options['3']) {
 981           if (!ChkAssCompat(&(right->nd_LEFT), base_tp, "FOR statement") ||
 982               !ChkAssCompat(&(right->nd_RIGHT), base_tp, "FOR statement")) {
 983                 return 1;
 984           }
 985           if (!TstCompat(df->df_type, tpl) ||
 986               !TstCompat(df->df_type, tpr)) {
 987 node_warning(nd, W_OLDFASHIONED, "compatibility required in FOR statement");
 988           }
 989         } else
 990 #endif
 991         if (!ChkCompat(&(right->nd_LEFT), base_tp, "FOR statement") ||
 992             !ChkCompat(&(right->nd_RIGHT), base_tp, "FOR statement")) {
 993                 return 1;
 994         }
 995
 996         return 1;
 997 }
 998
 999 DoAssign(nd)
1000         register t_node *nd;
1001 {
1002         /* May we do it in this order (expression first) ???
1003            The reference manual sais nothing about it, but the book does:
1004            it sais that the left hand side is evaluated first.
1005            DAMN THE BOOK!
1006         */
1007         t_desig dsr;
1008         register t_type *tp;
1009
1010         if (! (ChkExpression(&(nd->nd_RIGHT)) &
1011                ChkVariable(&(nd->nd_LEFT), D_DEFINED))) return;
1012         tp = nd->nd_LEFT->nd_type;
1013
1014         if (! ChkAssCompat(&(nd->nd_RIGHT), tp, "assignment")) {
1015                 return;
1016         }
1017         dsr = null_desig;
1018
1019 #define StackNeededFor(ds)      ((ds).dsg_kind == DSG_PLOADED \
1020                                   || (ds).dsg_kind == DSG_INDEXED)
1021         CodeExpr(nd->nd_RIGHT, &dsr, NO_LABEL, NO_LABEL);
1022         tp = nd->nd_RIGHT->nd_type;
1023         if (complex(tp)) {
1024                 if (StackNeededFor(dsr)) CodeAddress(&dsr);
1025         }
1026         else {
1027                 CodeValue(&dsr, tp);
1028         }
1029         CodeMove(&dsr, nd->nd_LEFT, tp);
1030 }
1031
1032 static
1033 RegisterMessage(df)
1034         register t_def *df;
1035 {
1036         register t_type *tp;
1037
1038         if (df->df_kind == D_VARIABLE) {
1039                 if ( !(df->df_flags & D_NOREG)) {
1040                         /* Examine type and size
1041                         */
1042                         tp = BaseType(df->df_type);
1043                         if ((df->df_flags & D_VARPAR) ||
1044                             (tp->tp_fund&(T_POINTER|T_HIDDEN|T_EQUAL))) {
1045                                 C_ms_reg(df->var_off,
1046                                          pointer_size,
1047                                          reg_pointer,
1048                                          0);
1049                         }
1050                         else if (tp->tp_fund & T_NUMERIC) {
1051                                 C_ms_reg(df->var_off,
1052                                          tp->tp_size,
1053                                          tp->tp_fund == T_REAL ?
1054                                             reg_float : reg_any,
1055                                          0);
1056                         }
1057                 }
1058         }
1059 }
1060
1061 static
1062 df_warning(nd, df, warning)
1063         t_node  *nd;
1064         t_def   *df;
1065         char    *warning;
1066 {
1067         if (! (df->df_kind & (D_VARIABLE|D_PROCEDURE|D_TYPE|D_CONST|D_PROCHEAD))) {
1068                 return;
1069         }
1070         if (warning) {
1071                 node_warning(nd,
1072                              W_ORDINARY,
1073                              "%s \"%s\" %s",
1074                              (df->df_flags & D_VALPAR) ? "value parameter" :
1075                               (df->df_flags & D_VARPAR) ? "variable parameter" :
1076                                (df->df_kind == D_VARIABLE) ? "variable" :
1077                                 (df->df_kind == D_TYPE) ? "type" :
1078                                  (df->df_kind == D_CONST) ? "constant" :
1079                                   "procedure",
1080                              df->df_idf->id_text, warning);
1081         }
1082 }
1083
1084 static
1085 UseWarnings(df)
1086         register t_def *df;
1087 {
1088         t_node  *nd = df->df_scope->sc_end;
1089
1090         if (is_anon_idf(df->df_idf) ||
1091             !(df->df_kind&(D_IMPORTED|D_VARIABLE|D_PROCEDURE|D_CONST|D_TYPE)) ||
1092             (df->df_flags&(D_EXPORTED|D_QEXPORTED))) {
1093                 return;
1094         }
1095
1096         if (df->df_kind & D_IMPORTED) {
1097                 register t_def *df1 = df->imp_def;
1098
1099                 df1->df_flags |= df->df_flags & (D_USED|D_DEFINED);
1100                 if (df->df_kind == D_INUSE) return;
1101                 if ( !(df->df_flags & D_IMP_BY_EXP)) {
1102                         if (df->df_flags & (D_USED | D_DEFINED)) {
1103                                 return;
1104                         }
1105                         df_warning(nd,
1106                                    df1,
1107                                    df1->df_kind == D_VARIABLE ?
1108                                         "imported but not used/assigned" :
1109                                         "imported but not used");
1110                         return;
1111                 }
1112                 df = df1;
1113                 nd = df->df_scope->sc_end;
1114         }
1115         switch(df->df_flags & (D_USED|D_DEFINED|D_VALPAR|D_VARPAR)) {
1116         case 0:
1117         case D_VARPAR:
1118                 df_warning(nd, df,"never used/assigned");
1119                 break;
1120         case D_USED:
1121                 df_warning(nd, df,"never assigned");
1122                 break;
1123         case D_VALPAR:
1124         case D_DEFINED:
1125         case D_DEFINED|D_VALPAR:
1126                 df_warning(nd, df,"never used");
1127                 break;
1128         }
1129 }
1130
1131 WalkDefList(df, proc)
1132         register t_def *df;
1133         int (*proc)();
1134 {
1135         for (; df; df = df->df_nextinscope) {
1136                 (*proc)(df);
1137         }
1138 }
1139
1140 #ifdef DBSYMTAB
1141 static int
1142 stabdef(df)
1143         t_def   *df;
1144 {
1145         switch(df->df_kind) {
1146         case D_CONST:
1147         case D_VARIABLE:
1148                 stb_string(df, df->df_kind);
1149                 break;
1150         }
1151 }
1152 #endif