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 "expr.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 (compute->test, c, case_num, NULL) == 1.0)
 116     {
 117       expr_evaluate (compute->rvalue, c, case_num,
 118                      case_data_rw (c, compute->fv));
 119     }
 120
 121   return -1;
 122 }
 123
 124 /* Handle COMPUTE or IF with numeric vector element target
 125    variable. */
 126 static int
 127 compute_num_vec (struct trns_header *compute_, struct ccase *c,
 128                  int case_num)
 129 {
 130   struct compute_trns *compute = (struct compute_trns *) compute_;
 131
 132   if (compute->test == NULL
 133       || expr_evaluate (compute->test, c, case_num, NULL) == 1.0)
 134     {
 135       /* Index into the vector. */
 136       union value index;
 137
 138       /* Rounded index value. */
 139       int rindx;
 140
 141       expr_evaluate (compute->element, c, case_num, &index);
 142       rindx = floor (index.f + EPSILON);
 143       if (index.f == SYSMIS || rindx < 1 || rindx > compute->vector->cnt)
 144         {
 145           if (index.f == SYSMIS)
 146             msg (SW, _("When executing COMPUTE: SYSMIS is not a valid value as "
 147                        "an index into vector %s."), compute->vector->name);
 148           else
 149             msg (SW, _("When executing COMPUTE: %g is not a valid value as "
 150                        "an index into vector %s."),
 151                  index.f, compute->vector->name);
 152           return -1;
 153         }
 154       expr_evaluate (compute->rvalue, c, case_num,
 155                      case_data_rw (c, compute->vector->var[rindx - 1]->fv));
 156     }
 157
 158   return -1;
 159 }
 160
 161 /* Handle COMPUTE or IF with string target variable. */
 162 static int
 163 compute_str (struct trns_header *compute_, struct ccase *c,
 164              int case_num)
 165 {
 166   struct compute_trns *compute = (struct compute_trns *) compute_;
 167
 168   if (compute->test == NULL
 169       || expr_evaluate (compute->test, c, case_num, NULL) == 1.0)
 170     {
 171       /* Temporary storage for string expression return value. */
 172       union value v;
 173
 174       expr_evaluate (compute->rvalue, c, case_num, &v);
 175       st_bare_pad_len_copy (case_data_rw (c, compute->fv)->s,
 176                             &v.c[1], compute->width, v.c[0]);
 177     }
 178
 179   return -1;
 180 }
 181
 182 /* Handle COMPUTE or IF with string vector element target
 183    variable. */
 184 static int
 185 compute_str_vec (struct trns_header *compute_, struct ccase *c,
 186                  int case_num)
 187 {
 188   struct compute_trns *compute = (struct compute_trns *) compute_;
 189
 190   if (compute->test == NULL
 191       || expr_evaluate (compute->test, c, case_num, NULL) == 1.0)
 192     {
 193       /* Temporary storage for string expression return value. */
 194       union value v;
 195
 196       /* Index into the vector. */
 197       union value index;
 198
 199       /* Rounded index value. */
 200       int rindx;
 201
 202       /* Variable reference by indexed vector. */
 203       struct variable *vr;
 204
 205       expr_evaluate (compute->element, c, case_num, &index);
 206       rindx = floor (index.f + EPSILON);
 207       if (index.f == SYSMIS || rindx < 1 || rindx > compute->vector->cnt)
 208         {
 209           if (index.f == SYSMIS)
 210             msg (SW, _("When executing COMPUTE: SYSMIS is not a valid "
 211                        "value as an index into vector %s."),
 212                  compute->vector->name);
 213           else
 214             msg (SW, _("When executing COMPUTE: %g is not a valid value as "
 215                        "an index into vector %s."),
 216                  index.f, compute->vector->name);
 217           return -1;
 218         }
 219
 220       expr_evaluate (compute->rvalue, c, case_num, &v);
 221       vr = compute->vector->var[rindx - 1];
 222       st_bare_pad_len_copy (case_data_rw (c, vr->fv)->s,
 223                             &v.c[1], vr->width, v.c[0]);
 224     }
 225
 226   return -1;
 227 }
 228 \f
 229 /* IF. */
 230
 231 int
 232 cmd_if (void)
 233 {
 234   struct compute_trns *compute = NULL;
 235   struct lvalue *lvalue = NULL;
 236
 237   compute = compute_trns_create ();
 238
 239   /* Test expression. */
 240   compute->test = expr_parse (EXPR_BOOLEAN);
 241   if (compute->test == NULL)
 242     goto fail;
 243
 244   /* Lvalue variable. */
 245   lvalue = lvalue_parse ();
 246   if (lvalue == NULL)
 247     goto fail;
 248
 249   /* Rvalue expression. */
 250   if (!lex_force_match ('=') || !parse_rvalue_expression (compute, lvalue))
 251     goto fail;
 252
 253   lvalue_finalize (lvalue, compute);
 254
 255   add_transformation (&compute->h);
 256
 257   return CMD_SUCCESS;
 258
 259  fail:
 260   lvalue_destroy (lvalue);
 261   if (compute != NULL)
 262     {
 263       compute_trns_free (&compute->h);
 264       free (compute);
 265     }
 266   return CMD_FAILURE;
 267 }
 268 \f
 269 /* Code common to COMPUTE and IF. */
 270
 271 /* Checks for type mismatches on transformation C.  Also checks for
 272    command terminator, sets the case-handling proc from the array
 273    passed. */
 274 static int
 275 parse_rvalue_expression (struct compute_trns *compute,
 276                          const struct lvalue *lvalue)
 277 {
 278   int type = lvalue_get_type (lvalue);
 279   int vector = lvalue_is_vector (lvalue);
 280
 281   assert (type == NUMERIC || type == ALPHA);
 282
 283   compute->rvalue = expr_parse (type == ALPHA ? EXPR_STRING : EXPR_NUMERIC);
 284   if (compute->rvalue == NULL)
 285     return 0;
 286
 287   if (type == NUMERIC)
 288     compute->h.proc = vector ? compute_num_vec : compute_num;
 289   else
 290     compute->h.proc = vector ? compute_str_vec : compute_str;
 291
 292   if (token != '.')
 293     {
 294       lex_error (_("expecting end of command"));
 295       return 0;
 296     }
 297
 298   return 1;
 299 }
 300
 301 /* Returns a new struct compute_trns after initializing its fields. */
 302 static struct compute_trns *
 303 compute_trns_create (void)
 304 {
 305   struct compute_trns *compute = xmalloc (sizeof *compute);
 306   compute->h.proc = NULL;
 307   compute->h.free = compute_trns_free;
 308   compute->test = NULL;
 309   compute->variable = NULL;
 310   compute->vector = NULL;
 311   compute->element = NULL;
 312   compute->rvalue = NULL;
 313   return compute;
 314 }
 315
 316 /* Deletes all the fields in COMPUTE. */
 317 static void
 318 compute_trns_free (struct trns_header *compute_)
 319 {
 320   struct compute_trns *compute = (struct compute_trns *) compute_;
 321
 322   expr_free (compute->test);
 323   expr_free (compute->element);
 324   expr_free (compute->rvalue);
 325 }
 326 \f
 327 /* COMPUTE or IF target variable or vector element. */
 328 struct lvalue
 329   {
 330     char var_name[9];            /* Destination variable name, or "". */
 331     const struct vector *vector; /* Destination vector, if any, or NULL. */
 332     struct expression *element;  /* Destination vector element, or NULL. */
 333   };
 334
 335 /* Parses the target variable or vector elector into a new
 336    `struct lvalue', which is returned. */
 337 static struct lvalue *
 338 lvalue_parse (void)
 339 {
 340   struct lvalue *lvalue;
 341
 342   lvalue = xmalloc (sizeof *lvalue);
 343   lvalue->var_name[0] = '\0';
 344   lvalue->vector = NULL;
 345   lvalue->element = NULL;
 346
 347   if (!lex_force_id ())
 348     goto lossage;
 349
 350   if (lex_look_ahead () == '(')
 351     {
 352       /* Vector. */
 353       lvalue->vector = dict_lookup_vector (default_dict, tokid);
 354       if (lvalue->vector == NULL)
 355         {
 356           msg (SE, _("There is no vector named %s."), tokid);
 357           goto lossage;
 358         }
 359
 360       /* Vector element. */
 361       lex_get ();
 362       if (!lex_force_match ('('))
 363         goto lossage;
 364       lvalue->element = expr_parse (EXPR_NUMERIC);
 365       if (lvalue->element == NULL)
 366         goto lossage;
 367       if (!lex_force_match (')'))
 368         goto lossage;
 369     }
 370   else
 371     {
 372       /* Variable name. */
 373       strncpy (lvalue->var_name, tokid, 8);
 374       lvalue->var_name[8] = '\0';
 375       lex_get ();
 376     }
 377   return lvalue;
 378
 379  lossage:
 380   lvalue_destroy (lvalue);
 381   return NULL;
 382 }
 383
 384 /* Returns the type (NUMERIC or ALPHA) of the target variable or
 385    vector in LVALUE. */
 386 static int
 387 lvalue_get_type (const struct lvalue *lvalue)
 388 {
 389   if (lvalue->vector == NULL)
 390     {
 391       struct variable *var
 392         = dict_lookup_var (default_dict, lvalue->var_name);
 393       if (var == NULL)
 394         return NUMERIC;
 395       else
 396         return var->type;
 397     }
 398   else
 399     return lvalue->vector->var[0]->type;
 400 }
 401
 402 /* Returns nonzero if LVALUE has a vector as its target. */
 403 static int
 404 lvalue_is_vector (const struct lvalue *lvalue)
 405 {
 406   return lvalue->vector != NULL;
 407 }
 408
 409 /* Finalizes making LVALUE the target of COMPUTE, by creating the
 410    target variable if necessary and setting fields in COMPUTE. */
 411 static void
 412 lvalue_finalize (struct lvalue *lvalue,
 413                  struct compute_trns *compute)
 414 {
 415   if (lvalue->vector == NULL)
 416     {
 417       compute->variable = dict_lookup_var (default_dict, lvalue->var_name);
 418       if (compute->variable == NULL)
 419           compute->variable = dict_create_var_assert (default_dict,
 420                                                       lvalue->var_name, 0);
 421
 422       compute->fv = compute->variable->fv;
 423       compute->width = compute->variable->width;
 424
 425       /* Goofy behavior, but compatible: Turn off LEAVE. */
 426       if (dict_class_from_id (compute->variable->name) != DC_SCRATCH)
 427         compute->variable->reinit = 1;
 428     }
 429   else
 430     {
 431       compute->vector = lvalue->vector;
 432       compute->element = lvalue->element;
 433       lvalue->element = NULL;
 434     }
 435
 436   lvalue_destroy (lvalue);
 437 }
 438
 439 /* Destroys LVALUE. */
 440 static void
 441 lvalue_destroy (struct lvalue *lvalue)
 442 {
 443   if ( ! lvalue )
 444      return ;
 445
 446   expr_free (lvalue->element);
 447   free (lvalue);
 448 }