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