src/expr-prs.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 "expr.h"
  22 #include "exprP.h"
  23 #include "error.h"
  24 #include <ctype.h>
  25 #include <float.h>
  26 #include <stdlib.h>
  27 #include "algorithm.h"
  28 #include "alloc.h"
  29 #include "error.h"
  30 #include "lexer.h"
  31 #include "misc.h"
  32 #include "settings.h"
  33 #include "str.h"
  34 #include "var.h"
  35 #include "vfm.h"
  36 #include "pool.h"
  37 \f
  38 /* Declarations. */
  39
  40 /* Recursive descent parser in order of increasing precedence. */
  41 typedef enum expr_type parse_recursively_func (union any_node **);
  42 static parse_recursively_func parse_or, parse_and, parse_not;
  43 static parse_recursively_func parse_rel, parse_add, parse_mul;
  44 static parse_recursively_func parse_neg, parse_exp;
  45 static parse_recursively_func parse_primary, parse_function;
  46
  47 /* Utility functions. */
  48 static const char *expr_type_name (enum expr_type type);
  49 static const char *var_type_name (int var_type);
  50 static void make_bool (union any_node **n);
  51 static union any_node *allocate_nonterminal (int op, union any_node *n);
  52 static union any_node *allocate_binary_nonterminal (int op, union any_node *,
  53                                                     union any_node *);
  54 static union any_node *allocate_num_con (double value);
  55 static union any_node *allocate_str_con (const char *string, size_t length);
  56 static union any_node *allocate_var_node (int type, struct variable *);
  57 static int type_check (union any_node **n,
  58                        enum expr_type actual_type,
  59                        enum expr_type expected_type);
  60
  61 static algo_compare_func compare_functions;
  62 static void init_func_tab (void);
  63 \f
  64 /* Public functions. */
  65
  66 void
  67 expr_free (struct expression *e)
  68 {
  69   if (e == NULL)
  70     return;
  71
  72   free (e->op);
  73   free (e->var);
  74   free (e->num);
  75   free (e->str);
  76   free (e->stack);
  77   pool_destroy (e->pool);
  78   free (e);
  79 }
  80
  81 struct expression *
  82 expr_parse (enum expr_type expected_type)
  83 {
  84   struct expression *e;
  85   union any_node *n;
  86   enum expr_type actual_type;
  87   int optimize = (expected_type & EXPR_NO_OPTIMIZE) == 0;
  88
  89   expected_type &= ~EXPR_NO_OPTIMIZE;
  90
  91   /* Make sure the table of functions is initialized. */
  92   init_func_tab ();
  93
  94   /* Parse the expression. */
  95   actual_type = parse_or (&n);
  96   if (actual_type == EXPR_ERROR)
  97     return NULL;
  98
  99   /* Enforce type rules. */
 100   if (!type_check (&n, actual_type, expected_type))
 101     {
 102       free_node (n);
 103       return NULL;
 104     }
 105
 106   /* Optimize the expression as best we can. */
 107   if (optimize)
 108     optimize_expression (&n);
 109
 110   /* Dump the tree-based expression to a postfix representation for
 111      best evaluation speed, and destroy the tree. */
 112   e = xmalloc (sizeof *e);
 113   e->type = actual_type;
 114   dump_expression (n, e);
 115   free_node (n);
 116
 117   return e;
 118 }
 119
 120 /* Returns the type of EXPR. */
 121 enum expr_type
 122 expr_get_type (const struct expression *expr)
 123 {
 124   assert (expr != NULL);
 125   return expr->type;
 126 }
 127
 128 static int
 129 type_check (union any_node **n, enum expr_type actual_type, enum expr_type expected_type)
 130 {
 131   switch (expected_type)
 132     {
 133     case EXPR_BOOLEAN:
 134     case EXPR_NUMERIC:
 135       if (actual_type == EXPR_STRING)
 136         {
 137           msg (SE, _("Type mismatch: expression has string type, "
 138                      "but a numeric value is required here."));
 139           return 0;
 140         }
 141       if (actual_type == EXPR_NUMERIC && expected_type == EXPR_BOOLEAN)
 142         *n = allocate_nonterminal (OP_NUM_TO_BOOL, *n);
 143       break;
 144
 145     case EXPR_STRING:
 146       if (actual_type != EXPR_STRING)
 147         {
 148           msg (SE, _("Type mismatch: expression has numeric type, "
 149                      "but a string value is required here."));
 150           return 0;
 151         }
 152       break;
 153
 154     case EXPR_ANY:
 155       break;
 156
 157     default:
 158       assert (0);
 159     }
 160
 161   return 1;
 162 }
 163 \f
 164 /* Recursive-descent expression parser. */
 165
 166 /* Coerces *NODE, of type ACTUAL_TYPE, to type REQUIRED_TYPE, and
 167    returns success.  If ACTUAL_TYPE cannot be coerced to the
 168    desired type then we issue an error message about operator
 169    OPERATOR_NAME and free *NODE. */
 170 static int
 171 type_coercion (enum expr_type actual_type, enum expr_type required_type,
 172                union any_node **node,
 173                const char *operator_name)
 174 {
 175   assert (required_type == EXPR_NUMERIC
 176           || required_type == EXPR_BOOLEAN
 177           || required_type == EXPR_STRING);
 178
 179   if (actual_type == required_type)
 180     {
 181       /* Type match. */
 182       return 1;
 183     }
 184   else if (actual_type == EXPR_ERROR)
 185     {
 186       /* Error already reported. */
 187       *node = NULL;
 188       return 0;
 189     }
 190   else if (actual_type == EXPR_BOOLEAN && required_type == EXPR_NUMERIC)
 191     {
 192       /* Boolean -> numeric: nothing to do. */
 193       return 1;
 194     }
 195   else if (actual_type == EXPR_NUMERIC && required_type == EXPR_BOOLEAN)
 196     {
 197       /* Numeric -> Boolean: insert conversion. */
 198       make_bool (node);
 199       return 1;
 200     }
 201   else
 202     {
 203       /* We want a string and got a number/Boolean, or vice versa. */
 204       assert ((actual_type == EXPR_STRING) != (required_type == EXPR_STRING));
 205
 206       if (required_type == EXPR_STRING)
 207         msg (SE, _("Type mismatch: operands of %s operator must be strings."),
 208              operator_name);
 209       else
 210         msg (SE, _("Type mismatch: operands of %s operator must be numeric."),
 211              operator_name);
 212       free_node (*node);
 213       *node = NULL;
 214       return 0;
 215     }
 216 }
 217
 218 /* An operator. */
 219 struct operator
 220   {
 221     int token;          /* Operator token. */
 222     int type;           /* Operator node type. */
 223     const char *name;   /* Operator name. */
 224   };
 225
 226 /* Attempts to match the current token against the tokens for the
 227    OP_CNT operators in OPS[].  If successful, returns nonzero
 228    and, if OPERATOR is non-null, sets *OPERATOR to the operator.
 229    On failure, returns zero and, if OPERATOR is non-null, sets
 230    *OPERATOR to a null pointer. */
 231 static int
 232 match_operator (const struct operator ops[], size_t op_cnt,
 233                 const struct operator **operator)
 234 {
 235   const struct operator *op;
 236
 237   for (op = ops; op < ops + op_cnt; op++)
 238     {
 239       if (op->token == '-')
 240         lex_negative_to_dash ();
 241       if (lex_match (op->token))
 242         {
 243           if (operator != NULL)
 244             *operator = op;
 245           return 1;
 246         }
 247     }
 248   if (operator != NULL)
 249     *operator = NULL;
 250   return 0;
 251 }
 252
 253 /* Parses a chain of left-associative operator/operand pairs.
 254    The operators' operands uniformly must be type REQUIRED_TYPE.
 255    There are OP_CNT operators, specified in OPS[].  The next
 256    higher level is parsed by PARSE_NEXT_LEVEL.  If CHAIN_WARNING
 257    is non-null, then it will be issued as a warning if more than
 258    one operator/operand pair is parsed. */
 259 static enum expr_type
 260 parse_binary_operators (union any_node **node,
 261                         enum expr_type actual_type,
 262                         enum expr_type required_type,
 263                         enum expr_type result_type,
 264                         const struct operator ops[], size_t op_cnt,
 265                         parse_recursively_func *parse_next_level,
 266                         const char *chain_warning)
 267 {
 268   int op_count;
 269   const struct operator *operator;
 270
 271   if (actual_type == EXPR_ERROR)
 272     return EXPR_ERROR;
 273
 274   for (op_count = 0; match_operator (ops, op_cnt, &operator); op_count++)
 275     {
 276       union any_node *rhs;
 277
 278       /* Convert the left-hand side to type REQUIRED_TYPE. */
 279       if (!type_coercion (actual_type, required_type, node, operator->name))
 280         return EXPR_ERROR;
 281
 282       /* Parse the right-hand side and coerce to type
 283          REQUIRED_TYPE. */
 284       if (!type_coercion (parse_next_level (&rhs), required_type,
 285                           &rhs, operator->name))
 286         {
 287           free_node (*node);
 288           *node = NULL;
 289           return EXPR_ERROR;
 290         }
 291       *node = allocate_binary_nonterminal (operator->type, *node, rhs);
 292
 293       /* The result is of type RESULT_TYPE. */
 294       actual_type = result_type;
 295     }
 296
 297   if (op_count > 1 && chain_warning != NULL)
 298     msg (SW, chain_warning);
 299
 300   return actual_type;
 301 }
 302
 303 static enum expr_type
 304 parse_inverting_unary_operator (union any_node **node,
 305                                 enum expr_type required_type,
 306                                 const struct operator *operator,
 307                                 parse_recursively_func *parse_next_level)
 308 {
 309   unsigned op_count;
 310
 311   op_count = 0;
 312   while (match_operator (operator, 1, NULL))
 313     op_count++;
 314   if (op_count == 0)
 315     return parse_next_level (node);
 316
 317   if (!type_coercion (parse_next_level (node), required_type,
 318                       node, operator->name))
 319     return EXPR_ERROR;
 320   if (op_count % 2 != 0)
 321     *node = allocate_nonterminal (operator->type, *node);
 322   return required_type;
 323 }
 324
 325 /* Parses the OR level. */
 326 static enum expr_type
 327 parse_or (union any_node **n)
 328 {
 329   static const struct operator ops[] =
 330     {
 331       { T_OR, OP_OR, "logical disjunction (\"OR\")" },
 332     };
 333
 334   return parse_binary_operators (n, parse_and (n), EXPR_BOOLEAN, EXPR_BOOLEAN,
 335                                  ops, sizeof ops / sizeof *ops,
 336                                  parse_and, NULL);
 337 }
 338
 339 /* Parses the AND level. */
 340 static enum expr_type
 341 parse_and (union any_node ** n)
 342 {
 343   static const struct operator ops[] =
 344     {
 345       { T_AND, OP_AND, "logical conjunction (\"AND\")" },
 346     };
 347
 348   return parse_binary_operators (n, parse_not (n), EXPR_BOOLEAN, EXPR_BOOLEAN,
 349                                  ops, sizeof ops / sizeof *ops,
 350                                  parse_not, NULL);
 351 }
 352
 353 /* Parses the NOT level. */
 354 static enum expr_type
 355 parse_not (union any_node ** n)
 356 {
 357   static const struct operator op
 358     = { T_NOT, OP_NOT, "logical negation (\"NOT-\")" };
 359   return parse_inverting_unary_operator (n, EXPR_BOOLEAN, &op, parse_rel);
 360 }
 361
 362 /* Parse relational operators. */
 363 static enum expr_type
 364 parse_rel (union any_node **n)
 365 {
 366   static const struct operator numeric_ops[] =
 367     {
 368       { '=', OP_EQ, "numeric equality (\"=\")" },
 369       { T_EQ, OP_EQ, "numeric equality (\"EQ\")" },
 370       { T_GE, OP_GE, "numeric greater-than-or-equal-to (\">=\")" },
 371       { T_GT, OP_GT, "numeric greater than (\">\")" },
 372       { T_LE, OP_LE, "numeric less-than-or-equal-to (\"<=\")" },
 373       { T_LT, OP_LT, "numeric less than (\"<\")" },
 374       { T_NE, OP_NE, "numeric inequality (\"<>\")" },
 375     };
 376
 377   static const struct operator string_ops[] =
 378     {
 379       { '=', OP_EQ_STRING, "string equality (\"=\")" },
 380       { T_EQ, OP_EQ_STRING, "string equality (\"EQ\")" },
 381       { T_GE, OP_GE_STRING, "string greater-than-or-equal-to (\">=\")" },
 382       { T_GT, OP_GT_STRING, "string greater than (\">\")" },
 383       { T_LE, OP_LE_STRING, "string less-than-or-equal-to (\"<=\")" },
 384       { T_LT, OP_LT_STRING, "string less than (\"<\")" },
 385       { T_NE, OP_NE_STRING, "string inequality (\"<>\")" },
 386     };
 387
 388   int type = parse_add (n);
 389
 390   const char *chain_warning =
 391     _("Chaining relational operators (e.g. \"a < b < c\") will "
 392       "not produce the mathematically expected result.  "
 393       "Use the AND logical operator to fix the problem "
 394       "(e.g. \"a < b AND b < c\").  "
 395       "If chaining is really intended, parentheses will disable "
 396       "this warning (e.g. \"(a < b) < c\".)");
 397
 398   switch (type)
 399     {
 400     case EXPR_ERROR:
 401       return EXPR_ERROR;
 402
 403     case EXPR_NUMERIC:
 404     case EXPR_BOOLEAN:
 405       return parse_binary_operators (n,
 406                                      type, EXPR_NUMERIC, EXPR_BOOLEAN,
 407                                      numeric_ops,
 408                                      sizeof numeric_ops / sizeof *numeric_ops,
 409                                      parse_add, chain_warning);
 410
 411     case EXPR_STRING:
 412       return parse_binary_operators (n,
 413                                      type, EXPR_STRING, EXPR_BOOLEAN,
 414                                      string_ops,
 415                                      sizeof string_ops / sizeof *string_ops,
 416                                      parse_add, chain_warning);
 417
 418     default:
 419       assert (0);
 420       abort ();
 421     }
 422 }
 423
 424 /* Parses the addition and subtraction level. */
 425 static enum expr_type
 426 parse_add (union any_node **n)
 427 {
 428   static const struct operator ops[] =
 429     {
 430       { '+', OP_ADD, "addition (\"+\")" },
 431       { '-', OP_SUB, "subtraction (\"-\")-" },
 432     };
 433
 434   return parse_binary_operators (n, parse_mul (n), EXPR_NUMERIC, EXPR_NUMERIC,
 435                                  ops, sizeof ops / sizeof *ops,
 436                                  parse_mul, NULL);
 437 }
 438
 439 /* Parses the multiplication and division level. */
 440 static enum expr_type
 441 parse_mul (union any_node ** n)
 442 {
 443   static const struct operator ops[] =
 444     {
 445       { '*', OP_MUL, "multiplication (\"*\")" },
 446       { '/', OP_DIV, "division (\"/\")" },
 447     };
 448
 449   return parse_binary_operators (n, parse_neg (n), EXPR_NUMERIC, EXPR_NUMERIC,
 450                                  ops, sizeof ops / sizeof *ops,
 451                                  parse_neg, NULL);
 452 }
 453
 454 /* Parses the unary minus level. */
 455 static enum expr_type
 456 parse_neg (union any_node **n)
 457 {
 458   static const struct operator op = { '-', OP_NEG, "negation (\"-\")" };
 459   return parse_inverting_unary_operator (n, EXPR_NUMERIC, &op, parse_exp);
 460 }
 461
 462 static enum expr_type
 463 parse_exp (union any_node **n)
 464 {
 465   static const struct operator ops[] =
 466     {
 467       { T_EXP, OP_POW, "exponentiation (\"**\")" },
 468     };
 469
 470   const char *chain_warning =
 471     _("The exponentiation operator (\"**\") is left-associative, "
 472       "even though right-associative semantics are more useful.  "
 473       "That is, \"a**b**c\" equals \"(a**b)**c\", not as \"a**(b**c)\".  "
 474       "To disable this warning, insert parentheses.");
 475
 476   return parse_binary_operators (n,
 477                                  parse_primary (n), EXPR_NUMERIC, EXPR_NUMERIC,
 478                                  ops, sizeof ops / sizeof *ops,
 479                                  parse_primary, chain_warning);
 480 }
 481
 482 /* Parses system variables. */
 483 static enum expr_type
 484 parse_sysvar (union any_node **n)
 485 {
 486   if (!strcmp (tokid, "$CASENUM"))
 487     {
 488       *n = xmalloc (sizeof (struct casenum_node));
 489       (*n)->casenum.type = OP_CASENUM;
 490       return EXPR_NUMERIC;
 491     }
 492   else if (!strcmp (tokid, "$DATE"))
 493     {
 494       static const char *months[12] =
 495         {
 496           "JAN", "FEB", "MAR", "APR", "MAY", "JUN",
 497           "JUL", "AUG", "SEP", "OCT", "NOV", "DEC",
 498         };
 499
 500       struct tm *time;
 501       char temp_buf[10];
 502
 503       time = localtime (&last_vfm_invocation);
 504       sprintf (temp_buf, "%02d %s %02d", abs (time->tm_mday) % 100,
 505                months[abs (time->tm_mon) % 12], abs (time->tm_year) % 100);
 506
 507       *n = xmalloc (sizeof (struct str_con_node) + 8);
 508       (*n)->str_con.type = OP_STR_CON;
 509       (*n)->str_con.len = 9;
 510       memcpy ((*n)->str_con.s, temp_buf, 9);
 511       return EXPR_STRING;
 512     }
 513   else
 514     {
 515       enum expr_type type;
 516       double d;
 517
 518       type = EXPR_NUMERIC;
 519       if (!strcmp (tokid, "$TRUE"))
 520         {
 521           d = 1.0;
 522           type = EXPR_BOOLEAN;
 523         }
 524       else if (!strcmp (tokid, "$FALSE"))
 525         {
 526           d = 0.0;
 527           type = EXPR_BOOLEAN;
 528         }
 529       else if (!strcmp (tokid, "$SYSMIS"))
 530         d = SYSMIS;
 531       else if (!strcmp (tokid, "$JDATE"))
 532         {
 533           struct tm *time = localtime (&last_vfm_invocation);
 534           d = yrmoda (time->tm_year + 1900, time->tm_mon + 1, time->tm_mday);
 535         }
 536       else if (!strcmp (tokid, "$TIME"))
 537         {
 538           struct tm *time;
 539           time = localtime (&last_vfm_invocation);
 540           d = (yrmoda (time->tm_year + 1900, time->tm_mon + 1,
 541                        time->tm_mday) * 60. * 60. * 24.
 542                + time->tm_hour * 60 * 60.
 543                + time->tm_min * 60.
 544                + time->tm_sec);
 545         }
 546       else if (!strcmp (tokid, "$LENGTH"))
 547         d = get_viewlength ();
 548       else if (!strcmp (tokid, "$WIDTH"))
 549         d = get_viewwidth ();
 550       else
 551         {
 552           msg (SE, _("Unknown system variable %s."), tokid);
 553           return EXPR_ERROR;
 554         }
 555
 556       *n = xmalloc (sizeof (struct num_con_node));
 557       (*n)->num_con.type = OP_NUM_CON;
 558       (*n)->num_con.value = d;
 559       return type;
 560     }
 561 }
 562
 563 /* Parses numbers, varnames, etc. */
 564 static enum expr_type
 565 parse_primary (union any_node **n)
 566 {
 567   switch (token)
 568     {
 569     case T_ID:
 570       {
 571         struct variable *v;
 572
 573         /* An identifier followed by a left parenthesis is a function
 574            call. */
 575         if (lex_look_ahead () == '(')
 576           return parse_function (n);
 577
 578         /* $ at the beginning indicates a system variable. */
 579         if (tokid[0] == '$')
 580           {
 581             enum expr_type type = parse_sysvar (n);
 582             lex_get ();
 583             return type;
 584           }
 585
 586         /* Otherwise, it must be a user variable. */
 587         v = dict_lookup_var (default_dict, tokid);
 588         lex_get ();
 589         if (v == NULL)
 590           {
 591             lex_error (_("expecting variable name"));
 592             return EXPR_ERROR;
 593           }
 594
 595         if (v->type == NUMERIC)
 596           {
 597             *n = allocate_var_node (OP_NUM_VAR, v);
 598             return EXPR_NUMERIC;
 599           }
 600         else
 601           {
 602             *n = allocate_var_node (OP_STR_VAR, v);
 603             return EXPR_STRING;
 604           }
 605       }
 606
 607     case T_NUM:
 608       *n = allocate_num_con (tokval);
 609       lex_get ();
 610       return EXPR_NUMERIC;
 611
 612     case T_STRING:
 613       {
 614         *n = allocate_str_con (ds_c_str (&tokstr), ds_length (&tokstr));
 615         lex_get ();
 616         return EXPR_STRING;
 617       }
 618
 619     case '(':
 620       {
 621         int t;
 622         lex_get ();
 623         t = parse_or (n);
 624         if (!lex_match (')'))
 625           {
 626             lex_error (_("expecting `)'"));
 627             free_node (*n);
 628             return EXPR_ERROR;
 629           }
 630         return t;
 631       }
 632
 633     default:
 634       lex_error (_("in expression"));
 635       return EXPR_ERROR;
 636     }
 637 }
 638 \f
 639 /* Individual function parsing. */
 640
 641 struct function
 642   {
 643     const char *s;
 644     int t;
 645     enum expr_type (*func) (const struct function *, int, union any_node **);
 646   };
 647
 648 static struct function func_tab[];
 649 static int func_count;
 650
 651 static int get_num_args (const struct function *, int, union any_node **);
 652
 653 static enum expr_type
 654 unary_func (const struct function *f, int x UNUSED, union any_node ** n)
 655 {
 656   if (!get_num_args (f, 1, n))
 657     return EXPR_ERROR;
 658   return EXPR_NUMERIC;
 659 }
 660
 661 static enum expr_type
 662 binary_func (const struct function *f, int x UNUSED, union any_node ** n)
 663 {
 664   if (!get_num_args (f, 2, n))
 665     return EXPR_ERROR;
 666   return EXPR_NUMERIC;
 667 }
 668
 669 static enum expr_type
 670 ternary_func (const struct function *f, int x UNUSED, union any_node **n)
 671 {
 672   if (!get_num_args (f, 3, n))
 673     return EXPR_ERROR;
 674   return EXPR_NUMERIC;
 675 }
 676
 677 static enum expr_type
 678 MISSING_func (const struct function *f, int x UNUSED, union any_node **n)
 679 {
 680   if (!get_num_args (f, 1, n))
 681     return EXPR_ERROR;
 682   return EXPR_BOOLEAN;
 683 }
 684
 685 static enum expr_type
 686 SYSMIS_func (const struct function *f, int x UNUSED, union any_node **n)
 687 {
 688   if (!get_num_args (f, 1, n))
 689     return EXPR_ERROR;
 690   if ((*n)->nonterm.arg[0]->type == OP_NUM_VAR)
 691     {
 692       struct variable *v = (*n)->nonterm.arg[0]->var.v;
 693       free_node (*n);
 694       *n = allocate_var_node (OP_NUM_SYS, v);
 695     }
 696   return EXPR_BOOLEAN;
 697 }
 698
 699 static enum expr_type
 700 VALUE_func (const struct function *f UNUSED, int x UNUSED, union any_node **n)
 701 {
 702   struct variable *v = parse_variable ();
 703
 704   if (!v)
 705     return EXPR_ERROR;
 706   if (v->type == NUMERIC)
 707     {
 708       *n = allocate_var_node (OP_NUM_VAL, v);
 709       return EXPR_NUMERIC;
 710     }
 711   else
 712     {
 713       *n = allocate_var_node (OP_STR_VAR, v);
 714       return EXPR_STRING;
 715     }
 716 }
 717
 718 static enum expr_type
 719 LAG_func (const struct function *f UNUSED, int x UNUSED, union any_node **n)
 720 {
 721   struct variable *v = parse_variable ();
 722   int nlag = 1;
 723
 724   if (!v)
 725     return EXPR_ERROR;
 726   if (lex_match (','))
 727     {
 728       if (!lex_integer_p () || lex_integer () <= 0 || lex_integer () > 1000)
 729         {
 730           msg (SE, _("Argument 2 to LAG must be a small positive "
 731                      "integer constant."));
 732           return EXPR_ERROR;
 733         }
 734
 735       nlag = lex_integer ();
 736       lex_get ();
 737     }
 738   n_lag = max (nlag, n_lag);
 739   *n = xmalloc (sizeof (struct lag_node));
 740   (*n)->lag.type = (v->type == NUMERIC ? OP_NUM_LAG : OP_STR_LAG);
 741   (*n)->lag.v = v;
 742   (*n)->lag.lag = nlag;
 743   return (v->type == NUMERIC ? EXPR_NUMERIC : EXPR_STRING);
 744 }
 745
 746 /* This screwball function parses n-ary operators:
 747
 748    1. NMISS, NVALID, SUM, MEAN: any number of numeric
 749       arguments.
 750
 751    2. SD, VARIANCE, CFVAR: at least two numeric arguments.
 752
 753    3. RANGE: An odd number of arguments, but at least three, and
 754       all of the same type.
 755
 756    4. ANY: At least two arguments, all of the same type.
 757
 758    5. MIN, MAX: Any number of arguments, all of the same type.
 759  */
 760 static enum expr_type
 761 nary_num_func (const struct function *f, int min_args, union any_node **n)
 762 {
 763   /* Argument number of current argument (used for error messages). */
 764   int arg_idx = 1;
 765
 766   /* Number of arguments. */
 767   int nargs;
 768
 769   /* Number of arguments allocated. */
 770   int m = 16;
 771
 772   /* Type of arguments. */
 773   int type = (f->t == OP_ANY || f->t == OP_RANGE
 774               || f->t == OP_MIN || f->t == OP_MAX) ? -1 : NUMERIC;
 775
 776   *n = xmalloc (sizeof (struct nonterm_node) + sizeof (union any_node *[15]));
 777   (*n)->nonterm.type = f->t;
 778   (*n)->nonterm.n = 0;
 779   for (;;)
 780     {
 781       /* Special case: vara TO varb. */
 782
 783       /* FIXME: Is this condition failsafe?  Can we _ever_ have two
 784          juxtaposed identifiers otherwise?  */
 785       if (token == T_ID && dict_lookup_var (default_dict, tokid) != NULL
 786           && toupper (lex_look_ahead ()) == 'T')
 787         {
 788           struct variable **v;
 789           int nv;
 790           int j;
 791           int opts = PV_SINGLE;
 792
 793           if (type == NUMERIC)
 794             opts |= PV_NUMERIC;
 795           else if (type == ALPHA)
 796             opts |= PV_STRING;
 797           if (!parse_variables (default_dict, &v, &nv, opts))
 798             goto fail;
 799           if (nv + (*n)->nonterm.n >= m)
 800             {
 801               m += nv + 16;
 802               *n = xrealloc (*n, (sizeof (struct nonterm_node)
 803                                   + (m - 1) * sizeof (union any_node *)));
 804             }
 805           if (type == -1)
 806             {
 807               type = v[0]->type;
 808               for (j = 1; j < nv; j++)
 809                 if (type != v[j]->type)
 810                   {
 811                     msg (SE, _("Type mismatch in argument %d of %s, which was "
 812                                "expected to be of %s type.  It was actually "
 813                                "of %s type. "),
 814                          arg_idx, f->s, var_type_name (type), var_type_name (v[j]->type));
 815                     free (v);
 816                     goto fail;
 817                   }
 818             }
 819           for (j = 0; j < nv; j++)
 820             {
 821               union any_node **c = &(*n)->nonterm.arg[(*n)->nonterm.n++];
 822               *c = allocate_var_node ((type == NUMERIC
 823                                        ? OP_NUM_VAR : OP_STR_VAR),
 824                                       v[j]);
 825             }
 826         }
 827       else
 828         {
 829           union any_node *c;
 830           int t = parse_or (&c);
 831
 832           if (t == EXPR_ERROR)
 833             goto fail;
 834           if (t == EXPR_BOOLEAN)
 835             {
 836               free_node (c);
 837               msg (SE, _("%s cannot take Boolean operands."), f->s);
 838               goto fail;
 839             }
 840           if (type == -1)
 841             {
 842               if (t == EXPR_NUMERIC)
 843                 type = NUMERIC;
 844               else if (t == EXPR_STRING)
 845                 type = ALPHA;
 846             }
 847           else if ((t == EXPR_NUMERIC) ^ (type == NUMERIC))
 848             {
 849               free_node (c);
 850               msg (SE, _("Type mismatch in argument %d of %s, which was "
 851                          "expected to be of %s type.  It was actually "
 852                          "of %s type. "),
 853                    arg_idx, f->s, var_type_name (type), expr_type_name (t));
 854               goto fail;
 855             }
 856           if ((*n)->nonterm.n + 1 >= m)
 857             {
 858               m += 16;
 859               *n = xrealloc (*n, (sizeof (struct nonterm_node)
 860                                   + (m - 1) * sizeof (union any_node *)));
 861             }
 862           (*n)->nonterm.arg[(*n)->nonterm.n++] = c;
 863         }
 864
 865       if (token == ')')
 866         break;
 867       if (!lex_match (','))
 868         {
 869           lex_error (_("in function call"));
 870           goto fail;
 871         }
 872
 873       arg_idx++;
 874     }
 875   *n = xrealloc (*n, (sizeof (struct nonterm_node)
 876                       + ((*n)->nonterm.n) * sizeof (union any_node *)));
 877
 878   nargs = (*n)->nonterm.n;
 879   if (f->t == OP_RANGE)
 880     {
 881       if (nargs < 3 || (nargs & 1) == 0)
 882         {
 883           msg (SE, _("RANGE requires an odd number of arguments, but "
 884                      "at least three."));
 885           goto fail;
 886         }
 887     }
 888   else if (f->t == OP_SD || f->t == OP_VARIANCE
 889            || f->t == OP_CFVAR || f->t == OP_ANY)
 890     {
 891       if (nargs < 2)
 892         {
 893           msg (SE, _("%s requires at least two arguments."), f->s);
 894           goto fail;
 895         }
 896     }
 897
 898   if (f->t == OP_CFVAR || f->t == OP_SD || f->t == OP_VARIANCE)
 899     min_args = max (min_args, 2);
 900   else
 901     min_args = max (min_args, 1);
 902
 903   /* Yes, this is admittedly a terrible crock, but it works. */
 904   (*n)->nonterm.arg[(*n)->nonterm.n] = (union any_node *) min_args;
 905
 906   if (min_args > nargs)
 907     {
 908       msg (SE, _("%s.%d requires at least %d arguments."),
 909            f->s, min_args, min_args);
 910       goto fail;
 911     }
 912
 913   if (f->t == OP_MIN || f->t == OP_MAX)
 914     {
 915       if (type == ALPHA)
 916         {
 917           if (f->t == OP_MIN)
 918             (*n)->type = OP_MIN_STRING;
 919           else if (f->t == OP_MAX)
 920             (*n)->type = OP_MAX_STRING;
 921           else
 922             assert (0);
 923           return EXPR_STRING;
 924         }
 925       else
 926         return EXPR_NUMERIC;
 927     }
 928   else if (f->t == OP_ANY || f->t == OP_RANGE)
 929     {
 930       if (type == ALPHA)
 931         {
 932           if (f->t == OP_ANY)
 933             (*n)->type = OP_ANY_STRING;
 934           else if (f->t == OP_RANGE)
 935             (*n)->type = OP_RANGE_STRING;
 936           else
 937             assert (0);
 938         }
 939       return EXPR_BOOLEAN;
 940     }
 941   else
 942     return EXPR_NUMERIC;
 943
 944 fail:
 945   free_node (*n);
 946   return EXPR_ERROR;
 947 }
 948
 949 static enum expr_type
 950 CONCAT_func (const struct function *f UNUSED, int x UNUSED, union any_node **n)
 951 {
 952   int m = 0;
 953
 954   int type;
 955
 956   *n = xmalloc (sizeof (struct nonterm_node) + sizeof (union any_node *[15]));
 957   (*n)->nonterm.type = OP_CONCAT;
 958   (*n)->nonterm.n = 0;
 959   for (;;)
 960     {
 961       if ((*n)->nonterm.n >= m)
 962         {
 963           m += 16;
 964           *n = xrealloc (*n, (sizeof (struct nonterm_node)
 965                               + (m - 1) * sizeof (union any_node *)));
 966         }
 967       type = parse_or (&(*n)->nonterm.arg[(*n)->nonterm.n]);
 968       if (type == EXPR_ERROR)
 969         goto fail;
 970       (*n)->nonterm.n++;
 971       if (type != EXPR_STRING)
 972         {
 973           msg (SE, _("Argument %d to CONCAT is type %s.  All arguments "
 974                      "to CONCAT must be strings."),
 975                (*n)->nonterm.n + 1, expr_type_name (type));
 976           goto fail;
 977         }
 978
 979       if (!lex_match (','))
 980         break;
 981     }
 982   *n = xrealloc (*n, (sizeof (struct nonterm_node)
 983                       + ((*n)->nonterm.n - 1) * sizeof (union any_node *)));
 984   return EXPR_STRING;
 985
 986 fail:
 987   free_node (*n);
 988   return EXPR_ERROR;
 989 }
 990
 991 /* Parses a string function according to f->desc.  f->desc[0] is the
 992    return type of the function.  Succeeding characters represent
 993    successive args.  Optional args are separated from the required
 994    args by a slash (`/').  Codes are `n', numeric arg; `s', string
 995    arg; and `f', format spec (this must be the last arg).  If the
 996    optional args are included, the type becomes f->t+1. */
 997 static enum expr_type
 998 generic_str_func (const struct function *f, int x UNUSED, union any_node **n)
 999 {
1000   struct string_function
1001     {
1002       int t1, t2;
1003       enum expr_type return_type;
1004       const char *arg_types;
1005     };
1006
1007   static const struct string_function string_func_tab[] =
1008     {
1009       {OP_INDEX_2, OP_INDEX_3, EXPR_NUMERIC, "ssN"},
1010       {OP_RINDEX_2, OP_RINDEX_3, EXPR_NUMERIC, "ssN"},
1011       {OP_LENGTH, 0, EXPR_NUMERIC, "s"},
1012       {OP_LOWER, 0, EXPR_STRING, "s"},
1013       {OP_UPPER, 0, EXPR_STRING, "s"},
1014       {OP_LPAD, 0, EXPR_STRING, "snS"},
1015       {OP_RPAD, 0, EXPR_STRING, "snS"},
1016       {OP_LTRIM, 0, EXPR_STRING, "sS"},
1017       {OP_RTRIM, 0, EXPR_STRING, "sS"},
1018       {OP_NUMBER, 0, EXPR_NUMERIC, "sf"},
1019       {OP_STRING, 0, EXPR_STRING, "nf"},
1020       {OP_SUBSTR_2, OP_SUBSTR_3, EXPR_STRING, "snN"},
1021     };
1022
1023   const int string_func_cnt = sizeof string_func_tab / sizeof *string_func_tab;
1024
1025   const struct string_function *sf;
1026   int arg_cnt;
1027   const char *cp;
1028   struct nonterm_node *nonterm;
1029
1030   /* Find string_function that corresponds to f. */
1031   for (sf = string_func_tab; sf < string_func_tab + string_func_cnt; sf++)
1032     if (f->t == sf->t1)
1033       break;
1034   assert (sf < string_func_tab + string_func_cnt);
1035
1036   /* Count max number of arguments. */
1037   arg_cnt = 0;
1038   for (cp = sf->arg_types; *cp != '\0'; cp++)
1039     {
1040       if (*cp != 'f')
1041         arg_cnt++;
1042       else
1043         arg_cnt += 3;
1044     }
1045
1046   /* Allocate node. */
1047   *n = xmalloc (sizeof (struct nonterm_node)
1048                 + (arg_cnt - 1) * sizeof (union any_node *));
1049   nonterm = &(*n)->nonterm;
1050   nonterm->type = sf->t1;
1051   nonterm->n = 0;
1052
1053   /* Parse arguments. */
1054   cp = sf->arg_types;
1055   for (;;)
1056     {
1057       if (*cp == 'n' || *cp == 's' || *cp == 'N' || *cp == 'S')
1058         {
1059           enum expr_type wanted_type
1060             = *cp == 'n' || *cp == 'N' ? EXPR_NUMERIC : EXPR_STRING;
1061           enum expr_type actual_type = parse_or (&nonterm->arg[nonterm->n]);
1062
1063           if (actual_type == EXPR_ERROR)
1064             goto fail;
1065           else if (actual_type == EXPR_BOOLEAN)
1066             actual_type = EXPR_NUMERIC;
1067           nonterm->n++;
1068           if (actual_type != wanted_type)
1069             {
1070               msg (SE, _("Argument %d to %s was expected to be of %s type.  "
1071                          "It was actually of type %s."),
1072                    nonterm->n + 1, f->s,
1073                    expr_type_name (actual_type), expr_type_name (wanted_type));
1074               goto fail;
1075             }
1076         }
1077       else if (*cp == 'f')
1078         {
1079           /* This is always the very last argument.  Also, this code
1080              is a crock.  However, it works. */
1081           struct fmt_spec fmt;
1082
1083           if (!parse_format_specifier (&fmt, 0))
1084             goto fail;
1085           if (formats[fmt.type].cat & FCAT_STRING)
1086             {
1087               msg (SE, _("%s is not a numeric format."), fmt_to_string (&fmt));
1088               goto fail;
1089             }
1090           nonterm->arg[nonterm->n + 0] = (union any_node *) fmt.type;
1091           nonterm->arg[nonterm->n + 1] = (union any_node *) fmt.w;
1092           nonterm->arg[nonterm->n + 2] = (union any_node *) fmt.d;
1093           break;
1094         }
1095       else
1096         assert (0);
1097
1098       /* We're done if no args are left. */
1099       cp++;
1100       if (*cp == 0)
1101         break;
1102
1103       /* Optional arguments are named with capital letters. */
1104       if (isupper ((unsigned char) *cp))
1105         {
1106           if (!lex_match (','))
1107             {
1108               if (sf->t2 == 0)
1109                 {
1110                   if (*cp == 'N')
1111                     nonterm->arg[nonterm->n++] = allocate_num_con (SYSMIS);
1112                   else if (*cp == 'S')
1113                     nonterm->arg[nonterm->n++] = allocate_str_con (" ", 1);
1114                   else
1115                     assert (0);
1116                 }
1117               break;
1118             }
1119
1120           if (sf->t2 != 0)
1121             nonterm->type = sf->t2;
1122         }
1123       else if (!lex_match (','))
1124         {
1125           msg (SE, _("Too few arguments to function %s."), f->s);
1126           goto fail;
1127         }
1128     }
1129
1130   return sf->return_type;
1131
1132 fail:
1133   free_node (*n);
1134   return EXPR_ERROR;
1135 }
1136 \f
1137 /* General function parsing. */
1138
1139 static int
1140 get_num_args (const struct function *f, int num_args, union any_node **n)
1141 {
1142   int t;
1143   int i;
1144
1145   *n = xmalloc (sizeof (struct nonterm_node)
1146                 + (num_args - 1) * sizeof (union any_node *));
1147   (*n)->nonterm.type = f->t;
1148   (*n)->nonterm.n = 0;
1149   for (i = 0;;)
1150     {
1151       t = parse_or (&(*n)->nonterm.arg[i]);
1152       if (t == EXPR_ERROR)
1153         goto fail;
1154       (*n)->nonterm.n++;
1155
1156       if (t == EXPR_STRING)
1157         {
1158           msg (SE, _("Type mismatch in argument %d of %s.  A string "
1159                      "expression was supplied where only a numeric expression "
1160                      "is allowed."),
1161                i + 1, f->s);
1162           goto fail;
1163         }
1164       if (++i >= num_args)
1165         return 1;
1166       if (!lex_match (','))
1167         {
1168           msg (SE, _("Missing comma following argument %d of %s."), i + 1, f->s);
1169           goto fail;
1170         }
1171     }
1172
1173 fail:
1174   free_node (*n);
1175   return 0;
1176 }
1177
1178 static enum expr_type
1179 parse_function (union any_node ** n)
1180 {
1181   const struct function *fp;
1182   char fname[32], *cp;
1183   int t;
1184   int min_args;
1185   const struct vector *v;
1186
1187   /* Check for a vector with this name. */
1188   v = dict_lookup_vector (default_dict, tokid);
1189   if (v)
1190     {
1191       lex_get ();
1192       assert (token == '(');
1193       lex_get ();
1194
1195       *n = xmalloc (sizeof (struct nonterm_node)
1196                     + sizeof (union any_node *[2]));
1197       (*n)->nonterm.type = (v->var[0]->type == NUMERIC
1198                         ? OP_VEC_ELEM_NUM : OP_VEC_ELEM_STR);
1199       (*n)->nonterm.n = 0;
1200
1201       t = parse_or (&(*n)->nonterm.arg[0]);
1202       if (t == EXPR_ERROR)
1203         goto fail;
1204       if (t != EXPR_NUMERIC)
1205         {
1206           msg (SE, _("The index value after a vector name must be numeric."));
1207           goto fail;
1208         }
1209       (*n)->nonterm.n++;
1210
1211       if (!lex_match (')'))
1212         {
1213           msg (SE, _("`)' expected after a vector index value."));
1214           goto fail;
1215         }
1216       ((*n)->nonterm.arg[1]) = (union any_node *) v->idx;
1217
1218       return v->var[0]->type == NUMERIC ? EXPR_NUMERIC : EXPR_STRING;
1219     }
1220
1221   ds_truncate (&tokstr, 31);
1222   strcpy (fname, ds_c_str (&tokstr));
1223   cp = strrchr (fname, '.');
1224   if (cp && isdigit ((unsigned char) cp[1]))
1225     {
1226       min_args = atoi (&cp[1]);
1227       *cp = 0;
1228     }
1229   else
1230     min_args = 0;
1231
1232   lex_get ();
1233   if (!lex_force_match ('('))
1234     return EXPR_ERROR;
1235
1236   {
1237     struct function f;
1238     f.s = fname;
1239
1240     fp = binary_search (func_tab, func_count, sizeof *func_tab, &f,
1241                         compare_functions, NULL);
1242   }
1243
1244   if (!fp)
1245     {
1246       msg (SE, _("There is no function named %s."), fname);
1247       return EXPR_ERROR;
1248     }
1249   if (min_args && fp->func != nary_num_func)
1250     {
1251       msg (SE, _("Function %s may not be given a minimum number of "
1252                  "arguments."), fname);
1253       return EXPR_ERROR;
1254     }
1255   t = fp->func (fp, min_args, n);
1256   if (t == EXPR_ERROR)
1257     return EXPR_ERROR;
1258   if (!lex_match (')'))
1259     {
1260       lex_error (_("expecting `)' after %s function"), fname);
1261       goto fail;
1262     }
1263
1264   return t;
1265
1266 fail:
1267   free_node (*n);
1268   return EXPR_ERROR;
1269 }
1270 \f
1271 /* Utility functions. */
1272
1273 static const char *
1274 expr_type_name (enum expr_type type)
1275 {
1276   switch (type)
1277     {
1278     case EXPR_ERROR:
1279       return _("error");
1280
1281     case EXPR_BOOLEAN:
1282       return _("Boolean");
1283
1284     case EXPR_NUMERIC:
1285       return _("numeric");
1286
1287     case EXPR_STRING:
1288       return _("string");
1289
1290     default:
1291       assert (0);
1292       return 0;
1293     }
1294 }
1295
1296 static const char *
1297 var_type_name (int type)
1298 {
1299   switch (type)
1300     {
1301     case NUMERIC:
1302       return _("numeric");
1303     case ALPHA:
1304       return _("string");
1305     default:
1306       assert (0);
1307       return 0;
1308     }
1309 }
1310
1311 static void
1312 make_bool (union any_node **n)
1313 {
1314   union any_node *c;
1315
1316   c = xmalloc (sizeof (struct nonterm_node));
1317   c->nonterm.type = OP_NUM_TO_BOOL;
1318   c->nonterm.n = 1;
1319   c->nonterm.arg[0] = *n;
1320   *n = c;
1321 }
1322
1323 void
1324 free_node (union any_node *n)
1325 {
1326   if (n != NULL)
1327     {
1328       if (IS_NONTERMINAL (n->type))
1329         {
1330           int i;
1331
1332           for (i = 0; i < n->nonterm.n; i++)
1333             free_node (n->nonterm.arg[i]);
1334         }
1335       free (n);
1336     }
1337 }
1338
1339 static union any_node *
1340 allocate_num_con (double value)
1341 {
1342   union any_node *c;
1343
1344   c = xmalloc (sizeof (struct num_con_node));
1345   c->num_con.type = OP_NUM_CON;
1346   c->num_con.value = value;
1347
1348   return c;
1349 }
1350
1351 static union any_node *
1352 allocate_str_con (const char *string, size_t length)
1353 {
1354   union any_node *c;
1355
1356   c = xmalloc (sizeof (struct str_con_node) + length - 1);
1357   c->str_con.type = OP_STR_CON;
1358   c->str_con.len = length;
1359   memcpy (c->str_con.s, string, length);
1360
1361   return c;
1362 }
1363
1364 static union any_node *
1365 allocate_var_node (int type, struct variable *variable)
1366 {
1367   union any_node *c;
1368
1369   c = xmalloc (sizeof (struct var_node));
1370   c->var.type = type;
1371   c->var.v = variable;
1372
1373   return c;
1374 }
1375
1376 union any_node *
1377 allocate_nonterminal (int op, union any_node *n)
1378 {
1379   union any_node *c;
1380
1381   c = xmalloc (sizeof c->nonterm);
1382   c->nonterm.type = op;
1383   c->nonterm.n = 1;
1384   c->nonterm.arg[0] = n;
1385
1386   return c;
1387 }
1388
1389 static union any_node *
1390 allocate_binary_nonterminal (int op, union any_node *lhs, union any_node *rhs)
1391 {
1392   union any_node *node;
1393
1394   node = xmalloc (sizeof node->nonterm + sizeof *node->nonterm.arg);
1395   node->nonterm.type = op;
1396   node->nonterm.n = 2;
1397   node->nonterm.arg[0] = lhs;
1398   node->nonterm.arg[1] = rhs;
1399
1400   return node;
1401 }
1402 \f
1403 static struct function func_tab[] =
1404 {
1405   {"ABS", OP_ABS, unary_func},
1406   {"ACOS", OP_ARCOS, unary_func},
1407   {"ARCOS", OP_ARCOS, unary_func},
1408   {"ARSIN", OP_ARSIN, unary_func},
1409   {"ARTAN", OP_ARTAN, unary_func},
1410   {"ASIN", OP_ARSIN, unary_func},
1411   {"ATAN", OP_ARTAN, unary_func},
1412   {"COS", OP_COS, unary_func},
1413   {"EXP", OP_EXP, unary_func},
1414   {"LG10", OP_LG10, unary_func},
1415   {"LN", OP_LN, unary_func},
1416   {"MOD10", OP_MOD10, unary_func},
1417   {"NORMAL", OP_NORMAL, unary_func},
1418   {"RND", OP_RND, unary_func},
1419   {"SIN", OP_SIN, unary_func},
1420   {"SQRT", OP_SQRT, unary_func},
1421   {"TAN", OP_TAN, unary_func},
1422   {"TRUNC", OP_TRUNC, unary_func},
1423   {"UNIFORM", OP_UNIFORM, unary_func},
1424
1425   {"TIME.DAYS", OP_TIME_DAYS, unary_func},
1426   {"TIME.HMS", OP_TIME_HMS, ternary_func},
1427
1428   {"CTIME.DAYS", OP_CTIME_DAYS, unary_func},
1429   {"CTIME.HOURS", OP_CTIME_HOURS, unary_func},
1430   {"CTIME.MINUTES", OP_CTIME_MINUTES, unary_func},
1431   {"CTIME.SECONDS", OP_CTIME_SECONDS, unary_func},
1432
1433   {"DATE.DMY", OP_DATE_DMY, ternary_func},
1434   {"DATE.MDY", OP_DATE_MDY, ternary_func},
1435   {"DATE.MOYR", OP_DATE_MOYR, binary_func},
1436   {"DATE.QYR", OP_DATE_QYR, binary_func},
1437   {"DATE.WKYR", OP_DATE_WKYR, binary_func},
1438   {"DATE.YRDAY", OP_DATE_YRDAY, binary_func},
1439
1440   {"XDATE.DATE", OP_XDATE_DATE, unary_func},
1441   {"XDATE.HOUR", OP_XDATE_HOUR, unary_func},
1442   {"XDATE.JDAY", OP_XDATE_JDAY, unary_func},
1443   {"XDATE.MDAY", OP_XDATE_MDAY, unary_func},
1444   {"XDATE.MINUTE", OP_XDATE_MINUTE, unary_func},
1445   {"XDATE.MONTH", OP_XDATE_MONTH, unary_func},
1446   {"XDATE.QUARTER", OP_XDATE_QUARTER, unary_func},
1447   {"XDATE.SECOND", OP_XDATE_SECOND, unary_func},
1448   {"XDATE.TDAY", OP_XDATE_TDAY, unary_func},
1449   {"XDATE.TIME", OP_XDATE_TIME, unary_func},
1450   {"XDATE.WEEK", OP_XDATE_WEEK, unary_func},
1451   {"XDATE.WKDAY", OP_XDATE_WKDAY, unary_func},
1452   {"XDATE.YEAR", OP_XDATE_YEAR, unary_func},
1453
1454   {"MISSING", OP_SYSMIS, MISSING_func},
1455   {"MOD", OP_MOD, binary_func},
1456   {"SYSMIS", OP_SYSMIS, SYSMIS_func},
1457   {"VALUE", OP_NUM_VAL, VALUE_func},
1458   {"LAG", OP_NUM_LAG, LAG_func},
1459   {"YRMODA", OP_YRMODA, ternary_func},
1460
1461   {"ANY", OP_ANY, nary_num_func},
1462   {"CFVAR", OP_CFVAR, nary_num_func},
1463   {"MAX", OP_MAX, nary_num_func},
1464   {"MEAN", OP_MEAN, nary_num_func},
1465   {"MIN", OP_MIN, nary_num_func},
1466   {"NMISS", OP_NMISS, nary_num_func},
1467   {"NVALID", OP_NVALID, nary_num_func},
1468   {"RANGE", OP_RANGE, nary_num_func},
1469   {"SD", OP_SD, nary_num_func},
1470   {"SUM", OP_SUM, nary_num_func},
1471   {"VAR", OP_VARIANCE, nary_num_func},
1472   {"VARIANCE", OP_VARIANCE, nary_num_func},
1473
1474   {"CONCAT", OP_CONCAT, CONCAT_func},
1475
1476   {"INDEX", OP_INDEX_2, generic_str_func},
1477   {"RINDEX", OP_RINDEX_2, generic_str_func},
1478   {"LENGTH", OP_LENGTH, generic_str_func},
1479   {"LOWER", OP_LOWER, generic_str_func},
1480   {"UPCASE", OP_UPPER, generic_str_func},
1481   {"LPAD", OP_LPAD, generic_str_func},
1482   {"RPAD", OP_RPAD, generic_str_func},
1483   {"LTRIM", OP_LTRIM, generic_str_func},
1484   {"RTRIM", OP_RTRIM, generic_str_func},
1485   {"NUMBER", OP_NUMBER, generic_str_func},
1486   {"STRING", OP_STRING, generic_str_func},
1487   {"SUBSTR", OP_SUBSTR_2, generic_str_func},
1488 };
1489
1490 /* An algo_compare_func that compares functions A and B based on
1491    their names. */
1492 static int
1493 compare_functions (const void *a_, const void *b_, void *aux UNUSED)
1494 {
1495   const struct function *a = a_;
1496   const struct function *b = b_;
1497
1498   return strcmp (a->s, b->s);
1499 }
1500
1501 static void
1502 init_func_tab (void)
1503 {
1504   {
1505     static int inited;
1506
1507     if (inited)
1508       return;
1509     inited = 1;
1510   }
1511
1512   func_count = sizeof func_tab / sizeof *func_tab;
1513   sort (func_tab, func_count, sizeof *func_tab, compare_functions, NULL);
1514 }
1515 \f
1516 /* Debug output. */
1517
1518 void
1519 expr_debug_print_postfix (const struct expression *e)
1520 {
1521   const unsigned char *o;
1522   const double *num = e->num;
1523   const unsigned char *str = e->str;
1524   struct variable *const *v = e->var;
1525   int t;
1526
1527   printf ("postfix:");
1528   for (o = e->op; *o != OP_SENTINEL;)
1529     {
1530       t = *o++;
1531       if (IS_NONTERMINAL (t))
1532         {
1533           printf (" %s", ops[t].name);
1534
1535           if (ops[t].flags & OP_VAR_ARGS)
1536             {
1537               printf ("(%d)", *o);
1538               o++;
1539             }
1540           if (ops[t].flags & OP_MIN_ARGS)
1541             {
1542               printf (".%d", *o);
1543               o++;
1544             }
1545           if (ops[t].flags & OP_FMT_SPEC)
1546             {
1547               struct fmt_spec f;
1548               f.type = (int) *o++;
1549               f.w = (int) *o++;
1550               f.d = (int) *o++;
1551               printf ("(%s)", fmt_to_string (&f));
1552             }
1553         }
1554       else if (t == OP_NUM_CON)
1555         {
1556           if (*num == SYSMIS)
1557             printf (" SYSMIS");
1558           else
1559             printf (" %f", *num);
1560           num++;
1561         }
1562       else if (t == OP_STR_CON)
1563         {
1564           printf (" \"%.*s\"", *str, &str[1]);
1565           str += str[0] + 1;
1566         }
1567       else if (t == OP_NUM_VAR || t == OP_STR_VAR)
1568         {
1569           printf (" %s", (*v)->name);
1570           v++;
1571         }
1572       else if (t == OP_NUM_SYS)
1573         {
1574           printf (" SYSMIS(#%d)", *o);
1575           o++;
1576         }
1577       else if (t == OP_NUM_VAL)
1578         {
1579           printf (" VALUE(#%d)", *o);
1580           o++;
1581         }
1582       else if (t == OP_NUM_LAG || t == OP_STR_LAG)
1583         {
1584           printf (" LAG(%s,%d)", (*v)->name, *o);
1585           o++;
1586           v++;
1587         }
1588       else
1589         {
1590           printf ("%d unknown\n", t);
1591           assert (0);
1592         }
1593     }
1594   putchar ('\n');
1595 }
1596 \f
1597 #define DEFINE_OPERATOR(NAME, STACK_DELTA, FLAGS, ARGS) \
1598         {#NAME, STACK_DELTA, FLAGS, ARGS},
1599 struct op_desc ops[OP_SENTINEL] =
1600   {
1601 #include "expr.def"
1602   };
1603 \f
1604 #include "command.h"
1605
1606 int
1607 cmd_debug_evaluate (void)
1608 {
1609   struct expression *expr;
1610   union value value;
1611   enum expr_type expr_flags;
1612   int dump_postfix = 0;
1613
1614   discard_variables ();
1615
1616   expr_flags = 0;
1617   if (lex_match_id ("NOOPTIMIZE"))
1618     expr_flags |= EXPR_NO_OPTIMIZE;
1619   if (lex_match_id ("POSTFIX"))
1620     dump_postfix = 1;
1621   if (token != '/')
1622     {
1623       lex_force_match ('/');
1624       return CMD_FAILURE;
1625     }
1626   fprintf (stderr, "%s => ", lex_rest_of_line (NULL));
1627   lex_get ();
1628
1629   expr = expr_parse (EXPR_ANY | expr_flags);
1630   if (!expr || token != '.')
1631     {
1632       if (expr != NULL)
1633         expr_free (expr);
1634       fprintf (stderr, "error\n");
1635       return CMD_FAILURE;
1636     }
1637
1638   if (dump_postfix)
1639     expr_debug_print_postfix (expr);
1640   else
1641     {
1642       expr_evaluate (expr, NULL, 0, &value);
1643       switch (expr_get_type (expr))
1644         {
1645         case EXPR_NUMERIC:
1646           if (value.f == SYSMIS)
1647             fprintf (stderr, "sysmis\n");
1648           else
1649             fprintf (stderr, "%.2f\n", value.f);
1650           break;
1651
1652         case EXPR_BOOLEAN:
1653           if (value.f == SYSMIS)
1654             fprintf (stderr, "sysmis\n");
1655           else if (value.f == 0.0)
1656             fprintf (stderr, "false\n");
1657           else
1658             fprintf (stderr, "true\n");
1659           break;
1660
1661         case EXPR_STRING:
1662           fputc ('"', stderr);
1663           fwrite (value.c + 1, value.c[0], 1, stderr);
1664           fputs ("\"\n", stderr);
1665           break;
1666
1667         default:
1668           assert (0);
1669         }
1670     }
1671
1672   expr_free (expr);
1673   return CMD_SUCCESS;
1674 }