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
34 /*#define DEBUGGING 1*/
35 #include "debug-print.h"
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.
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.
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.
54 After the second transformation the body of the loop is executed.
56 The last transformation checks the test clause if present and
57 either jumps back up to the second transformation or terminates the
60 Flow of control: (The characters ^V<> represents arrows.)
62 1. LOOP (sets pass # to -1)
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
71 ^ *. execute loop body V
73 ^ . (any number of transformations) V
76 ^ 3. END LOOP (test optional IF clause) V
77 ^<<<<if we need another trip if we're done with the loop>>V
80 *. transformations after loop body<<<<<<<<<<<<<<<<<<<<<<<<<<<
85 /* Types of limits on loop execution. */
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. */
94 /* LOOP transformation 1. */
99 struct loop_2_trns *two; /* Allows modification of associated
100 second transformation. */
102 struct expression *init; /* Starting index. */
103 struct expression *incr; /* Index increment. */
104 struct expression *term; /* Terminal index. */
107 /* LOOP transformation 2. */
110 struct trns_header h;
112 struct ctl_stmt ctl; /* Nesting control info. */
114 int flags; /* Types of limits on loop execution. */
115 int pass; /* Number of passes thru the loop so far. */
117 struct variable *index; /* Index variable. */
118 double curr; /* Current index. */
119 double incr; /* Increment. */
120 double term; /* Terminal index. */
122 struct expression *cond; /* Optional IF condition when non-NULL. */
124 int loop_term; /* 1+(t_trns[] index of transformation 3);
125 backpatched in by END LOOP. */
128 /* LOOP transformation 3. (Actually output by END LOOP.) */
131 struct trns_header h;
133 struct expression *cond; /* Optional IF condition when non-NULL. */
135 int loop_start; /* t_trns[] index of transformation 2. */
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;
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);
156 /* Parses a LOOP command. Passes the real work off to
157 internal_cmd_loop(). */
161 if (!internal_cmd_loop ())
163 loop_1_trns_free ((struct trns_header *) one);
164 loop_2_trns_free ((struct trns_header *) two);
171 /* Parses a LOOP command, returns success. */
173 internal_cmd_loop (void)
175 /* Name of indexing variable if applicable. */
178 lex_match_id ("LOOP");
180 /* Create and initialize transformations to facilitate
182 two = xmalloc (sizeof *two);
183 two->h.proc = loop_2_trns_proc;
184 two->h.free = loop_2_trns_free;
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;
194 /* Parse indexing clause. */
195 if (token == T_ID && lex_look_ahead () == '=')
197 struct variable *v = find_variable (tokid);
199 two->flags |= LPC_INDEX;
201 if (v && v->type == ALPHA)
203 msg (SE, _("The index variable may not be a string variable."));
206 strcpy (name, tokid);
209 assert (token == '=');
212 one->init = expr_parse (PXP_NUMERIC);
216 if (!lex_force_match (T_TO))
218 expr_free (one->init);
221 one->term = expr_parse (PXP_NUMERIC);
224 expr_free (one->init);
228 if (lex_match (T_BY))
230 one->incr = expr_parse (PXP_NUMERIC);
238 /* Parse IF clause. */
239 if (lex_match_id ("IF"))
241 two->flags |= LPC_COND;
243 two->cond = expr_parse (PXP_BOOLEAN);
250 lex_error (_("expecting end of command"));
254 /* Find variable; create if necessary. */
257 two->index = find_variable (name);
260 two->index = force_create_variable (&default_dict, name, NUMERIC, 0);
262 envector (two->index);
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;
272 ctl_stack = &two->ctl;
274 /* Dump out the transformations. */
275 add_transformation ((struct trns_header *) one);
276 add_transformation ((struct trns_header *) two);
280 if (two->flags & LPC_INDEX)
282 if (two->flags & LPC_COND)
290 /* Parses the END LOOP command by passing the buck off to
291 cmd_internal_end_loop(). */
295 if (!internal_cmd_end_loop ())
297 loop_3_trns_free ((struct trns_header *) thr);
298 if (ctl_stack && ctl_stack->type == CST_LOOP)
306 /* Parses the END LOOP command. */
308 internal_cmd_end_loop (void)
310 /* Backpatch pointer for BREAK commands. */
311 struct break_trns *brk;
313 /* Allocate, initialize transformation to facilitate
315 thr = xmalloc (sizeof *thr);
316 thr->h.proc = loop_3_trns_proc;
317 thr->h.free = loop_3_trns_free;
320 /* There must be a matching LOOP command. */
321 if (!ctl_stack || ctl_stack->type != CST_LOOP)
323 msg (SE, _("There is no LOOP command that corresponds to this "
327 thr->loop_start = ((struct loop_2_trns *) ctl_stack->trns)->h.index;
329 /* Parse the expression if any. */
330 if (lex_match_id ("IF"))
332 thr->cond = expr_parse (PXP_BOOLEAN);
337 add_transformation ((struct trns_header *) thr);
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;
344 /* Pop off the top of stack. */
345 ctl_stack = ctl_stack->down;
357 /* Performs transformation 1. */
359 loop_1_trns_proc (struct trns_header * trns, struct ccase * c)
361 struct loop_1_trns *one = (struct loop_1_trns *) trns;
362 struct loop_2_trns *two = one->two;
365 if (two->flags & LPC_INDEX)
367 union value t1, t2, t3;
369 expr_evaluate (one->init, c, &t1);
371 expr_evaluate (one->incr, c, &t2);
374 expr_evaluate (one->term, c, &t3);
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;
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,
388 /* Loop counts upward: I=1 TO 5 BY 1. */
389 two->flags &= ~LPC_RINDEX;
391 /* incr>0 but init>term */
392 if (approx_gt (t1.f, t3.f))
393 return two->loop_term;
397 /* Loop counts downward: I=5 TO 1 BY -1. */
398 two->flags |= LPC_RINDEX;
400 /* incr<0 but init<term */
401 if (approx_lt (t1.f, t3.f))
402 return two->loop_term;
413 /* Frees transformation 1. */
415 loop_1_trns_free (struct trns_header * trns)
417 struct loop_1_trns *one = (struct loop_1_trns *) trns;
419 expr_free (one->init);
420 expr_free (one->incr);
421 expr_free (one->term);
424 /* Performs transformation 2. */
426 loop_2_trns_proc (struct trns_header * trns, struct ccase * c)
428 struct loop_2_trns *two = (struct loop_2_trns *) trns;
430 /* MXLOOPS limiter. */
434 if (two->pass > set_mxloops)
435 return two->loop_term;
438 /* Indexing clause limiter: counting downward. */
439 if (two->flags & LPC_RINDEX)
441 /* Test if we're at the end of the looping. */
442 if (approx_lt (two->curr, two->term))
443 return two->loop_term;
445 /* Set the current value into the case. */
446 c->data[two->index->fv].f = two->curr;
448 /* Decrement the current value. */
449 two->curr += two->incr;
451 /* Indexing clause limiter: counting upward. */
452 else if (two->flags & LPC_INDEX)
454 /* Test if we're at the end of the looping. */
455 if (approx_gt (two->curr, two->term))
456 return two->loop_term;
458 /* Set the current value into the case. */
459 c->data[two->index->fv].f = two->curr;
461 /* Increment the current value. */
462 two->curr += two->incr;
465 /* Conditional clause limiter. */
466 if ((two->flags & LPC_COND)
467 && expr_evaluate (two->cond, c, NULL) != 1.0)
468 return two->loop_term;
473 /* Frees transformation 2. */
475 loop_2_trns_free (struct trns_header * trns)
477 struct loop_2_trns *two = (struct loop_2_trns *) trns;
479 expr_free (two->cond);
482 /* Performs transformation 3. */
484 loop_3_trns_proc (struct trns_header * trns, struct ccase * c)
486 struct loop_3_trns *thr = (struct loop_3_trns *) trns;
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)
493 return thr->loop_start;
496 /* Frees transformation 3. */
498 loop_3_trns_free (struct trns_header * trns)
500 struct loop_3_trns *thr = (struct loop_3_trns *) trns;
502 expr_free (thr->cond);
507 /* Parses the BREAK command. */
511 /* Climbs down the stack to find a LOOP. */
512 struct ctl_stmt *loop;
514 /* New transformation. */
515 struct break_trns *t;
517 lex_match_id ("BREAK");
519 for (loop = ctl_stack; loop; loop = loop->down)
520 if (loop->type == CST_LOOP)
524 msg (SE, _("This command may only appear enclosed in a LOOP/"
525 "END LOOP control structure."));
529 if (ctl_stack->type != CST_DO_IF)
530 msg (SW, _("BREAK not enclosed in DO IF structure."));
532 t = xmalloc (sizeof *t);
533 t->h.proc = break_trns_proc;
537 add_transformation ((struct trns_header *) t);
539 return lex_end_of_command ();
543 break_trns_proc (struct trns_header * trns, struct ccase * c unused)
545 return ((struct break_trns *) trns)->loop_term;
548 /* Control stack operations. */
550 /* Pops the top of stack element off of ctl_stack. Does not
551 check that ctl_stack is indeed non-NULL. */
555 switch (ctl_stack->type)
559 /* Pointer for chasing down and backpatching BREAKs. */
560 struct break_trns *brk;
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;
567 thr->loop_start = ((struct loop_2_trns *) ctl_stack->trns)->h.index;
568 add_transformation ((struct trns_header *) thr);
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;
579 struct do_if_trns *iter;
581 iter = ((struct do_if_trns *) ctl_stack->trns);
585 iter->brk->dest = n_trns;
586 iter->missing_jump = n_trns;
592 iter->false_jump = n_trns;
598 ctl_stack = ctl_stack->down;
601 /* Checks for unclosed LOOPs and DO IFs and closes them out. */
603 discard_ctl_stack (void)
607 msg (SE, _("%s without %s."), ctl_stack->type == CST_LOOP ? "LOOP" : "DO IF",
608 ctl_stack->type == CST_LOOP ? "END LOOP" : "END IF");