Commit remaining bits
[pspp] / src / language / xforms / compute.c
1 /* PSPP - a program for statistical analysis.
2    Copyright (C) 1997-9, 2000, 2009, 2010, 2011 Free Software Foundation, Inc.
3
4    This program is free software: you can redistribute it and/or modify
5    it under the terms of the GNU General Public License as published by
6    the Free Software Foundation, either version 3 of the License, or
7    (at your option) any later version.
8
9    This program is distributed in the hope that it will be useful,
10    but WITHOUT ANY WARRANTY; without even the implied warranty of
11    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12    GNU General Public License for more details.
13
14    You should have received a copy of the GNU General Public License
15    along with this program.  If not, see <http://www.gnu.org/licenses/>. */
16
17 #include <config.h>
18
19 #include <stdint.h>
20 #include <stdlib.h>
21
22 #include "data/case.h"
23 #include "data/dataset.h"
24 #include "data/dictionary.h"
25 #include "data/transformations.h"
26 #include "data/variable.h"
27 #include "data/vector.h"
28 #include "language/command.h"
29 #include "language/expressions/public.h"
30 #include "language/lexer/lexer.h"
31 #include "libpspp/message.h"
32 #include "libpspp/misc.h"
33 #include "libpspp/str.h"
34
35 #include "gl/xalloc.h"
36
37 #include "gettext.h"
38 #define _(msgid) gettext (msgid)
39
40 struct compute_trns;
41 struct lvalue;
42
43 /* Target of a COMPUTE or IF assignment, either a variable or a
44    vector element. */
45 static struct lvalue *lvalue_parse (struct lexer *lexer, struct dataset *);
46 static int lvalue_get_type (const struct lvalue *);
47 static bool lvalue_is_vector (const struct lvalue *);
48 static void lvalue_finalize (struct lvalue *,
49                              struct compute_trns *, struct dictionary *);
50 static void lvalue_destroy (struct lvalue *, struct dictionary *);
51
52 /* COMPUTE and IF transformation. */
53 struct compute_trns
54   {
55     /* Test expression (IF only). */
56     struct expression *test;     /* Test expression. */
57
58     /* Variable lvalue, if variable != NULL. */
59     struct variable *variable;   /* Destination variable, if any. */
60     int width;                   /* Lvalue string width; 0=numeric. */
61
62     /* Vector lvalue, if vector != NULL. */
63     const struct vector *vector; /* Destination vector, if any. */
64     struct expression *element;  /* Destination vector element expr. */
65
66     /* Rvalue. */
67     struct expression *rvalue;   /* Rvalue expression. */
68   };
69
70 static struct expression *parse_rvalue (struct lexer *lexer,
71                                         const struct lvalue *,
72                                         struct dataset *);
73
74 static struct compute_trns *compute_trns_create (void);
75 static trns_proc_func *get_proc_func (const struct lvalue *);
76 static trns_free_func compute_trns_free;
77 \f
78 /* COMPUTE. */
79
80 int
81 cmd_compute (struct lexer *lexer, struct dataset *ds)
82 {
83   struct dictionary *dict = dataset_dict (ds);
84   struct lvalue *lvalue = NULL;
85   struct compute_trns *compute = NULL;
86
87   compute = compute_trns_create ();
88
89   lvalue = lvalue_parse (lexer, ds);
90   if (lvalue == NULL)
91     goto fail;
92
93   if (!lex_force_match (lexer, T_EQUALS))
94     goto fail;
95   compute->rvalue = parse_rvalue (lexer, lvalue, ds);
96   if (compute->rvalue == NULL)
97     goto fail;
98
99   add_transformation (ds, get_proc_func (lvalue), compute_trns_free, compute);
100
101   lvalue_finalize (lvalue, compute, dict);
102
103   return CMD_SUCCESS;
104
105  fail:
106   lvalue_destroy (lvalue, dict);
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     {
122       *c = case_unshare (*c);
123       case_data_rw (*c, compute->variable)->f
124         = expr_evaluate_num (compute->rvalue, *c, case_num);
125     }
126
127   return TRNS_CONTINUE;
128 }
129
130 /* Handle COMPUTE or IF with numeric vector element target
131    variable. */
132 static int
133 compute_num_vec (void *compute_, struct ccase **c, casenumber case_num)
134 {
135   struct compute_trns *compute = compute_;
136
137   if (compute->test == NULL
138       || expr_evaluate_num (compute->test, *c, case_num) == 1.0)
139     {
140       double index;     /* Index into the vector. */
141       int rindx;        /* Rounded index value. */
142
143       index = expr_evaluate_num (compute->element, *c, case_num);
144       rindx = floor (index + EPSILON);
145       if (index == SYSMIS
146           || rindx < 1 || rindx > vector_get_var_cnt (compute->vector))
147         {
148           if (index == SYSMIS)
149             msg (SW, _("When executing COMPUTE: SYSMIS is not a valid value "
150                        "as an index into vector %s."),
151                  vector_get_name (compute->vector));
152           else
153             msg (SW, _("When executing COMPUTE: %g is not a valid value as "
154                        "an index into vector %s."),
155                  index, vector_get_name (compute->vector));
156           return TRNS_CONTINUE;
157         }
158
159       *c = case_unshare (*c);
160       case_data_rw (*c, vector_get_var (compute->vector, rindx - 1))->f
161         = expr_evaluate_num (compute->rvalue, *c, case_num);
162     }
163
164   return TRNS_CONTINUE;
165 }
166
167 /* Handle COMPUTE or IF with string target variable. */
168 static int
169 compute_str (void *compute_, struct ccase **c, casenumber case_num)
170 {
171   struct compute_trns *compute = compute_;
172
173   if (compute->test == NULL
174       || expr_evaluate_num (compute->test, *c, case_num) == 1.0)
175     {
176       char *s;
177
178       *c = case_unshare (*c);
179       s = CHAR_CAST_BUG (char *, case_str_rw (*c, compute->variable));
180       expr_evaluate_str (compute->rvalue, *c, case_num, s, compute->width);
181     }
182
183   return TRNS_CONTINUE;
184 }
185
186 /* Handle COMPUTE or IF with string vector element target
187    variable. */
188 static int
189 compute_str_vec (void *compute_, struct ccase **c, casenumber case_num)
190 {
191   struct compute_trns *compute = compute_;
192
193   if (compute->test == NULL
194       || expr_evaluate_num (compute->test, *c, case_num) == 1.0)
195     {
196       double index;             /* Index into the vector. */
197       int rindx;                /* Rounded index value. */
198       struct variable *vr;      /* Variable reference by indexed vector. */
199
200       index = expr_evaluate_num (compute->element, *c, case_num);
201       rindx = floor (index + EPSILON);
202       if (index == SYSMIS)
203         {
204           msg (SW, _("When executing COMPUTE: SYSMIS is not a valid "
205                      "value as an index into vector %s."),
206                vector_get_name (compute->vector));
207           return TRNS_CONTINUE;
208         }
209       else if (rindx < 1 || rindx > vector_get_var_cnt (compute->vector))
210         {
211           msg (SW, _("When executing COMPUTE: %g is not a valid value as "
212                      "an index into vector %s."),
213                index, vector_get_name (compute->vector));
214           return TRNS_CONTINUE;
215         }
216
217       vr = vector_get_var (compute->vector, rindx - 1);
218       *c = case_unshare (*c);
219       expr_evaluate_str (compute->rvalue, *c, case_num,
220                          CHAR_CAST_BUG (char *, case_str_rw (*c, vr)),
221                          var_get_width (vr));
222     }
223
224   return TRNS_CONTINUE;
225 }
226 \f
227 /* IF. */
228
229 int
230 cmd_if (struct lexer *lexer, struct dataset *ds)
231 {
232   struct dictionary *dict = dataset_dict (ds);
233   struct compute_trns *compute = NULL;
234   struct lvalue *lvalue = NULL;
235
236   compute = compute_trns_create ();
237
238   /* Test expression. */
239   compute->test = expr_parse (lexer, ds, EXPR_BOOLEAN);
240   if (compute->test == NULL)
241     goto fail;
242
243   /* Lvalue variable. */
244   lvalue = lvalue_parse (lexer, ds);
245   if (lvalue == NULL)
246     goto fail;
247
248   /* Rvalue expression. */
249   if (!lex_force_match (lexer, T_EQUALS))
250     goto fail;
251   compute->rvalue = parse_rvalue (lexer, lvalue, ds);
252   if (compute->rvalue == NULL)
253     goto fail;
254
255   add_transformation (ds, get_proc_func (lvalue), compute_trns_free, compute);
256
257   lvalue_finalize (lvalue, compute, dict);
258
259   return CMD_SUCCESS;
260
261  fail:
262   lvalue_destroy (lvalue, dict);
263   compute_trns_free (compute);
264   return CMD_CASCADING_FAILURE;
265 }
266 \f
267 /* Code common to COMPUTE and IF. */
268
269 static trns_proc_func *
270 get_proc_func (const struct lvalue *lvalue)
271 {
272   bool is_numeric = lvalue_get_type (lvalue) == VAL_NUMERIC;
273   bool is_vector = lvalue_is_vector (lvalue);
274
275   return (is_numeric
276           ? (is_vector ? compute_num_vec : compute_num)
277           : (is_vector ? compute_str_vec : compute_str));
278 }
279
280 /* Parses and returns an rvalue expression of the same type as
281    LVALUE, or a null pointer on failure. */
282 static struct expression *
283 parse_rvalue (struct lexer *lexer,
284               const struct lvalue *lvalue, struct dataset *ds)
285 {
286   bool is_numeric = lvalue_get_type (lvalue) == VAL_NUMERIC;
287
288   return expr_parse (lexer, ds, is_numeric ? EXPR_NUMBER : EXPR_STRING);
289 }
290
291 /* Returns a new struct compute_trns after initializing its fields. */
292 static struct compute_trns *
293 compute_trns_create (void)
294 {
295   struct compute_trns *compute = xmalloc (sizeof *compute);
296   compute->test = NULL;
297   compute->variable = NULL;
298   compute->vector = NULL;
299   compute->element = NULL;
300   compute->rvalue = NULL;
301   return compute;
302 }
303
304 /* Deletes all the fields in COMPUTE. */
305 static bool
306 compute_trns_free (void *compute_)
307 {
308   struct compute_trns *compute = compute_;
309
310   if (compute != NULL)
311     {
312       expr_free (compute->test);
313       expr_free (compute->element);
314       expr_free (compute->rvalue);
315       free (compute);
316     }
317   return true;
318 }
319 \f
320 /* COMPUTE or IF target variable or vector element.
321    For a variable, the `variable' member is non-null.
322    For a vector element, the `vector' member is non-null. */
323 struct lvalue
324   {
325     struct variable *variable;   /* Destination variable. */
326     bool is_new_variable;        /* Did we create the variable? */
327
328     const struct vector *vector; /* Destination vector, if any, or NULL. */
329     struct expression *element;  /* Destination vector element, or NULL. */
330   };
331
332 /* Parses the target variable or vector element into a new
333    `struct lvalue', which is returned. */
334 static struct lvalue *
335 lvalue_parse (struct lexer *lexer, struct dataset *ds)
336 {
337   struct dictionary *dict = dataset_dict (ds);
338   struct lvalue *lvalue;
339
340   lvalue = xmalloc (sizeof *lvalue);
341   lvalue->variable = NULL;
342   lvalue->is_new_variable = false;
343   lvalue->vector = NULL;
344   lvalue->element = NULL;
345
346   if (!lex_force_id (lexer))
347     goto lossage;
348
349   if (lex_next_token (lexer, 1) == T_LPAREN)
350     {
351       /* Vector. */
352       lvalue->vector = dict_lookup_vector (dict, lex_tokcstr (lexer));
353       if (lvalue->vector == NULL)
354         {
355           msg (SE, _("There is no vector named %s."), lex_tokcstr (lexer));
356           goto lossage;
357         }
358
359       /* Vector element. */
360       lex_get (lexer);
361       if (!lex_force_match (lexer, T_LPAREN))
362         goto lossage;
363       lvalue->element = expr_parse (lexer, ds, EXPR_NUMBER);
364       if (lvalue->element == NULL)
365         goto lossage;
366       if (!lex_force_match (lexer, T_RPAREN))
367         goto lossage;
368     }
369   else
370     {
371       /* Variable name. */
372       const char *var_name = lex_tokcstr (lexer);
373       lvalue->variable = dict_lookup_var (dict, var_name);
374       if (lvalue->variable == NULL)
375         {
376           lvalue->variable = dict_create_var_assert (dict, var_name, 0);
377           lvalue->is_new_variable = true;
378         }
379       lex_get (lexer);
380     }
381   return lvalue;
382
383  lossage:
384   lvalue_destroy (lvalue, dict);
385   return NULL;
386 }
387
388 /* Returns the type (NUMERIC or ALPHA) of the target variable or
389    vector in LVALUE. */
390 static int
391 lvalue_get_type (const struct lvalue *lvalue)
392 {
393   return (lvalue->variable != NULL
394           ? var_get_type (lvalue->variable)
395           : vector_get_type (lvalue->vector));
396 }
397
398 /* Returns true if LVALUE has a vector as its target. */
399 static bool
400 lvalue_is_vector (const struct lvalue *lvalue)
401 {
402   return lvalue->vector != NULL;
403 }
404
405 /* Finalizes making LVALUE the target of COMPUTE, by creating the
406    target variable if necessary and setting fields in COMPUTE. */
407 static void
408 lvalue_finalize (struct lvalue *lvalue,
409                  struct compute_trns *compute,
410                  struct dictionary *dict)
411 {
412   if (lvalue->vector == NULL)
413     {
414       compute->variable = lvalue->variable;
415       compute->width = var_get_width (compute->variable);
416
417       /* Goofy behavior, but compatible: Turn off LEAVE. */
418       if (!var_must_leave (compute->variable))
419         var_set_leave (compute->variable, false);
420
421       /* Prevent lvalue_destroy from deleting variable. */
422       lvalue->is_new_variable = false;
423     }
424   else
425     {
426       compute->vector = lvalue->vector;
427       compute->element = lvalue->element;
428       lvalue->element = NULL;
429     }
430
431   lvalue_destroy (lvalue, dict);
432 }
433
434 /* Destroys LVALUE. */
435 static void
436 lvalue_destroy (struct lvalue *lvalue, struct dictionary *dict)
437 {
438   if (lvalue == NULL)
439      return;
440
441   if (lvalue->is_new_variable)
442     dict_delete_var (dict, lvalue->variable);
443   expr_free (lvalue->element);
444   free (lvalue);
445 }