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