1 /* PSPP - computes sample statistics.
2 Copyright (C) 1997-9, 2000 Free Software Foundation, Inc.
3 Written by Ben Pfaff <blp@gnu.org>.
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.
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.
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
33 #include "debug-print.h"
38 Each loop causes 3 different transformations to be output. The
39 first two are output when the LOOP command is encountered; the last
40 is output when the END LOOP command is encountered.
42 The first to be output resets the pass number in the second
43 transformation to -1. This ensures that the pass number is set to
44 -1 every time the loop is encountered, before the first iteration.
46 The second transformation increments the pass number. If there is
47 no indexing or test clause on either LOOP or END LOOP, then the
48 pass number is checked against MXLOOPS and control may pass out of
49 the loop; otherwise the indexing or test clause(s) on LOOP are
50 checked, and again control may pass out of the loop.
52 After the second transformation the body of the loop is executed.
54 The last transformation checks the test clause if present and
55 either jumps back up to the second transformation or terminates the
58 Flow of control: (The characters ^V<> represents arrows.)
60 1. LOOP (sets pass # to -1)
63 >>2. LOOP (increment pass number)
64 ^ (test optional indexing clause)
65 ^ (test optional IF clause)
66 ^ if we need another trip if we're done with the loop>>V
69 ^ *. execute loop body V
71 ^ . (any number of transformations) V
74 ^ 3. END LOOP (test optional IF clause) V
75 ^<<<<if we need another trip if we're done with the loop>>V
78 *. transformations after loop body<<<<<<<<<<<<<<<<<<<<<<<<<<<
83 /* Types of limits on loop execution. */
86 LPC_INDEX = 001, /* Limited by indexing clause. */
87 LPC_COND = 002, /* Limited by IF clause. */
88 LPC_RINDEX = 004 /* Indexing clause counts downward, at least
89 for this pass thru the loop. */
92 /* LOOP transformation 1. */
97 struct loop_2_trns *two; /* Allows modification of associated
98 second transformation. */
100 struct expression *init; /* Starting index. */
101 struct expression *incr; /* Index increment. */
102 struct expression *term; /* Terminal index. */
105 /* LOOP transformation 2. */
108 struct trns_header h;
110 struct ctl_stmt ctl; /* Nesting control info. */
112 int flags; /* Types of limits on loop execution. */
113 int pass; /* Number of passes thru the loop so far. */
115 struct variable *index; /* Index variable. */
116 double curr; /* Current index. */
117 double incr; /* Increment. */
118 double term; /* Terminal index. */
120 struct expression *cond; /* Optional IF condition when non-NULL. */
122 int loop_term; /* 1+(t_trns[] index of transformation 3);
123 backpatched in by END LOOP. */
126 /* LOOP transformation 3. (Actually output by END LOOP.) */
129 struct trns_header h;
131 struct expression *cond; /* Optional IF condition when non-NULL. */
133 int loop_start; /* t_trns[] index of transformation 2. */
136 /* LOOP transformations being created. */
137 static struct loop_1_trns *one;
138 static struct loop_2_trns *two;
139 static struct loop_3_trns *thr;
141 static int internal_cmd_loop (void);
142 static int internal_cmd_end_loop (void);
143 static int break_trns_proc (struct trns_header *, struct ccase *);
144 static int loop_1_trns_proc (struct trns_header *, struct ccase *);
145 static void loop_1_trns_free (struct trns_header *);
146 static int loop_2_trns_proc (struct trns_header *, struct ccase *);
147 static void loop_2_trns_free (struct trns_header *);
148 static int loop_3_trns_proc (struct trns_header *, struct ccase *);
149 static void loop_3_trns_free (struct trns_header *);
150 static void pop_ctl_stack (void);
154 /* Parses a LOOP command. Passes the real work off to
155 internal_cmd_loop(). */
159 if (!internal_cmd_loop ())
161 loop_1_trns_free ((struct trns_header *) one);
162 loop_2_trns_free ((struct trns_header *) two);
169 /* Parses a LOOP command, returns success. */
171 internal_cmd_loop (void)
173 /* Name of indexing variable if applicable. */
176 lex_match_id ("LOOP");
178 /* Create and initialize transformations to facilitate
180 two = xmalloc (sizeof *two);
181 two->h.proc = loop_2_trns_proc;
182 two->h.free = loop_2_trns_free;
186 one = xmalloc (sizeof *one);
187 one->h.proc = loop_1_trns_proc;
188 one->h.free = loop_1_trns_free;
189 one->init = one->incr = one->term = NULL;
192 /* Parse indexing clause. */
193 if (token == T_ID && lex_look_ahead () == '=')
195 struct variable *v = dict_lookup_var (default_dict, tokid);
197 two->flags |= LPC_INDEX;
199 if (v && v->type == ALPHA)
201 msg (SE, _("The index variable may not be a string variable."));
204 strcpy (name, tokid);
207 assert (token == '=');
210 one->init = expr_parse (PXP_NUMERIC);
214 if (!lex_force_match (T_TO))
216 expr_free (one->init);
219 one->term = expr_parse (PXP_NUMERIC);
222 expr_free (one->init);
226 if (lex_match (T_BY))
228 one->incr = expr_parse (PXP_NUMERIC);
236 /* Parse IF clause. */
237 if (lex_match_id ("IF"))
239 two->flags |= LPC_COND;
241 two->cond = expr_parse (PXP_BOOLEAN);
248 lex_error (_("expecting end of command"));
252 /* Find variable; create if necessary. */
255 two->index = dict_lookup_var (default_dict, name);
258 two->index = dict_create_var (default_dict, name, 0);
260 envector (two->index);
265 /* Push on control stack. */
266 two->ctl.down = ctl_stack;
267 two->ctl.type = CST_LOOP;
268 two->ctl.trns = (struct trns_header *) two;
270 ctl_stack = &two->ctl;
272 /* Dump out the transformations. */
273 add_transformation ((struct trns_header *) one);
274 add_transformation ((struct trns_header *) two);
278 if (two->flags & LPC_INDEX)
280 if (two->flags & LPC_COND)
288 /* Parses the END LOOP command by passing the buck off to
289 cmd_internal_end_loop(). */
293 if (!internal_cmd_end_loop ())
295 loop_3_trns_free ((struct trns_header *) thr);
296 if (ctl_stack && ctl_stack->type == CST_LOOP)
304 /* Parses the END LOOP command. */
306 internal_cmd_end_loop (void)
308 /* Backpatch pointer for BREAK commands. */
309 struct break_trns *brk;
311 /* Allocate, initialize transformation to facilitate
313 thr = xmalloc (sizeof *thr);
314 thr->h.proc = loop_3_trns_proc;
315 thr->h.free = loop_3_trns_free;
318 /* There must be a matching LOOP command. */
319 if (!ctl_stack || ctl_stack->type != CST_LOOP)
321 msg (SE, _("There is no LOOP command that corresponds to this "
325 thr->loop_start = ((struct loop_2_trns *) ctl_stack->trns)->h.index;
327 /* Parse the expression if any. */
328 if (lex_match_id ("IF"))
330 thr->cond = expr_parse (PXP_BOOLEAN);
335 add_transformation ((struct trns_header *) thr);
338 ((struct loop_2_trns *) ctl_stack->trns)->loop_term = n_trns;
339 for (brk = ctl_stack->brk; brk; brk = brk->next)
340 brk->loop_term = n_trns;
342 /* Pop off the top of stack. */
343 ctl_stack = ctl_stack->down;
355 /* Performs transformation 1. */
357 loop_1_trns_proc (struct trns_header * trns, struct ccase * c)
359 struct loop_1_trns *one = (struct loop_1_trns *) trns;
360 struct loop_2_trns *two = one->two;
363 if (two->flags & LPC_INDEX)
365 union value t1, t2, t3;
367 expr_evaluate (one->init, c, &t1);
369 expr_evaluate (one->incr, c, &t2);
372 expr_evaluate (one->term, c, &t3);
374 /* Even if the loop is never entered, force the index variable
375 to assume the initial value. */
376 c->data[two->index->fv].f = t1.f;
378 /* Throw out various pathological cases. */
379 if (!finite (t1.f) || !finite (t2.f) || !finite (t3.f)
380 || approx_eq (t2.f, 0.0))
381 return two->loop_term;
382 debug_printf (("LOOP %s=%g TO %g BY %g.\n", two->index->name,
386 /* Loop counts upward: I=1 TO 5 BY 1. */
387 two->flags &= ~LPC_RINDEX;
389 /* incr>0 but init>term */
390 if (approx_gt (t1.f, t3.f))
391 return two->loop_term;
395 /* Loop counts downward: I=5 TO 1 BY -1. */
396 two->flags |= LPC_RINDEX;
398 /* incr<0 but init<term */
399 if (approx_lt (t1.f, t3.f))
400 return two->loop_term;
411 /* Frees transformation 1. */
413 loop_1_trns_free (struct trns_header * trns)
415 struct loop_1_trns *one = (struct loop_1_trns *) trns;
417 expr_free (one->init);
418 expr_free (one->incr);
419 expr_free (one->term);
422 /* Performs transformation 2. */
424 loop_2_trns_proc (struct trns_header * trns, struct ccase * c)
426 struct loop_2_trns *two = (struct loop_2_trns *) trns;
428 /* MXLOOPS limiter. */
432 if (two->pass > set_mxloops)
433 return two->loop_term;
436 /* Indexing clause limiter: counting downward. */
437 if (two->flags & LPC_RINDEX)
439 /* Test if we're at the end of the looping. */
440 if (approx_lt (two->curr, two->term))
441 return two->loop_term;
443 /* Set the current value into the case. */
444 c->data[two->index->fv].f = two->curr;
446 /* Decrement the current value. */
447 two->curr += two->incr;
449 /* Indexing clause limiter: counting upward. */
450 else if (two->flags & LPC_INDEX)
452 /* Test if we're at the end of the looping. */
453 if (approx_gt (two->curr, two->term))
454 return two->loop_term;
456 /* Set the current value into the case. */
457 c->data[two->index->fv].f = two->curr;
459 /* Increment the current value. */
460 two->curr += two->incr;
463 /* Conditional clause limiter. */
464 if ((two->flags & LPC_COND)
465 && expr_evaluate (two->cond, c, NULL) != 1.0)
466 return two->loop_term;
471 /* Frees transformation 2. */
473 loop_2_trns_free (struct trns_header * trns)
475 struct loop_2_trns *two = (struct loop_2_trns *) trns;
477 expr_free (two->cond);
480 /* Performs transformation 3. */
482 loop_3_trns_proc (struct trns_header * trns, struct ccase * c)
484 struct loop_3_trns *thr = (struct loop_3_trns *) trns;
486 /* Note that it breaks out of the loop if the expression is true *or
487 missing*. This is conformant. */
488 if (thr->cond && expr_evaluate (two->cond, c, NULL) != 0.0)
491 return thr->loop_start;
494 /* Frees transformation 3. */
496 loop_3_trns_free (struct trns_header * trns)
498 struct loop_3_trns *thr = (struct loop_3_trns *) trns;
500 expr_free (thr->cond);
505 /* Parses the BREAK command. */
509 /* Climbs down the stack to find a LOOP. */
510 struct ctl_stmt *loop;
512 /* New transformation. */
513 struct break_trns *t;
515 lex_match_id ("BREAK");
517 for (loop = ctl_stack; loop; loop = loop->down)
518 if (loop->type == CST_LOOP)
522 msg (SE, _("This command may only appear enclosed in a LOOP/"
523 "END LOOP control structure."));
527 if (ctl_stack->type != CST_DO_IF)
528 msg (SW, _("BREAK not enclosed in DO IF structure."));
530 t = xmalloc (sizeof *t);
531 t->h.proc = break_trns_proc;
535 add_transformation ((struct trns_header *) t);
537 return lex_end_of_command ();
541 break_trns_proc (struct trns_header * trns, struct ccase * c UNUSED)
543 return ((struct break_trns *) trns)->loop_term;
546 /* Control stack operations. */
548 /* Pops the top of stack element off of ctl_stack. Does not
549 check that ctl_stack is indeed non-NULL. */
553 switch (ctl_stack->type)
557 /* Pointer for chasing down and backpatching BREAKs. */
558 struct break_trns *brk;
560 /* Terminate the loop. */
561 thr = xmalloc (sizeof *thr);
562 thr->h.proc = loop_3_trns_proc;
563 thr->h.free = loop_3_trns_free;
565 thr->loop_start = ((struct loop_2_trns *) ctl_stack->trns)->h.index;
566 add_transformation ((struct trns_header *) thr);
569 ((struct loop_2_trns *) ctl_stack->trns)->loop_term = n_trns;
570 for (brk = ctl_stack->brk; brk; brk = brk->next)
571 brk->loop_term = n_trns;
577 struct do_if_trns *iter;
579 iter = ((struct do_if_trns *) ctl_stack->trns);
583 iter->brk->dest = n_trns;
584 iter->missing_jump = n_trns;
590 iter->false_jump = n_trns;
596 ctl_stack = ctl_stack->down;
599 /* Checks for unclosed LOOPs and DO IFs and closes them out. */
601 discard_ctl_stack (void)
605 msg (SE, _("%s without %s."), ctl_stack->type == CST_LOOP ? "LOOP" : "DO IF",
606 ctl_stack->type == CST_LOOP ? "END LOOP" : "END IF");