d26bf1ed2dd441d8f1406353b75b29b4105d227b
[pspp-builds.git] / src / compute.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 <assert.h>
22 #include <stdlib.h>
23 #include "alloc.h"
24 #include "command.h"
25 #include "error.h"
26 #include "expr.h"
27 #include "lexer.h"
28 #include "misc.h"
29 #include "str.h"
30 #include "var.h"
31
32 struct compute_trns;
33 struct lvalue;
34
35 /* Target of a COMPUTE or IF assignment, either a variable or a
36    vector element. */
37 static struct lvalue *lvalue_parse (void);
38 static int lvalue_get_type (const struct lvalue *);
39 static int lvalue_is_vector (const struct lvalue *);
40 static void lvalue_finalize (struct lvalue *,
41                              struct compute_trns *);
42 static void lvalue_destroy (struct lvalue *);
43
44 /* COMPUTE and IF transformation. */
45 struct compute_trns
46   {
47     struct trns_header h;
48
49     /* Test expression (IF only). */
50     struct expression *test;     /* Test expression. */
51
52     /* Variable lvalue, if variable != NULL. */
53     struct variable *variable;   /* Destination variable, if any. */
54     int fv;                      /* `value' index of destination variable. */
55     int width;                   /* Lvalue string width; 0=numeric. */
56
57     /* Vector lvalue, if vector != NULL. */
58     const struct vector *vector; /* Destination vector, if any. */
59     struct expression *element;  /* Destination vector element expr. */
60
61     /* Rvalue. */
62     struct expression *rvalue;   /* Rvalue expression. */
63   };
64
65 static int parse_rvalue_expression (struct compute_trns *,
66                                     const struct lvalue *);
67 static struct compute_trns *compute_trns_create (void);
68 static void compute_trns_free (struct trns_header *);
69 \f
70 /* COMPUTE. */
71
72 int
73 cmd_compute (void)
74 {
75   struct lvalue *lvalue = NULL;
76   struct compute_trns *compute = NULL;
77
78   lex_match_id ("COMPUTE");
79
80   lvalue = lvalue_parse ();
81   if (lvalue == NULL)
82     goto fail;
83
84   compute = compute_trns_create ();
85
86   if (!lex_force_match ('=') || !parse_rvalue_expression (compute, lvalue))
87     goto fail;
88
89   lvalue_finalize (lvalue, compute);
90
91   add_transformation (&compute->h);
92
93   return CMD_SUCCESS;
94
95  fail:
96   lvalue_destroy (lvalue);
97   if (compute != NULL) 
98     {
99       compute_trns_free (&compute->h);
100       free (compute); 
101     }
102   return CMD_FAILURE;
103 }
104 \f
105 /* Transformation functions. */
106
107 static int
108 compute_num (struct trns_header *compute_, struct ccase *c)
109 {
110   struct compute_trns *compute = (struct compute_trns *) compute_;
111
112   if (compute->test == NULL
113       || expr_evaluate (compute->test, c, NULL) == 1.0) 
114     {
115       expr_evaluate (compute->rvalue, c, &c->data[compute->fv]); 
116     }
117   
118   return -1;
119 }
120
121 static int
122 compute_num_vec (struct trns_header *compute_, struct ccase *c)
123 {
124   struct compute_trns *compute = (struct compute_trns *) compute_;
125
126   if (compute->test == NULL
127       || expr_evaluate (compute->test, c, NULL) == 1.0) 
128     {
129       /* Index into the vector. */
130       union value index;
131
132       /* Rounded index value. */
133       int rindx;
134
135       expr_evaluate (compute->element, c, &index);
136       rindx = floor (index.f + EPSILON);
137       if (index.f == SYSMIS || rindx < 1 || rindx > compute->vector->cnt)
138         {
139           if (index.f == SYSMIS)
140             msg (SW, _("When executing COMPUTE: SYSMIS is not a valid value as "
141                        "an index into vector %s."), compute->vector->name);
142           else
143             msg (SW, _("When executing COMPUTE: %g is not a valid value as "
144                        "an index into vector %s."),
145                  index.f, compute->vector->name);
146           return -1;
147         }
148       expr_evaluate (compute->rvalue, c,
149                      &c->data[compute->vector->var[rindx - 1]->fv]); 
150     }
151   
152   return -1;
153 }
154
155 static int
156 compute_str (struct trns_header *compute_, struct ccase *c)
157 {
158   struct compute_trns *compute = (struct compute_trns *) compute_;
159
160   if (compute->test == NULL
161       || expr_evaluate (compute->test, c, NULL) == 1.0) 
162     {
163       /* Temporary storage for string expression return value. */
164       union value v;
165
166       expr_evaluate (compute->rvalue, c, &v);
167       st_bare_pad_len_copy (c->data[compute->fv].s, &v.c[1], compute->width,
168                             v.c[0]); 
169     }
170   
171   return -1;
172 }
173
174 static int
175 compute_str_vec (struct trns_header *compute_, struct ccase *c)
176 {
177   struct compute_trns *compute = (struct compute_trns *) compute_;
178
179   if (compute->test == NULL
180       || expr_evaluate (compute->test, c, NULL) == 1.0) 
181     {
182       /* Temporary storage for string expression return value. */
183       union value v;
184
185       /* Index into the vector. */
186       union value index;
187
188       /* Rounded index value. */
189       int rindx;
190
191       /* Variable reference by indexed vector. */
192       struct variable *vr;
193
194       expr_evaluate (compute->element, c, &index);
195       rindx = floor (index.f + EPSILON);
196       if (index.f == SYSMIS || rindx < 1 || rindx > compute->vector->cnt)
197         {
198           if (index.f == SYSMIS)
199             msg (SW, _("When executing COMPUTE: SYSMIS is not a valid "
200                        "value as an index into vector %s."),
201                  compute->vector->name);
202           else
203             msg (SW, _("When executing COMPUTE: %g is not a valid value as "
204                        "an index into vector %s."),
205                  index.f, compute->vector->name);
206           return -1;
207         }
208
209       expr_evaluate (compute->rvalue, c, &v);
210       vr = compute->vector->var[rindx - 1];
211       st_bare_pad_len_copy (c->data[vr->fv].s, &v.c[1], vr->width, v.c[0]); 
212     }
213   
214   return -1;
215 }
216 \f
217 /* IF. */
218
219 int
220 cmd_if (void)
221 {
222   struct compute_trns *compute = NULL;
223   struct lvalue *lvalue = NULL;
224
225   lex_match_id ("IF");
226   compute = compute_trns_create ();
227
228   /* Test expression. */
229   compute->test = expr_parse (PXP_BOOLEAN);
230   if (compute->test == NULL)
231     goto fail;
232
233   /* Lvalue variable. */
234   lvalue = lvalue_parse ();
235   if (lvalue == NULL)
236     goto fail;
237
238   /* Rvalue expression. */
239   if (!lex_force_match ('=') || !parse_rvalue_expression (compute, lvalue))
240     goto fail;
241
242   lvalue_finalize (lvalue, compute);
243
244   add_transformation (&compute->h);
245
246   return CMD_SUCCESS;
247
248  fail:
249   lvalue_destroy (lvalue);
250   if (compute != NULL) 
251     {
252       compute_trns_free (&compute->h);
253       free (compute); 
254     }
255   return CMD_FAILURE;
256 }
257 \f
258 /* Code common to COMPUTE and IF. */
259
260 /* Checks for type mismatches on transformation C.  Also checks for
261    command terminator, sets the case-handling proc from the array
262    passed. */
263 static int
264 parse_rvalue_expression (struct compute_trns *compute,
265                          const struct lvalue *lvalue)
266 {
267   int type = lvalue_get_type (lvalue);
268   int vector = lvalue_is_vector (lvalue);
269
270   assert (type == NUMERIC || type == ALPHA);
271
272   compute->rvalue = expr_parse (type == ALPHA ? PXP_STRING : PXP_NUMERIC);
273   if (compute->rvalue == NULL)
274     return 0;
275
276   if (type == NUMERIC)
277     compute->h.proc = vector ? compute_num_vec : compute_num;
278   else
279     compute->h.proc = vector ? compute_str_vec : compute_str;
280
281   if (token != '.')
282     {
283       lex_error (_("expecting end of command"));
284       return 0;
285     }
286   
287   return 1;
288 }
289
290 /* Returns a new struct compute_trns after initializing its fields. */
291 static struct compute_trns *
292 compute_trns_create (void)
293 {
294   struct compute_trns *compute = xmalloc (sizeof *compute);
295   compute->h.proc = NULL;
296   compute->h.free = compute_trns_free;
297   compute->test = NULL;
298   compute->variable = NULL;
299   compute->vector = NULL;
300   compute->element = NULL;
301   compute->rvalue = NULL;
302   return compute;
303 }
304
305 /* Deletes all the fields in COMPUTE. */
306 static void
307 compute_trns_free (struct trns_header *compute_)
308 {
309   struct compute_trns *compute = (struct compute_trns *) compute_;
310
311   expr_free (compute->test);
312   expr_free (compute->element);
313   expr_free (compute->rvalue);
314 }
315 \f
316 struct lvalue
317   {
318     char var_name[9];            /* Destination variable name, or "". */
319     const struct vector *vector; /* Destination vector, if any, or NULL. */
320     struct expression *element;  /* Destination vector element, or NULL. */
321   };
322
323 static struct lvalue *
324 lvalue_parse (void) 
325 {
326   struct lvalue *lvalue;
327
328   lvalue = xmalloc (sizeof *lvalue);
329   lvalue->var_name[0] = '\0';
330   lvalue->vector = NULL;
331   lvalue->element = NULL;
332
333   if (!lex_force_id ())
334     goto lossage;
335   
336   if (lex_look_ahead () == '(')
337     {
338       /* Vector. */
339       lvalue->vector = dict_lookup_vector (default_dict, tokid);
340       if (lvalue->vector == NULL)
341         {
342           msg (SE, _("There is no vector named %s."), tokid);
343           goto lossage;
344         }
345
346       /* Vector element. */
347       lex_get ();
348       if (!lex_force_match ('('))
349         goto lossage;
350       lvalue->element = expr_parse (PXP_NUMERIC);
351       if (lvalue->element == NULL)
352         goto lossage;
353       if (!lex_force_match (')'))
354         goto lossage;
355     }
356   else
357     {
358       /* Variable name. */
359       strncpy (lvalue->var_name, tokid, 8);
360       lvalue->var_name[8] = '\0';
361       lex_get ();
362     }
363   return lvalue;
364
365  lossage:
366   lvalue_destroy (lvalue);
367   return NULL;
368 }
369
370 static int
371 lvalue_get_type (const struct lvalue *lvalue) 
372 {
373   if (lvalue->vector == NULL) 
374     {
375       struct variable *var
376         = dict_lookup_var (default_dict, lvalue->var_name);
377       if (var == NULL)
378         return NUMERIC;
379       else
380         return var->type;
381     }
382   else 
383     return lvalue->vector->var[0]->type;
384 }
385
386 static int
387 lvalue_is_vector (const struct lvalue *lvalue) 
388 {
389   return lvalue->vector != NULL;
390 }
391
392 static void
393 lvalue_finalize (struct lvalue *lvalue,
394                  struct compute_trns *compute) 
395 {
396   if (lvalue->vector == NULL)
397     {
398       compute->variable = dict_lookup_var (default_dict, lvalue->var_name);
399       if (compute->variable == NULL)
400         {
401           struct fmt_spec input_spec = { 0,8,2 };
402           compute->variable = dict_create_var_assert (default_dict,
403                                                       lvalue->var_name, 0);
404
405           convert_fmt_ItoO (&input_spec, &compute->variable->print);
406           compute->variable->write = compute->variable->print;
407         }
408
409       compute->fv = compute->variable->fv;
410       compute->width = compute->variable->width;
411
412       
413
414       /* Goofy behavior, but compatible: Turn off LEAVE. */
415       if (dict_class_from_id (compute->variable->name) != DC_SCRATCH)
416         compute->variable->reinit = 1;
417     }
418   else 
419     {
420       compute->vector = lvalue->vector;
421       compute->element = lvalue->element;
422       lvalue->element = NULL;
423     }
424
425   lvalue_destroy (lvalue);
426 }
427
428 static void 
429 lvalue_destroy (struct lvalue *lvalue) 
430 {
431   expr_free (lvalue->element);
432   free (lvalue);
433 }
434 \f
435 /* EVALUATE. */
436
437 int
438 cmd_evaluate (void)
439 {
440   struct expression *expr;
441
442   lex_match_id ("EVALUATE");
443   expr = expr_parse (PXP_DUMP);
444   if (!expr)
445     return CMD_FAILURE;
446
447   expr_free (expr);
448   if (token != '.')
449     {
450       msg (SE, _("Extra characters after expression."));
451       return CMD_FAILURE;
452     }
453   
454   return CMD_SUCCESS;
455 }