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