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 }