Adopt use of gnulib for portability.
[pspp] / 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., 51 Franklin Street, Fifth Floor, Boston, MA
18    02110-1301, USA. */
19
20 #include <config.h>
21 #include "error.h"
22 #include <stdlib.h>
23 #include "alloc.h"
24 #include "case.h"
25 #include "command.h"
26 #include "dictionary.h"
27 #include "error.h"
28 #include "expressions/public.h"
29 #include "lexer.h"
30 #include "misc.h"
31 #include "str.h"
32 #include "var.h"
33
34 #include "gettext.h"
35 #define _(msgid) gettext (msgid)
36
37 struct compute_trns;
38 struct lvalue;
39
40 /* Target of a COMPUTE or IF assignment, either a variable or a
41    vector element. */
42 static struct lvalue *lvalue_parse (void);
43 static int lvalue_get_type (const struct lvalue *);
44 static int lvalue_is_vector (const struct lvalue *);
45 static void lvalue_finalize (struct lvalue *,
46                              struct compute_trns *);
47 static void lvalue_destroy (struct lvalue *);
48
49 /* COMPUTE and IF transformation. */
50 struct compute_trns
51   {
52     struct trns_header h;
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 fv;                      /* `value' index of destination variable. */
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 int parse_rvalue_expression (struct compute_trns *,
71                                     const struct lvalue *);
72 static struct compute_trns *compute_trns_create (void);
73 static void compute_trns_free (struct trns_header *);
74 \f
75 /* COMPUTE. */
76
77 int
78 cmd_compute (void)
79 {
80   struct lvalue *lvalue = NULL;
81   struct compute_trns *compute = NULL;
82
83   lvalue = lvalue_parse ();
84   if (lvalue == NULL)
85     goto fail;
86
87   compute = compute_trns_create ();
88
89   if (!lex_force_match ('=') || !parse_rvalue_expression (compute, lvalue))
90     goto fail;
91
92   lvalue_finalize (lvalue, compute);
93
94   add_transformation (&compute->h);
95
96   return CMD_SUCCESS;
97
98  fail:
99   lvalue_destroy (lvalue);
100   if (compute != NULL) 
101     {
102       compute_trns_free (&compute->h);
103       free (compute); 
104     }
105   return CMD_FAILURE;
106 }
107 \f
108 /* Transformation functions. */
109
110 /* Handle COMPUTE or IF with numeric target variable. */
111 static int
112 compute_num (struct trns_header *compute_, struct ccase *c,
113              int case_num)
114 {
115   struct compute_trns *compute = (struct compute_trns *) compute_;
116
117   if (compute->test == NULL
118       || expr_evaluate_num (compute->test, c, case_num) == 1.0) 
119     case_data_rw (c, compute->fv)->f = expr_evaluate_num (compute->rvalue, c,
120                                                           case_num); 
121   
122   return -1;
123 }
124
125 /* Handle COMPUTE or IF with numeric vector element target
126    variable. */
127 static int
128 compute_num_vec (struct trns_header *compute_, struct ccase *c,
129                  int case_num)
130 {
131   struct compute_trns *compute = (struct compute_trns *) 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 || rindx < 1 || rindx > compute->vector->cnt)
142         {
143           if (index == SYSMIS)
144             msg (SW, _("When executing COMPUTE: SYSMIS is not a valid value as "
145                        "an index into vector %s."), compute->vector->name);
146           else
147             msg (SW, _("When executing COMPUTE: %g is not a valid value as "
148                        "an index into vector %s."),
149                  index, compute->vector->name);
150           return -1;
151         }
152       case_data_rw (c, compute->vector->var[rindx - 1]->fv)->f
153         = expr_evaluate_num (compute->rvalue, c, case_num);
154     }
155   
156   return -1;
157 }
158
159 /* Handle COMPUTE or IF with string target variable. */
160 static int
161 compute_str (struct trns_header *compute_, struct ccase *c,
162              int case_num)
163 {
164   struct compute_trns *compute = (struct compute_trns *) 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 -1;
172 }
173
174 /* Handle COMPUTE or IF with string vector element target
175    variable. */
176 static int
177 compute_str_vec (struct trns_header *compute_, struct ccase *c,
178                  int case_num)
179 {
180   struct compute_trns *compute = (struct compute_trns *) 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                compute->vector->name);
196           return -1; 
197         }
198       else if (rindx < 1 || rindx > compute->vector->cnt)
199         {
200           msg (SW, _("When executing COMPUTE: %g is not a valid value as "
201                      "an index into vector %s."),
202                index, compute->vector->name);
203           return -1;
204         }
205
206       vr = compute->vector->var[rindx - 1];
207       expr_evaluate_str (compute->rvalue, c, case_num,
208                          case_data_rw (c, vr->fv)->s, vr->width);
209     }
210   
211   return -1;
212 }
213 \f
214 /* IF. */
215
216 int
217 cmd_if (void)
218 {
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 (default_dict, EXPR_BOOLEAN);
226   if (compute->test == NULL)
227     goto fail;
228
229   /* Lvalue variable. */
230   lvalue = lvalue_parse ();
231   if (lvalue == NULL)
232     goto fail;
233
234   /* Rvalue expression. */
235   if (!lex_force_match ('=') || !parse_rvalue_expression (compute, lvalue))
236     goto fail;
237
238   lvalue_finalize (lvalue, compute);
239
240   add_transformation (&compute->h);
241
242   return CMD_SUCCESS;
243
244  fail:
245   lvalue_destroy (lvalue);
246   if (compute != NULL) 
247     {
248       compute_trns_free (&compute->h);
249       free (compute); 
250     }
251   return CMD_FAILURE;
252 }
253 \f
254 /* Code common to COMPUTE and IF. */
255
256 /* Checks for type mismatches on transformation C.  Also checks for
257    command terminator, sets the case-handling proc from the array
258    passed. */
259 static int
260 parse_rvalue_expression (struct compute_trns *compute,
261                          const struct lvalue *lvalue)
262 {
263   int type = lvalue_get_type (lvalue);
264   int vector = lvalue_is_vector (lvalue);
265
266   assert (type == NUMERIC || type == ALPHA);
267
268   compute->rvalue = expr_parse (default_dict,
269                                 type == ALPHA ? EXPR_STRING : EXPR_NUMBER);
270   if (compute->rvalue == NULL)
271     return 0;
272
273   if (type == NUMERIC)
274     compute->h.proc = vector ? compute_num_vec : compute_num;
275   else
276     compute->h.proc = vector ? compute_str_vec : compute_str;
277
278   if (token != '.')
279     {
280       lex_error (_("expecting end of command"));
281       return 0;
282     }
283   
284   return 1;
285 }
286
287 /* Returns a new struct compute_trns after initializing its fields. */
288 static struct compute_trns *
289 compute_trns_create (void)
290 {
291   struct compute_trns *compute = xmalloc (sizeof *compute);
292   compute->h.proc = NULL;
293   compute->h.free = compute_trns_free;
294   compute->test = NULL;
295   compute->variable = NULL;
296   compute->vector = NULL;
297   compute->element = NULL;
298   compute->rvalue = NULL;
299   return compute;
300 }
301
302 /* Deletes all the fields in COMPUTE. */
303 static void
304 compute_trns_free (struct trns_header *compute_)
305 {
306   struct compute_trns *compute = (struct compute_trns *) compute_;
307
308   expr_free (compute->test);
309   expr_free (compute->element);
310   expr_free (compute->rvalue);
311 }
312 \f
313 /* COMPUTE or IF target variable or vector element. */
314 struct lvalue
315   {
316     char var_name[LONG_NAME_LEN + 1];   /* Destination variable name, or "". */
317     const struct vector *vector; /* Destination vector, if any, or NULL. */
318     struct expression *element;  /* Destination vector element, or NULL. */
319   };
320
321 /* Parses the target variable or vector element into a new
322    `struct lvalue', which is returned. */
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 (default_dict, EXPR_NUMBER);
351       if (lvalue->element == NULL)
352         goto lossage;
353       if (!lex_force_match (')'))
354         goto lossage;
355     }
356   else
357     {
358       /* Variable name. */
359       str_copy_trunc (lvalue->var_name, sizeof lvalue->var_name, tokid);
360       lex_get ();
361     }
362   return lvalue;
363
364  lossage:
365   lvalue_destroy (lvalue);
366   return NULL;
367 }
368
369 /* Returns the type (NUMERIC or ALPHA) of the target variable or
370    vector in LVALUE. */
371 static int
372 lvalue_get_type (const struct lvalue *lvalue) 
373 {
374   if (lvalue->vector == NULL) 
375     {
376       struct variable *var = 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 /* Returns nonzero if LVALUE has a vector as its target. */
387 static int
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 {
399   if (lvalue->vector == NULL)
400     {
401       compute->variable = dict_lookup_var (default_dict, lvalue->var_name);
402       if (compute->variable == NULL)
403           compute->variable = dict_create_var_assert (default_dict,
404                                                       lvalue->var_name, 0);
405
406       compute->fv = compute->variable->fv;
407       compute->width = compute->variable->width;
408
409       /* Goofy behavior, but compatible: Turn off LEAVE. */
410       if (dict_class_from_id (compute->variable->name) != DC_SCRATCH)
411         compute->variable->reinit = 1;
412     }
413   else 
414     {
415       compute->vector = lvalue->vector;
416       compute->element = lvalue->element;
417       lvalue->element = NULL;
418     }
419
420   lvalue_destroy (lvalue);
421 }
422
423 /* Destroys LVALUE. */
424 static void 
425 lvalue_destroy (struct lvalue *lvalue) 
426 {
427   if ( ! lvalue ) 
428      return ;
429
430   expr_free (lvalue->element);
431   free (lvalue);
432 }