Fix assertion for proper Huffman merge pattern: 0 == 1 modulo 1.
[pspp] / 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 "expr.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 (EXPR_NUMERIC);
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 (EXPR_NUMERIC);
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 (EXPR_NUMERIC);
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 (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 (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       union value t1, t2, t3;
339
340       expr_evaluate (one->init, c, case_num, &t1);
341       if (one->incr)
342         expr_evaluate (one->incr, c, case_num, &t2);
343       else
344         t2.f = 1.0;
345       expr_evaluate (one->term, c, case_num, &t3);
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.f;
350
351       /* Throw out various pathological cases. */
352       if (!finite (t1.f) || !finite (t2.f) || !finite (t3.f) || t2.f == 0.0)
353         return two->loop_term;
354       debug_printf (("LOOP %s=%g TO %g BY %g.\n", two->index->name,
355                      t1.f, t3.f, t2.f));
356       if (t2.f > 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.f > t3.f)
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.f < t3.f)
372             return two->loop_term;
373         }
374
375       two->curr = t1.f;
376       two->incr = t2.f;
377       two->term = t3.f;
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 (two->cond, c, case_num, NULL) != 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 (two->cond, c, case_num, NULL) != 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 }