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