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