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