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