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