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