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