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