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