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