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., 59 Temple Place - Suite 330, Boston, MA
  18    02111-1307, 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 struct compute_trns;
  35 struct lvalue;
  36
  37 /* Target of a COMPUTE or IF assignment, either a variable or a
  38    vector element. */
  39 static struct lvalue *lvalue_parse (void);
  40 static int lvalue_get_type (const struct lvalue *);
  41 static int lvalue_is_vector (const struct lvalue *);
  42 static void lvalue_finalize (struct lvalue *,
  43                              struct compute_trns *);
  44 static void lvalue_destroy (struct lvalue *);
  45
  46 /* COMPUTE and IF transformation. */
  47 struct compute_trns
  48   {
  49     struct trns_header h;
  50
  51     /* Test expression (IF only). */
  52     struct expression *test;     /* Test expression. */
  53
  54     /* Variable lvalue, if variable != NULL. */
  55     struct variable *variable;   /* Destination variable, if any. */
  56     int fv;                      /* `value' index of destination variable. */
  57     int width;                   /* Lvalue string width; 0=numeric. */
  58
  59     /* Vector lvalue, if vector != NULL. */
  60     const struct vector *vector; /* Destination vector, if any. */
  61     struct expression *element;  /* Destination vector element expr. */
  62
  63     /* Rvalue. */
  64     struct expression *rvalue;   /* Rvalue expression. */
  65   };
  66
  67 static int parse_rvalue_expression (struct compute_trns *,
  68                                     const struct lvalue *);
  69 static struct compute_trns *compute_trns_create (void);
  70 static void compute_trns_free (struct trns_header *);
  71 \f
  72 /* COMPUTE. */
  73
  74 int
  75 cmd_compute (void)
  76 {
  77   struct lvalue *lvalue = NULL;
  78   struct compute_trns *compute = NULL;
  79
  80   lvalue = lvalue_parse ();
  81   if (lvalue == NULL)
  82     goto fail;
  83
  84   compute = compute_trns_create ();
  85
  86   if (!lex_force_match ('=') || !parse_rvalue_expression (compute, lvalue))
  87     goto fail;
  88
  89   lvalue_finalize (lvalue, compute);
  90
  91   add_transformation (&compute->h);
  92
  93   return CMD_SUCCESS;
  94
  95  fail:
  96   lvalue_destroy (lvalue);
  97   if (compute != NULL)
  98     {
  99       compute_trns_free (&compute->h);
 100       free (compute);
 101     }
 102   return CMD_FAILURE;
 103 }
 104 \f
 105 /* Transformation functions. */
 106
 107 /* Handle COMPUTE or IF with numeric target variable. */
 108 static int
 109 compute_num (struct trns_header *compute_, struct ccase *c,
 110              int case_num)
 111 {
 112   struct compute_trns *compute = (struct compute_trns *) compute_;
 113
 114   if (compute->test == NULL
 115       || expr_evaluate_num (compute->test, c, case_num) == 1.0)
 116     case_data_rw (c, compute->fv)->f = expr_evaluate_num (compute->rvalue, c,
 117                                                           case_num);
 118
 119   return -1;
 120 }
 121
 122 /* Handle COMPUTE or IF with numeric vector element target
 123    variable. */
 124 static int
 125 compute_num_vec (struct trns_header *compute_, struct ccase *c,
 126                  int case_num)
 127 {
 128   struct compute_trns *compute = (struct compute_trns *) compute_;
 129
 130   if (compute->test == NULL
 131       || expr_evaluate_num (compute->test, c, case_num) == 1.0)
 132     {
 133       double index;     /* Index into the vector. */
 134       int rindx;        /* Rounded index value. */
 135
 136       index = expr_evaluate_num (compute->element, c, case_num);
 137       rindx = floor (index + EPSILON);
 138       if (index == SYSMIS || rindx < 1 || rindx > compute->vector->cnt)
 139         {
 140           if (index == SYSMIS)
 141             msg (SW, _("When executing COMPUTE: SYSMIS is not a valid value as "
 142                        "an index into vector %s."), compute->vector->name);
 143           else
 144             msg (SW, _("When executing COMPUTE: %g is not a valid value as "
 145                        "an index into vector %s."),
 146                  index, compute->vector->name);
 147           return -1;
 148         }
 149       case_data_rw (c, compute->vector->var[rindx - 1]->fv)->f
 150         = expr_evaluate_num (compute->rvalue, c, case_num);
 151     }
 152
 153   return -1;
 154 }
 155
 156 /* Handle COMPUTE or IF with string target variable. */
 157 static int
 158 compute_str (struct trns_header *compute_, struct ccase *c,
 159              int case_num)
 160 {
 161   struct compute_trns *compute = (struct compute_trns *) compute_;
 162
 163   if (compute->test == NULL
 164       || expr_evaluate_num (compute->test, c, case_num) == 1.0)
 165     expr_evaluate_str (compute->rvalue, c, case_num,
 166                        case_data_rw (c, compute->fv)->s, compute->width);
 167
 168   return -1;
 169 }
 170
 171 /* Handle COMPUTE or IF with string vector element target
 172    variable. */
 173 static int
 174 compute_str_vec (struct trns_header *compute_, struct ccase *c,
 175                  int case_num)
 176 {
 177   struct compute_trns *compute = (struct compute_trns *) 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 -1;
 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 -1;
 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 -1;
 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 ('=') || !parse_rvalue_expression (compute, lvalue))
 233     goto fail;
 234
 235   lvalue_finalize (lvalue, compute);
 236
 237   add_transformation (&compute->h);
 238
 239   return CMD_SUCCESS;
 240
 241  fail:
 242   lvalue_destroy (lvalue);
 243   if (compute != NULL)
 244     {
 245       compute_trns_free (&compute->h);
 246       free (compute);
 247     }
 248   return CMD_FAILURE;
 249 }
 250 \f
 251 /* Code common to COMPUTE and IF. */
 252
 253 /* Checks for type mismatches on transformation C.  Also checks for
 254    command terminator, sets the case-handling proc from the array
 255    passed. */
 256 static int
 257 parse_rvalue_expression (struct compute_trns *compute,
 258                          const struct lvalue *lvalue)
 259 {
 260   int type = lvalue_get_type (lvalue);
 261   int vector = lvalue_is_vector (lvalue);
 262
 263   assert (type == NUMERIC || type == ALPHA);
 264
 265   compute->rvalue = expr_parse (default_dict,
 266                                 type == ALPHA ? EXPR_STRING : EXPR_NUMBER);
 267   if (compute->rvalue == NULL)
 268     return 0;
 269
 270   if (type == NUMERIC)
 271     compute->h.proc = vector ? compute_num_vec : compute_num;
 272   else
 273     compute->h.proc = vector ? compute_str_vec : compute_str;
 274
 275   if (token != '.')
 276     {
 277       lex_error (_("expecting end of command"));
 278       return 0;
 279     }
 280
 281   return 1;
 282 }
 283
 284 /* Returns a new struct compute_trns after initializing its fields. */
 285 static struct compute_trns *
 286 compute_trns_create (void)
 287 {
 288   struct compute_trns *compute = xmalloc (sizeof *compute);
 289   compute->h.proc = NULL;
 290   compute->h.free = compute_trns_free;
 291   compute->test = NULL;
 292   compute->variable = NULL;
 293   compute->vector = NULL;
 294   compute->element = NULL;
 295   compute->rvalue = NULL;
 296   return compute;
 297 }
 298
 299 /* Deletes all the fields in COMPUTE. */
 300 static void
 301 compute_trns_free (struct trns_header *compute_)
 302 {
 303   struct compute_trns *compute = (struct compute_trns *) compute_;
 304
 305   expr_free (compute->test);
 306   expr_free (compute->element);
 307   expr_free (compute->rvalue);
 308 }
 309 \f
 310 /* COMPUTE or IF target variable or vector element. */
 311 struct lvalue
 312   {
 313     char var_name[LONG_NAME_LEN + 1];   /* Destination variable name, or "". */
 314     const struct vector *vector; /* Destination vector, if any, or NULL. */
 315     struct expression *element;  /* Destination vector element, or NULL. */
 316   };
 317
 318 /* Parses the target variable or vector elector into a new
 319    `struct lvalue', which is returned. */
 320 static struct lvalue *
 321 lvalue_parse (void)
 322 {
 323   struct lvalue *lvalue;
 324
 325   lvalue = xmalloc (sizeof *lvalue);
 326   lvalue->var_name[0] = '\0';
 327   lvalue->vector = NULL;
 328   lvalue->element = NULL;
 329
 330   if (!lex_force_id ())
 331     goto lossage;
 332
 333   if (lex_look_ahead () == '(')
 334     {
 335       /* Vector. */
 336       lvalue->vector = dict_lookup_vector (default_dict, tokid);
 337       if (lvalue->vector == NULL)
 338         {
 339           msg (SE, _("There is no vector named %s."), tokid);
 340           goto lossage;
 341         }
 342
 343       /* Vector element. */
 344       lex_get ();
 345       if (!lex_force_match ('('))
 346         goto lossage;
 347       lvalue->element = expr_parse (default_dict, EXPR_NUMBER);
 348       if (lvalue->element == NULL)
 349         goto lossage;
 350       if (!lex_force_match (')'))
 351         goto lossage;
 352     }
 353   else
 354     {
 355       /* Variable name. */
 356       strncpy (lvalue->var_name, tokid, LONG_NAME_LEN);
 357       lvalue->var_name[LONG_NAME_LEN] = '\0';
 358       lex_get ();
 359     }
 360   return lvalue;
 361
 362  lossage:
 363   lvalue_destroy (lvalue);
 364   return NULL;
 365 }
 366
 367 /* Returns the type (NUMERIC or ALPHA) of the target variable or
 368    vector in LVALUE. */
 369 static int
 370 lvalue_get_type (const struct lvalue *lvalue)
 371 {
 372   if (lvalue->vector == NULL)
 373     {
 374       struct variable *var
 375         = dict_lookup_var (default_dict, lvalue->var_name);
 376       if (var == NULL)
 377         return NUMERIC;
 378       else
 379         return var->type;
 380     }
 381   else
 382     return lvalue->vector->var[0]->type;
 383 }
 384
 385 /* Returns nonzero if LVALUE has a vector as its target. */
 386 static int
 387 lvalue_is_vector (const struct lvalue *lvalue)
 388 {
 389   return lvalue->vector != NULL;
 390 }
 391
 392 /* Finalizes making LVALUE the target of COMPUTE, by creating the
 393    target variable if necessary and setting fields in COMPUTE. */
 394 static void
 395 lvalue_finalize (struct lvalue *lvalue,
 396                  struct compute_trns *compute)
 397 {
 398   if (lvalue->vector == NULL)
 399     {
 400       compute->variable = dict_lookup_var (default_dict, lvalue->var_name);
 401       if (compute->variable == NULL)
 402           compute->variable = dict_create_var_assert (default_dict,
 403                                                       lvalue->var_name, 0);
 404
 405       compute->fv = compute->variable->fv;
 406       compute->width = compute->variable->width;
 407
 408       /* Goofy behavior, but compatible: Turn off LEAVE. */
 409       if (dict_class_from_id (compute->variable->name) != DC_SCRATCH)
 410         compute->variable->reinit = 1;
 411     }
 412   else
 413     {
 414       compute->vector = lvalue->vector;
 415       compute->element = lvalue->element;
 416       lvalue->element = NULL;
 417     }
 418
 419   lvalue_destroy (lvalue);
 420 }
 421
 422 /* Destroys LVALUE. */
 423 static void
 424 lvalue_destroy (struct lvalue *lvalue)
 425 {
 426   if ( ! lvalue )
 427      return ;
 428
 429   expr_free (lvalue->element);
 430   free (lvalue);
 431 }