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