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