src/language/xforms/compute.c

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