src/loop.c

   1 /* PSPP - computes sample statistics.
   2    Copyright (C) 1997-9, 2000 Free Software Foundation, Inc.
   3    Written by Ben Pfaff <blp@gnu.org>.
   4
   5    This program is free software; you can redistribute it and/or
   6    modify it under the terms of the GNU General Public License as
   7    published by the Free Software Foundation; either version 2 of the
   8    License, or (at your option) any later version.
   9
  10    This program is distributed in the hope that it will be useful, but
  11    WITHOUT ANY WARRANTY; without even the implied warranty of
  12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13    General Public License for more details.
  14
  15    You should have received a copy of the GNU General Public License
  16    along with this program; if not, write to the Free Software
  17    Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  18    02111-1307, USA. */
  19
  20 #include <config.h>
  21 #include "error.h"
  22 #include "alloc.h"
  23 #include "command.h"
  24 #include "do-ifP.h"
  25 #include "error.h"
  26 #include "expr.h"
  27 #include "lexer.h"
  28 #include "misc.h"
  29 #include "settings.h"
  30 #include "str.h"
  31 #include "var.h"
  32
  33 #include "debug-print.h"
  34
  35 /* LOOP strategy:
  36
  37    Each loop causes 3 different transformations to be output.  The
  38    first two are output when the LOOP command is encountered; the last
  39    is output when the END LOOP command is encountered.
  40
  41    The first to be output resets the pass number in the second
  42    transformation to -1.  This ensures that the pass number is set to
  43    -1 every time the loop is encountered, before the first iteration.
  44
  45    The second transformation increments the pass number.  If
  46    there is no indexing or test clause on either LOOP or END
  47    LOOP, then the pass number is checked against MXLOOPS and
  48    control may pass out of the loop.  Otherwise the indexing or
  49    test clause(s) on LOOP are checked, and again control may pass
  50    out of the loop.
  51
  52    After the second transformation the body of the loop is
  53    executed.
  54
  55    The last transformation checks the test clause if present and
  56    either jumps back up to the second transformation or
  57    terminates the loop.
  58
  59    Flow of control:
  60
  61    1. LOOP.  Sets pass number to -1 and continues to next
  62       transformation.
  63
  64    2. LOOP.  Increments pass number.  Tests optional indexing
  65       clause and optional IF clause.  If we're done with the
  66       loop, we jump to the transformation just after LOOP
  67       transformation 3.
  68
  69       Otherwise, we continue through the transformations in the
  70       loop body.
  71
  72    3. END LOOP.  We test the optional IF clause.  If we need to
  73       make another pass through the loop, we jump to LOOP
  74       transformation 2.
  75
  76       Otherwise, we continue with the transformation jump after
  77       the loop.
  78  */
  79
  80 /* Types of limits on loop execution. */
  81 enum
  82   {
  83     LPC_INDEX = 001,            /* Limited by indexing clause. */
  84     LPC_COND = 002,             /* Limited by IF clause. */
  85     LPC_RINDEX = 004            /* Indexing clause counts downward, at least
  86                                    for this pass thru the loop. */
  87   };
  88
  89 /* LOOP transformation 1. */
  90 struct loop_1_trns
  91   {
  92     struct trns_header h;
  93
  94     struct loop_2_trns *two;    /* Allows modification of associated
  95                                    second transformation. */
  96
  97     struct expression *init;    /* Starting index. */
  98     struct expression *incr;    /* Index increment. */
  99     struct expression *term;    /* Terminal index. */
 100   };
 101
 102 /* LOOP transformation 2. */
 103 struct loop_2_trns
 104   {
 105     struct trns_header h;
 106
 107     struct ctl_stmt ctl;        /* Nesting control info. */
 108
 109     int flags;                  /* Types of limits on loop execution. */
 110     int pass;                   /* Number of passes thru the loop so far. */
 111
 112     struct variable *index;     /* Index variable. */
 113     double curr;                /* Current index. */
 114     double incr;                /* Increment. */
 115     double term;                /* Terminal index. */
 116
 117     struct expression *cond;    /* Optional IF condition when non-NULL. */
 118
 119     int loop_term;              /* 1+(t_trns[] index of transformation 3);
 120                                    backpatched in by END LOOP. */
 121   };
 122
 123 /* LOOP transformation 3.  (Actually output by END LOOP.)  */
 124 struct loop_3_trns
 125   {
 126     struct trns_header h;
 127
 128     struct expression *cond;    /* Optional IF condition when non-NULL. */
 129
 130     int loop_start;             /* t_trns[] index of transformation 2. */
 131   };
 132
 133 /* LOOP transformations being created. */
 134 static struct loop_1_trns *one;
 135 static struct loop_2_trns *two;
 136 static struct loop_3_trns *thr;
 137
 138 static int internal_cmd_loop (void);
 139 static int internal_cmd_end_loop (void);
 140 static trns_proc_func break_trns_proc;
 141 static trns_proc_func loop_1_trns_proc, loop_2_trns_proc, loop_3_trns_proc;
 142 static trns_free_func loop_1_trns_free, loop_2_trns_free, loop_3_trns_free;
 143 static void pop_ctl_stack (void);
 144 \f
 145 /* LOOP. */
 146
 147 /* Parses a LOOP command.  Passes the real work off to
 148    internal_cmd_loop(). */
 149 int
 150 cmd_loop (void)
 151 {
 152   if (!internal_cmd_loop ())
 153     {
 154       loop_1_trns_free ((struct trns_header *) one);
 155       loop_2_trns_free ((struct trns_header *) two);
 156       return CMD_FAILURE;
 157     }
 158
 159   return CMD_SUCCESS;
 160 }
 161
 162 /* Parses a LOOP command, returns success. */
 163 static int
 164 internal_cmd_loop (void)
 165 {
 166   /* Name of indexing variable if applicable. */
 167   char name[9];
 168
 169   /* Create and initialize transformations to facilitate
 170      error-handling. */
 171   two = xmalloc (sizeof *two);
 172   two->h.proc = loop_2_trns_proc;
 173   two->h.free = loop_2_trns_free;
 174   two->cond = NULL;
 175   two->flags = 0;
 176
 177   one = xmalloc (sizeof *one);
 178   one->h.proc = loop_1_trns_proc;
 179   one->h.free = loop_1_trns_free;
 180   one->init = one->incr = one->term = NULL;
 181   one->two = two;
 182
 183   /* Parse indexing clause. */
 184   if (token == T_ID && lex_look_ahead () == '=')
 185     {
 186       struct variable *v = dict_lookup_var (default_dict, tokid);
 187
 188       two->flags |= LPC_INDEX;
 189
 190       if (v && v->type == ALPHA)
 191         {
 192           msg (SE, _("The index variable may not be a string variable."));
 193           return 0;
 194         }
 195       strcpy (name, tokid);
 196
 197       lex_get ();
 198       assert (token == '=');
 199       lex_get ();
 200
 201       one->init = expr_parse (PXP_NUMERIC);
 202       if (!one->init)
 203         return 0;
 204
 205       if (!lex_force_match (T_TO))
 206         {
 207           expr_free (one->init);
 208           return 0;
 209         }
 210       one->term = expr_parse (PXP_NUMERIC);
 211       if (!one->term)
 212         {
 213           expr_free (one->init);
 214           return 0;
 215         }
 216
 217       if (lex_match (T_BY))
 218         {
 219           one->incr = expr_parse (PXP_NUMERIC);
 220           if (!one->incr)
 221             return 0;
 222         }
 223     }
 224   else
 225     name[0] = 0;
 226
 227   /* Parse IF clause. */
 228   if (lex_match_id ("IF"))
 229     {
 230       two->flags |= LPC_COND;
 231
 232       two->cond = expr_parse (PXP_BOOLEAN);
 233       if (!two->cond)
 234         return 0;
 235     }
 236
 237   if (token != '.')
 238     {
 239       lex_error (_("expecting end of command"));
 240       return 0;
 241     }
 242
 243   /* Find variable; create if necessary. */
 244   if (name[0])
 245     {
 246       two->index = dict_lookup_var (default_dict, name);
 247       if (!two->index)
 248         two->index = dict_create_var (default_dict, name, 0);
 249     }
 250
 251   /* Push on control stack. */
 252   two->ctl.down = ctl_stack;
 253   two->ctl.type = CST_LOOP;
 254   two->ctl.trns = (struct trns_header *) two;
 255   two->ctl.brk = NULL;
 256   ctl_stack = &two->ctl;
 257
 258   /* Dump out the transformations. */
 259   add_transformation ((struct trns_header *) one);
 260   add_transformation ((struct trns_header *) two);
 261
 262 #if DEBUGGING
 263   printf ("LOOP");
 264   if (two->flags & LPC_INDEX)
 265     printf ("(INDEX)");
 266   if (two->flags & LPC_COND)
 267     printf ("(IF)");
 268   printf ("\n");
 269 #endif
 270
 271   return 1;
 272 }
 273
 274 /* Parses the END LOOP command by passing the buck off to
 275    cmd_internal_end_loop(). */
 276 int
 277 cmd_end_loop (void)
 278 {
 279   if (!internal_cmd_end_loop ())
 280     {
 281       loop_3_trns_free ((struct trns_header *) thr);
 282       if (ctl_stack && ctl_stack->type == CST_LOOP)
 283         pop_ctl_stack ();
 284       return CMD_FAILURE;
 285     }
 286
 287   return CMD_SUCCESS;
 288 }
 289
 290 /* Parses the END LOOP command. */
 291 int
 292 internal_cmd_end_loop (void)
 293 {
 294   /* Backpatch pointer for BREAK commands. */
 295   struct break_trns *brk;
 296
 297   /* Allocate, initialize transformation to facilitate
 298      error-handling. */
 299   thr = xmalloc (sizeof *thr);
 300   thr->h.proc = loop_3_trns_proc;
 301   thr->h.free = loop_3_trns_free;
 302   thr->cond = NULL;
 303
 304   /* There must be a matching LOOP command. */
 305   if (!ctl_stack || ctl_stack->type != CST_LOOP)
 306     {
 307       msg (SE, _("There is no LOOP command that corresponds to this "
 308                  "END LOOP."));
 309       return 0;
 310     }
 311   thr->loop_start = ((struct loop_2_trns *) ctl_stack->trns)->h.index;
 312
 313   /* Parse the expression if any. */
 314   if (lex_match_id ("IF"))
 315     {
 316       thr->cond = expr_parse (PXP_BOOLEAN);
 317       if (!thr->cond)
 318         return 0;
 319     }
 320
 321   add_transformation ((struct trns_header *) thr);
 322
 323   /* Backpatch. */
 324   ((struct loop_2_trns *) ctl_stack->trns)->loop_term = n_trns;
 325   for (brk = ctl_stack->brk; brk; brk = brk->next)
 326     brk->loop_term = n_trns;
 327
 328   /* Pop off the top of stack. */
 329   ctl_stack = ctl_stack->down;
 330
 331 #if DEBUGGING
 332   printf ("END LOOP");
 333   if (thr->cond)
 334     printf ("(IF)");
 335   printf ("\n");
 336 #endif
 337
 338   return 1;
 339 }
 340
 341 /* Performs transformation 1. */
 342 static int
 343 loop_1_trns_proc (struct trns_header * trns, struct ccase * c,
 344                   int case_num)
 345 {
 346   struct loop_1_trns *one = (struct loop_1_trns *) trns;
 347   struct loop_2_trns *two = one->two;
 348
 349   two->pass = -1;
 350   if (two->flags & LPC_INDEX)
 351     {
 352       union value t1, t2, t3;
 353
 354       expr_evaluate (one->init, c, case_num, &t1);
 355       if (one->incr)
 356         expr_evaluate (one->incr, c, case_num, &t2);
 357       else
 358         t2.f = 1.0;
 359       expr_evaluate (one->term, c, case_num, &t3);
 360
 361       /* Even if the loop is never entered, force the index variable
 362          to assume the initial value. */
 363       c->data[two->index->fv].f = t1.f;
 364
 365       /* Throw out various pathological cases. */
 366       if (!finite (t1.f) || !finite (t2.f) || !finite (t3.f) || t2.f == 0.0)
 367         return two->loop_term;
 368       debug_printf (("LOOP %s=%g TO %g BY %g.\n", two->index->name,
 369                      t1.f, t3.f, t2.f));
 370       if (t2.f > 0.0)
 371         {
 372           /* Loop counts upward: I=1 TO 5 BY 1. */
 373           two->flags &= ~LPC_RINDEX;
 374
 375           /* incr>0 but init>term */
 376           if (t1.f > t3.f)
 377             return two->loop_term;
 378         }
 379       else
 380         {
 381           /* Loop counts downward: I=5 TO 1 BY -1. */
 382           two->flags |= LPC_RINDEX;
 383
 384           /* incr<0 but init<term */
 385           if (t1.f < t3.f)
 386             return two->loop_term;
 387         }
 388
 389       two->curr = t1.f;
 390       two->incr = t2.f;
 391       two->term = t3.f;
 392     }
 393
 394   return -1;
 395 }
 396
 397 /* Frees transformation 1. */
 398 static void
 399 loop_1_trns_free (struct trns_header * trns)
 400 {
 401   struct loop_1_trns *one = (struct loop_1_trns *) trns;
 402
 403   expr_free (one->init);
 404   expr_free (one->incr);
 405   expr_free (one->term);
 406 }
 407
 408 /* Performs transformation 2. */
 409 static int
 410 loop_2_trns_proc (struct trns_header * trns, struct ccase * c,
 411                   int case_num UNUSED)
 412 {
 413   struct loop_2_trns *two = (struct loop_2_trns *) trns;
 414
 415   /* MXLOOPS limiter. */
 416   if (two->flags == 0)
 417     {
 418       two->pass++;
 419       if (two->pass > get_mxloops() )
 420          return two->loop_term;
 421     }
 422
 423   /* Indexing clause limiter: counting downward. */
 424   if (two->flags & LPC_RINDEX)
 425     {
 426       /* Test if we're at the end of the looping. */
 427       if (two->curr < two->term)
 428         return two->loop_term;
 429
 430       /* Set the current value into the case. */
 431       c->data[two->index->fv].f = two->curr;
 432
 433       /* Decrement the current value. */
 434       two->curr += two->incr;
 435     }
 436   /* Indexing clause limiter: counting upward. */
 437   else if (two->flags & LPC_INDEX)
 438     {
 439       /* Test if we're at the end of the looping. */
 440       if (two->curr > two->term)
 441         return two->loop_term;
 442
 443       /* Set the current value into the case. */
 444       c->data[two->index->fv].f = two->curr;
 445
 446       /* Increment the current value. */
 447       two->curr += two->incr;
 448     }
 449
 450   /* Conditional clause limiter. */
 451   if ((two->flags & LPC_COND)
 452       && expr_evaluate (two->cond, c, case_num, NULL) != 1.0)
 453     return two->loop_term;
 454
 455   return -1;
 456 }
 457
 458 /* Frees transformation 2. */
 459 static void
 460 loop_2_trns_free (struct trns_header * trns)
 461 {
 462   struct loop_2_trns *two = (struct loop_2_trns *) trns;
 463
 464   expr_free (two->cond);
 465 }
 466
 467 /* Performs transformation 3. */
 468 static int
 469 loop_3_trns_proc (struct trns_header * trns, struct ccase * c,
 470                   int case_num)
 471 {
 472   struct loop_3_trns *thr = (struct loop_3_trns *) trns;
 473
 474   /* Note that it breaks out of the loop if the expression is true *or
 475      missing*.  This is conformant. */
 476   if (thr->cond && expr_evaluate (two->cond, c, case_num, NULL) != 0.0)
 477     return -1;
 478
 479   return thr->loop_start;
 480 }
 481
 482 /* Frees transformation 3. */
 483 static void
 484 loop_3_trns_free (struct trns_header * trns)
 485 {
 486   struct loop_3_trns *thr = (struct loop_3_trns *) trns;
 487
 488   expr_free (thr->cond);
 489 }
 490 \f
 491 /* BREAK. */
 492
 493 /* Parses the BREAK command. */
 494 int
 495 cmd_break (void)
 496 {
 497   /* Climbs down the stack to find a LOOP. */
 498   struct ctl_stmt *loop;
 499
 500   /* New transformation. */
 501   struct break_trns *t;
 502
 503   for (loop = ctl_stack; loop; loop = loop->down)
 504     if (loop->type == CST_LOOP)
 505       break;
 506   if (!loop)
 507     {
 508       msg (SE, _("This command may only appear enclosed in a LOOP/"
 509                  "END LOOP control structure."));
 510       return CMD_FAILURE;
 511     }
 512
 513   if (ctl_stack->type != CST_DO_IF)
 514     msg (SW, _("BREAK not enclosed in DO IF structure."));
 515
 516   t = xmalloc (sizeof *t);
 517   t->h.proc = break_trns_proc;
 518   t->h.free = NULL;
 519   t->next = loop->brk;
 520   loop->brk = t;
 521   add_transformation ((struct trns_header *) t);
 522
 523   return lex_end_of_command ();
 524 }
 525
 526 static int
 527 break_trns_proc (struct trns_header * trns, struct ccase * c UNUSED,
 528                  int case_num UNUSED)
 529 {
 530   return ((struct break_trns *) trns)->loop_term;
 531 }
 532 \f
 533 /* Control stack operations. */
 534
 535 /* Pops the top of stack element off of ctl_stack.  Does not
 536    check that ctl_stack is indeed non-NULL. */
 537 static void
 538 pop_ctl_stack (void)
 539 {
 540   switch (ctl_stack->type)
 541     {
 542     case CST_LOOP:
 543       {
 544         /* Pointer for chasing down and backpatching BREAKs. */
 545         struct break_trns *brk;
 546
 547         /* Terminate the loop. */
 548         thr = xmalloc (sizeof *thr);
 549         thr->h.proc = loop_3_trns_proc;
 550         thr->h.free = loop_3_trns_free;
 551         thr->cond = NULL;
 552         thr->loop_start = ((struct loop_2_trns *) ctl_stack->trns)->h.index;
 553         add_transformation ((struct trns_header *) thr);
 554
 555         /* Backpatch. */
 556         ((struct loop_2_trns *) ctl_stack->trns)->loop_term = n_trns;
 557         for (brk = ctl_stack->brk; brk; brk = brk->next)
 558           brk->loop_term = n_trns;
 559       }
 560       break;
 561     case CST_DO_IF:
 562       {
 563         /* List iterator. */
 564         struct do_if_trns *iter;
 565
 566         iter = ((struct do_if_trns *) ctl_stack->trns);
 567         for (;;)
 568           {
 569             if (iter->brk)
 570               iter->brk->dest = n_trns;
 571             iter->missing_jump = n_trns;
 572             if (iter->next)
 573               iter = iter->next;
 574             else
 575               break;
 576           }
 577         iter->false_jump = n_trns;
 578       }
 579       break;
 580     default:
 581       assert (0);
 582     }
 583   ctl_stack = ctl_stack->down;
 584 }
 585
 586 /* Checks for unclosed LOOPs and DO IFs and closes them out. */
 587 void
 588 discard_ctl_stack (void)
 589 {
 590   if (!ctl_stack)
 591     return;
 592   msg (SE, _("%s without %s."), ctl_stack->type == CST_LOOP ? "LOOP" : "DO IF",
 593        ctl_stack->type == CST_LOOP ? "END LOOP" : "END IF");
 594   while (ctl_stack)
 595     pop_ctl_stack ();
 596   ctl_stack = NULL;
 597 }