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