Damn! Forgot to change casenum_t in *.q
[pspp] / src / language / xforms / 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., 51 Franklin Street, Fifth Floor, Boston, MA
18    02110-1301, USA. */
19
20 #include <config.h>
21
22 #include <stdlib.h>
23
24 #include <data/case.h>
25 #include <data/dictionary.h>
26 #include <data/procedure.h>
27 #include <data/transformations.h>
28 #include <data/variable.h>
29 #include <language/command.h>
30 #include <language/expressions/public.h>
31 #include <language/lexer/lexer.h>
32 #include <libpspp/alloc.h>
33 #include <libpspp/message.h>
34 #include <libpspp/message.h>
35 #include <libpspp/misc.h>
36 #include <libpspp/str.h>
37
38 #include "gettext.h"
39 #define _(msgid) gettext (msgid)
40
41 struct compute_trns;
42 struct lvalue;
43
44 /* Target of a COMPUTE or IF assignment, either a variable or a
45    vector element. */
46 static struct lvalue *lvalue_parse (struct dataset *);
47 static int lvalue_get_type (const struct lvalue *, const struct dictionary *);
48 static bool lvalue_is_vector (const struct lvalue *);
49 static void lvalue_finalize (struct lvalue *,
50                              struct compute_trns *, struct dictionary *);
51 static void lvalue_destroy (struct lvalue *);
52
53 /* COMPUTE and IF transformation. */
54 struct compute_trns
55   {
56     /* Test expression (IF only). */
57     struct expression *test;     /* Test expression. */
58
59     /* Variable lvalue, if variable != NULL. */
60     struct variable *variable;   /* Destination variable, if any. */
61     int fv;                      /* `value' index of destination variable. */
62     int width;                   /* Lvalue string width; 0=numeric. */
63
64     /* Vector lvalue, if vector != NULL. */
65     const struct vector *vector; /* Destination vector, if any. */
66     struct expression *element;  /* Destination vector element expr. */
67
68     /* Rvalue. */
69     struct expression *rvalue;   /* Rvalue expression. */
70   };
71
72 static struct expression *parse_rvalue (const struct lvalue *, struct dataset *);
73 static struct compute_trns *compute_trns_create (void);
74 static trns_proc_func *get_proc_func (const struct lvalue *, const struct dictionary *);
75 static trns_free_func compute_trns_free;
76 \f
77 /* COMPUTE. */
78
79 int
80 cmd_compute (struct dataset *ds)
81 {
82   struct dictionary *dict = dataset_dict (ds);
83   struct lvalue *lvalue = NULL;
84   struct compute_trns *compute = NULL;
85
86   compute = compute_trns_create ();
87
88   lvalue = lvalue_parse (ds);
89   if (lvalue == NULL)
90     goto fail;
91
92   if (!lex_force_match ('='))
93     goto fail;
94   compute->rvalue = parse_rvalue (lvalue, ds);
95   if (compute->rvalue == NULL)
96     goto fail;
97
98   add_transformation (ds, get_proc_func (lvalue, dict), 
99                       compute_trns_free, compute);
100
101   lvalue_finalize (lvalue, compute, dict);
102
103   return lex_end_of_command ();
104
105  fail:
106   lvalue_destroy (lvalue);
107   compute_trns_free (compute);
108   return CMD_CASCADING_FAILURE;
109 }
110 \f
111 /* Transformation functions. */
112
113 /* Handle COMPUTE or IF with numeric target variable. */
114 static int
115 compute_num (void *compute_, struct ccase *c, casenumber case_num)
116 {
117   struct compute_trns *compute = compute_;
118
119   if (compute->test == NULL
120       || expr_evaluate_num (compute->test, c, case_num) == 1.0) 
121     case_data_rw (c, compute->fv)->f = expr_evaluate_num (compute->rvalue, c,
122                                                           case_num); 
123   
124   return TRNS_CONTINUE;
125 }
126
127 /* Handle COMPUTE or IF with numeric vector element target
128    variable. */
129 static int
130 compute_num_vec (void *compute_, struct ccase *c, casenumber case_num)
131 {
132   struct compute_trns *compute = compute_;
133
134   if (compute->test == NULL
135       || expr_evaluate_num (compute->test, c, case_num) == 1.0) 
136     {
137       double index;     /* Index into the vector. */
138       int rindx;        /* Rounded index value. */
139
140       index = expr_evaluate_num (compute->element, c, case_num);
141       rindx = floor (index + EPSILON);
142       if (index == SYSMIS || rindx < 1 || rindx > compute->vector->cnt)
143         {
144           if (index == SYSMIS)
145             msg (SW, _("When executing COMPUTE: SYSMIS is not a valid value as "
146                        "an index into vector %s."), compute->vector->name);
147           else
148             msg (SW, _("When executing COMPUTE: %g is not a valid value as "
149                        "an index into vector %s."),
150                  index, compute->vector->name);
151           return TRNS_CONTINUE;
152         }
153       case_data_rw (c, compute->vector->var[rindx - 1]->fv)->f
154         = expr_evaluate_num (compute->rvalue, c, case_num);
155     }
156   
157   return TRNS_CONTINUE;
158 }
159
160 /* Handle COMPUTE or IF with string target variable. */
161 static int
162 compute_str (void *compute_, struct ccase *c, casenumber case_num)
163 {
164   struct compute_trns *compute = compute_;
165
166   if (compute->test == NULL
167       || expr_evaluate_num (compute->test, c, case_num) == 1.0) 
168     expr_evaluate_str (compute->rvalue, c, case_num,
169                        case_data_rw (c, compute->fv)->s, compute->width);
170   
171   return TRNS_CONTINUE;
172 }
173
174 /* Handle COMPUTE or IF with string vector element target
175    variable. */
176 static int
177 compute_str_vec (void *compute_, struct ccase *c, casenumber case_num)
178 {
179   struct compute_trns *compute = compute_;
180
181   if (compute->test == NULL
182       || expr_evaluate_num (compute->test, c, case_num) == 1.0) 
183     {
184       double index;             /* Index into the vector. */
185       int rindx;                /* Rounded index value. */
186       struct variable *vr;      /* Variable reference by indexed vector. */
187
188       index = expr_evaluate_num (compute->element, c, case_num);
189       rindx = floor (index + EPSILON);
190       if (index == SYSMIS) 
191         {
192           msg (SW, _("When executing COMPUTE: SYSMIS is not a valid "
193                      "value as an index into vector %s."),
194                compute->vector->name);
195           return TRNS_CONTINUE; 
196         }
197       else if (rindx < 1 || rindx > compute->vector->cnt)
198         {
199           msg (SW, _("When executing COMPUTE: %g is not a valid value as "
200                      "an index into vector %s."),
201                index, compute->vector->name);
202           return TRNS_CONTINUE;
203         }
204
205       vr = compute->vector->var[rindx - 1];
206       expr_evaluate_str (compute->rvalue, c, case_num,
207                          case_data_rw (c, vr->fv)->s, vr->width);
208     }
209   
210   return TRNS_CONTINUE;
211 }
212 \f
213 /* IF. */
214
215 int
216 cmd_if (struct dataset *ds)
217 {
218   struct dictionary *dict = dataset_dict (ds);
219   struct compute_trns *compute = NULL;
220   struct lvalue *lvalue = NULL;
221
222   compute = compute_trns_create ();
223
224   /* Test expression. */
225   compute->test = expr_parse (ds, EXPR_BOOLEAN);
226   if (compute->test == NULL)
227     goto fail;
228
229   /* Lvalue variable. */
230   lvalue = lvalue_parse (ds);
231   if (lvalue == NULL)
232     goto fail;
233
234   /* Rvalue expression. */
235   if (!lex_force_match ('='))
236     goto fail;
237   compute->rvalue = parse_rvalue (lvalue, ds);
238   if (compute->rvalue == NULL)
239     goto fail;
240
241   add_transformation (ds, get_proc_func (lvalue, dict), 
242                       compute_trns_free, compute);
243
244   lvalue_finalize (lvalue, compute, dict);
245
246   return lex_end_of_command ();
247
248  fail:
249   lvalue_destroy (lvalue);
250   compute_trns_free (compute);
251   return CMD_CASCADING_FAILURE;
252 }
253 \f
254 /* Code common to COMPUTE and IF. */
255
256 static trns_proc_func *
257 get_proc_func (const struct lvalue *lvalue, const struct dictionary *dict) 
258 {
259   bool is_numeric = lvalue_get_type (lvalue, dict) == NUMERIC;
260   bool is_vector = lvalue_is_vector (lvalue);
261
262   return (is_numeric
263           ? (is_vector ? compute_num_vec : compute_num)
264           : (is_vector ? compute_str_vec : compute_str));
265 }
266
267 /* Parses and returns an rvalue expression of the same type as
268    LVALUE, or a null pointer on failure. */
269 static struct expression *
270 parse_rvalue (const struct lvalue *lvalue, struct dataset *ds)
271 {
272   const struct dictionary *dict = dataset_dict (ds);
273   bool is_numeric = lvalue_get_type (lvalue, dict) == NUMERIC;
274
275   return expr_parse (ds, is_numeric ? EXPR_NUMBER : EXPR_STRING);
276 }
277
278 /* Returns a new struct compute_trns after initializing its fields. */
279 static struct compute_trns *
280 compute_trns_create (void)
281 {
282   struct compute_trns *compute = xmalloc (sizeof *compute);
283   compute->test = NULL;
284   compute->variable = NULL;
285   compute->vector = NULL;
286   compute->element = NULL;
287   compute->rvalue = NULL;
288   return compute;
289 }
290
291 /* Deletes all the fields in COMPUTE. */
292 static bool
293 compute_trns_free (void *compute_)
294 {
295   struct compute_trns *compute = compute_;
296
297   if (compute != NULL) 
298     {
299       expr_free (compute->test);
300       expr_free (compute->element);
301       expr_free (compute->rvalue);
302       free (compute);
303     }
304   return true;
305 }
306 \f
307 /* COMPUTE or IF target variable or vector element. */
308 struct lvalue
309   {
310     char var_name[LONG_NAME_LEN + 1];   /* Destination variable name, or "". */
311     const struct vector *vector; /* Destination vector, if any, or NULL. */
312     struct expression *element;  /* Destination vector element, or NULL. */
313   };
314
315 /* Parses the target variable or vector element into a new
316    `struct lvalue', which is returned. */
317 static struct lvalue *
318 lvalue_parse (struct dataset *ds) 
319 {
320   struct lvalue *lvalue;
321
322   lvalue = xmalloc (sizeof *lvalue);
323   lvalue->var_name[0] = '\0';
324   lvalue->vector = NULL;
325   lvalue->element = NULL;
326
327   if (!lex_force_id ())
328     goto lossage;
329   
330   if (lex_look_ahead () == '(')
331     {
332       /* Vector. */
333       lvalue->vector = dict_lookup_vector (dataset_dict (ds), tokid);
334       if (lvalue->vector == NULL)
335         {
336           msg (SE, _("There is no vector named %s."), tokid);
337           goto lossage;
338         }
339
340       /* Vector element. */
341       lex_get ();
342       if (!lex_force_match ('('))
343         goto lossage;
344       lvalue->element = expr_parse (ds, EXPR_NUMBER);
345       if (lvalue->element == NULL)
346         goto lossage;
347       if (!lex_force_match (')'))
348         goto lossage;
349     }
350   else
351     {
352       /* Variable name. */
353       str_copy_trunc (lvalue->var_name, sizeof lvalue->var_name, tokid);
354       lex_get ();
355     }
356   return lvalue;
357
358  lossage:
359   lvalue_destroy (lvalue);
360   return NULL;
361 }
362
363 /* Returns the type (NUMERIC or ALPHA) of the target variable or
364    vector in LVALUE. */
365 static int
366 lvalue_get_type (const struct lvalue *lvalue, const struct dictionary *dict) 
367 {
368   if (lvalue->vector == NULL) 
369     {
370       struct variable *var = dict_lookup_var (dict, lvalue->var_name);
371       if (var == NULL)
372         return NUMERIC;
373       else
374         return var->type;
375     }
376   else 
377     return lvalue->vector->var[0]->type;
378 }
379
380 /* Returns true if LVALUE has a vector as its target. */
381 static bool
382 lvalue_is_vector (const struct lvalue *lvalue) 
383 {
384   return lvalue->vector != NULL;
385 }
386
387 /* Finalizes making LVALUE the target of COMPUTE, by creating the
388    target variable if necessary and setting fields in COMPUTE. */
389 static void
390 lvalue_finalize (struct lvalue *lvalue, 
391                  struct compute_trns *compute, 
392                  struct dictionary *dict) 
393 {
394   if (lvalue->vector == NULL)
395     {
396       compute->variable = dict_lookup_var (dict, lvalue->var_name);
397       if (compute->variable == NULL)
398           compute->variable = dict_create_var_assert (dict, lvalue->var_name, 0);
399
400       compute->fv = compute->variable->fv;
401       compute->width = compute->variable->width;
402
403       /* Goofy behavior, but compatible: Turn off LEAVE. */
404       if (dict_class_from_id (compute->variable->name) != DC_SCRATCH)
405         compute->variable->leave = false;
406     }
407   else 
408     {
409       compute->vector = lvalue->vector;
410       compute->element = lvalue->element;
411       lvalue->element = NULL;
412     }
413
414   lvalue_destroy (lvalue);
415 }
416
417 /* Destroys LVALUE. */
418 static void 
419 lvalue_destroy (struct lvalue *lvalue) 
420 {
421   if (lvalue == NULL) 
422      return;
423
424   expr_free (lvalue->element);
425   free (lvalue);
426 }