src/expressions/parse.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 "private.h"
  22 #include <ctype.h>
  23 #include <float.h>
  24 #include <limits.h>
  25 #include <stdlib.h>
  26 #include "algorithm.h"
  27 #include "alloc.h"
  28 #include "case.h"
  29 #include "dictionary.h"
  30 #include "error.h"
  31 #include "helpers.h"
  32 #include "lexer.h"
  33 #include "misc.h"
  34 #include "pool.h"
  35 #include "settings.h"
  36 #include "str.h"
  37 #include "var.h"
  38 #include "vfm.h"
  39 \f
  40 /* Declarations. */
  41
  42 /* Recursive descent parser in order of increasing precedence. */
  43 typedef union any_node *parse_recursively_func (struct expression *);
  44 static parse_recursively_func parse_or, parse_and, parse_not;
  45 static parse_recursively_func parse_rel, parse_add, parse_mul;
  46 static parse_recursively_func parse_neg, parse_exp;
  47 static parse_recursively_func parse_primary;
  48 static parse_recursively_func parse_vector_element, parse_function;
  49
  50 /* Utility functions. */
  51 static struct expression *expr_create (struct dictionary *);
  52 atom_type expr_node_returns (const union any_node *);
  53
  54 static const char *atom_type_name (atom_type);
  55 static struct expression *finish_expression (union any_node *,
  56                                              struct expression *);
  57 static bool type_check (struct expression *, union any_node **,
  58                         enum expr_type expected_type);
  59 static union any_node *allocate_unary_variable (struct expression *,
  60                                                 struct variable *);
  61 \f
  62 /* Public functions. */
  63
  64 /* Parses an expression of the given TYPE.
  65    If DICT is nonnull then variables and vectors within it may be
  66    referenced within the expression; otherwise, the expression
  67    must not reference any variables or vectors.
  68    Returns the new expression if successful or a null pointer
  69    otherwise. */
  70 struct expression *
  71 expr_parse (struct dictionary *dict, enum expr_type type)
  72 {
  73   union any_node *n;
  74   struct expression *e;
  75
  76   assert (type == EXPR_NUMBER || type == EXPR_STRING || type == EXPR_BOOLEAN);
  77
  78   e = expr_create (dict);
  79   n = parse_or (e);
  80   if (n != NULL && type_check (e, &n, type))
  81     return finish_expression (expr_optimize (n, e), e);
  82   else
  83     {
  84       expr_free (e);
  85       return NULL;
  86     }
  87 }
  88
  89 /* Free expression E. */
  90 void
  91 expr_free (struct expression *e)
  92 {
  93   if (e != NULL)
  94     pool_destroy (e->expr_pool);
  95 }
  96
  97 struct expression *
  98 expr_parse_any (struct dictionary *dict, bool optimize)
  99 {
 100   union any_node *n;
 101   struct expression *e;
 102
 103   e = expr_create (dict);
 104   n = parse_or (e);
 105   if (n == NULL)
 106     {
 107       expr_free (e);
 108       return NULL;
 109     }
 110
 111   if (optimize)
 112     n = expr_optimize (n, e);
 113   return finish_expression (n, e);
 114 }
 115 \f
 116 /* Finishing up expression building. */
 117
 118 /* Height of an expression's stacks. */
 119 struct stack_heights
 120   {
 121     int number_height;  /* Height of number stack. */
 122     int string_height;  /* Height of string stack. */
 123   };
 124
 125 /* Stack heights used by different kinds of arguments. */
 126 static const struct stack_heights on_number_stack = {1, 0};
 127 static const struct stack_heights on_string_stack = {0, 1};
 128 static const struct stack_heights not_on_stack = {0, 0};
 129
 130 /* Returns the stack heights used by an atom of the given
 131    TYPE. */
 132 static const struct stack_heights *
 133 atom_type_stack (atom_type type)
 134 {
 135   assert (is_atom (type));
 136
 137   switch (type)
 138     {
 139     case OP_number:
 140     case OP_boolean:
 141       return &on_number_stack;
 142
 143     case OP_string:
 144       return &on_string_stack;
 145
 146     case OP_format:
 147     case OP_ni_format:
 148     case OP_no_format:
 149     case OP_num_var:
 150     case OP_str_var:
 151     case OP_integer:
 152     case OP_pos_int:
 153     case OP_vector:
 154       return &not_on_stack;
 155
 156     default:
 157       abort ();
 158     }
 159 }
 160
 161 /* Measures the stack height needed for node N, supposing that
 162    the stack height is initially *HEIGHT and updating *HEIGHT to
 163    the final stack height.  Updates *MAX, if necessary, to
 164    reflect the maximum intermediate or final height. */
 165 static void
 166 measure_stack (const union any_node *n,
 167                struct stack_heights *height, struct stack_heights *max)
 168 {
 169   const struct stack_heights *return_height;
 170
 171   if (is_composite (n->type))
 172     {
 173       struct stack_heights args;
 174       int i;
 175
 176       args = *height;
 177       for (i = 0; i < n->composite.arg_cnt; i++)
 178         measure_stack (n->composite.args[i], &args, max);
 179
 180       return_height = atom_type_stack (operations[n->type].returns);
 181     }
 182   else
 183     return_height = atom_type_stack (n->type);
 184
 185   height->number_height += return_height->number_height;
 186   height->string_height += return_height->string_height;
 187
 188   if (height->number_height > max->number_height)
 189     max->number_height = height->number_height;
 190   if (height->string_height > max->string_height)
 191     max->string_height = height->string_height;
 192 }
 193
 194 /* Allocates stacks within E sufficient for evaluating node N. */
 195 static void
 196 allocate_stacks (union any_node *n, struct expression *e)
 197 {
 198   struct stack_heights initial = {0, 0};
 199   struct stack_heights max = {0, 0};
 200
 201   measure_stack (n, &initial, &max);
 202   e->number_stack = pool_alloc (e->expr_pool,
 203                                 sizeof *e->number_stack * max.number_height);
 204   e->string_stack = pool_alloc (e->expr_pool,
 205                                 sizeof *e->string_stack * max.string_height);
 206 }
 207
 208 /* Finalizes expression E for evaluating node N. */
 209 static struct expression *
 210 finish_expression (union any_node *n, struct expression *e)
 211 {
 212   /* Allocate stacks. */
 213   allocate_stacks (n, e);
 214
 215   /* Output postfix representation. */
 216   expr_flatten (n, e);
 217
 218   /* The eval_pool might have been used for allocating strings
 219      during optimization.  We need to keep those strings around
 220      for all subsequent evaluations, so start a new eval_pool. */
 221   e->eval_pool = pool_create_subpool (e->expr_pool);
 222
 223   return e;
 224 }
 225
 226 /* Verifies that expression E, whose root node is *N, can be
 227    converted to type EXPECTED_TYPE, inserting a conversion at *N
 228    if necessary.  Returns true if successful, false on failure. */
 229 static bool
 230 type_check (struct expression *e,
 231             union any_node **n, enum expr_type expected_type)
 232 {
 233   atom_type actual_type = expr_node_returns (*n);
 234
 235   switch (expected_type)
 236     {
 237     case EXPR_BOOLEAN:
 238     case EXPR_NUMBER:
 239       if (actual_type != OP_number && actual_type != OP_boolean)
 240         {
 241           msg (SE, _("Type mismatch: expression has %s type, "
 242                      "but a numeric value is required here."),
 243                atom_type_name (actual_type));
 244           return false;
 245         }
 246       if (actual_type == OP_number && expected_type == OP_boolean)
 247         *n = expr_allocate_unary (e, OP_NUM_TO_BOOLEAN, *n);
 248       break;
 249
 250     case EXPR_STRING:
 251       if (actual_type != OP_string)
 252         {
 253           msg (SE, _("Type mismatch: expression has %s type, "
 254                      "but a string value is required here."),
 255                atom_type_name (actual_type));
 256           return false;
 257         }
 258       break;
 259
 260     default:
 261       abort ();
 262     }
 263
 264   return true;
 265 }
 266 \f
 267 /* Recursive-descent expression parser. */
 268
 269 /* Considers whether *NODE may be coerced to type REQUIRED_TYPE.
 270    Returns true if possible, false if disallowed.
 271
 272    If DO_COERCION is zero, then *NODE is not modified and there
 273    are no side effects.
 274
 275    Otherwise, DO_COERCION is nonzero.  In this case, we perform
 276    the coercion if possible, possibly modifying *NODE.  If the
 277    coercion is not possible then we free *NODE and set *NODE to
 278    a null pointer.
 279
 280    This function's interface is somewhat awkward.  Use one of the
 281    wrapper functions type_coercion(), type_coercion_assert(), or
 282    is_coercible() instead. */
 283 static bool
 284 type_coercion_core (struct expression *e,
 285                     atom_type required_type,
 286                     union any_node **node,
 287                     const char *operator_name,
 288                     bool do_coercion)
 289 {
 290   atom_type actual_type;
 291
 292   assert (!!do_coercion == (e != NULL));
 293   if (*node == NULL)
 294     {
 295       /* Propagate error.  Whatever caused the original error
 296          already emitted an error message. */
 297       return false;
 298     }
 299
 300   actual_type = expr_node_returns (*node);
 301   if (actual_type == required_type)
 302     {
 303       /* Type match. */
 304       return true;
 305     }
 306
 307   switch (required_type)
 308     {
 309     case OP_number:
 310       if (actual_type == OP_boolean)
 311         {
 312           /* To enforce strict typing rules, insert Boolean to
 313              numeric "conversion".  This conversion is a no-op,
 314              so it will be removed later. */
 315           if (do_coercion)
 316             *node = expr_allocate_unary (e, OP_BOOLEAN_TO_NUM, *node);
 317           return true;
 318         }
 319       break;
 320
 321     case OP_string:
 322       /* No coercion to string. */
 323       break;
 324
 325     case OP_boolean:
 326       if (actual_type == OP_number)
 327         {
 328           /* Convert numeric to boolean. */
 329           if (do_coercion)
 330             *node = expr_allocate_unary (e, OP_NUM_TO_BOOLEAN, *node);
 331           return true;
 332         }
 333       break;
 334
 335     case OP_format:
 336       abort ();
 337
 338     case OP_ni_format:
 339       if ((*node)->type == OP_format
 340           && check_input_specifier (&(*node)->format.f, 0))
 341         {
 342           if (do_coercion)
 343             (*node)->type = OP_ni_format;
 344           return true;
 345         }
 346       break;
 347
 348     case OP_no_format:
 349       if ((*node)->type == OP_format
 350           && check_output_specifier (&(*node)->format.f, 0))
 351         {
 352           if (do_coercion)
 353             (*node)->type = OP_no_format;
 354           return true;
 355         }
 356       break;
 357
 358     case OP_num_var:
 359       if ((*node)->type == OP_NUM_VAR)
 360         {
 361           if (do_coercion)
 362             *node = (*node)->composite.args[0];
 363           return true;
 364         }
 365       break;
 366
 367     case OP_str_var:
 368       if ((*node)->type == OP_STR_VAR)
 369         {
 370           if (do_coercion)
 371             *node = (*node)->composite.args[0];
 372           return true;
 373         }
 374       break;
 375
 376     case OP_pos_int:
 377       if ((*node)->type == OP_number
 378           && floor ((*node)->number.n) == (*node)->number.n
 379           && (*node)->number.n > 0 && (*node)->number.n < INT_MAX)
 380         {
 381           if (do_coercion)
 382             *node = expr_allocate_pos_int (e, (*node)->number.n);
 383           return true;
 384         }
 385       break;
 386
 387     default:
 388       abort ();
 389     }
 390
 391   if (do_coercion)
 392     msg (SE, _("Type mismatch while applying %s operator: "
 393                "cannot convert %s to %s."),
 394          operator_name,
 395          atom_type_name (actual_type), atom_type_name (required_type));
 396   return false;
 397 }
 398
 399 /* Coerces *NODE to type REQUIRED_TYPE, and returns success.  If
 400    *NODE cannot be coerced to the desired type then we issue an
 401    error message about operator OPERATOR_NAME and free *NODE. */
 402 static bool
 403 type_coercion (struct expression *e,
 404                atom_type required_type, union any_node **node,
 405                const char *operator_name)
 406 {
 407   return type_coercion_core (e, required_type, node, operator_name, true);
 408 }
 409
 410 /* Coerces *NODE to type REQUIRED_TYPE.
 411    Assert-fails if the coercion is disallowed. */
 412 static void
 413 type_coercion_assert (struct expression *e,
 414                       atom_type required_type, union any_node **node)
 415 {
 416   int success = type_coercion_core (e, required_type, node, NULL, true);
 417   assert (success);
 418 }
 419
 420 /* Returns true if *NODE may be coerced to type REQUIRED_TYPE,
 421    false otherwise. */
 422 static bool
 423 is_coercible (atom_type required_type, union any_node *const *node)
 424 {
 425   return type_coercion_core (NULL, required_type,
 426                              (union any_node **) node, NULL, false);
 427 }
 428
 429 /* How to parse an operator. */
 430 struct operator
 431   {
 432     int token;                  /* Token representing operator. */
 433     operation_type type;        /* Operation type representing operation. */
 434     const char *name;           /* Name of operator. */
 435   };
 436
 437 /* Attempts to match the current token against the tokens for the
 438    OP_CNT operators in OPS[].  If successful, returns true
 439    and, if OPERATOR is non-null, sets *OPERATOR to the operator.
 440    On failure, returns false and, if OPERATOR is non-null, sets
 441    *OPERATOR to a null pointer. */
 442 static bool
 443 match_operator (const struct operator ops[], size_t op_cnt,
 444                 const struct operator **operator)
 445 {
 446   const struct operator *op;
 447
 448   for (op = ops; op < ops + op_cnt; op++)
 449     {
 450       if (op->token == '-')
 451         lex_negative_to_dash ();
 452       if (lex_match (op->token))
 453         {
 454           if (operator != NULL)
 455             *operator = op;
 456           return true;
 457         }
 458     }
 459   if (operator != NULL)
 460     *operator = NULL;
 461   return false;
 462 }
 463
 464 static bool
 465 check_operator (const struct operator *op, int arg_cnt, atom_type arg_type)
 466 {
 467   const struct operation *o;
 468   size_t i;
 469
 470   assert (op != NULL);
 471   o = &operations[op->type];
 472   assert (o->arg_cnt == arg_cnt);
 473   assert ((o->flags & OPF_ARRAY_OPERAND) == 0);
 474   for (i = 0; i < arg_cnt; i++)
 475     assert (o->args[i] == arg_type);
 476   return true;
 477 }
 478
 479 static bool
 480 check_binary_operators (const struct operator ops[], size_t op_cnt,
 481                         atom_type arg_type)
 482 {
 483   size_t i;
 484
 485   for (i = 0; i < op_cnt; i++)
 486     check_operator (&ops[i], 2, arg_type);
 487   return true;
 488 }
 489
 490 static atom_type
 491 get_operand_type (const struct operator *op)
 492 {
 493   return operations[op->type].args[0];
 494 }
 495
 496 /* Parses a chain of left-associative operator/operand pairs.
 497    There are OP_CNT operators, specified in OPS[].  The
 498    operators' operands must all be the same type.  The next
 499    higher level is parsed by PARSE_NEXT_LEVEL.  If CHAIN_WARNING
 500    is non-null, then it will be issued as a warning if more than
 501    one operator/operand pair is parsed. */
 502 static union any_node *
 503 parse_binary_operators (struct expression *e, union any_node *node,
 504                         const struct operator ops[], size_t op_cnt,
 505                         parse_recursively_func *parse_next_level,
 506                         const char *chain_warning)
 507 {
 508   atom_type operand_type = get_operand_type (&ops[0]);
 509   int op_count;
 510   const struct operator *operator;
 511
 512   assert (check_binary_operators (ops, op_cnt, operand_type));
 513   if (node == NULL)
 514     return node;
 515
 516   for (op_count = 0; match_operator (ops, op_cnt, &operator); op_count++)
 517     {
 518       union any_node *rhs;
 519
 520       /* Convert the left-hand side to type OPERAND_TYPE. */
 521       if (!type_coercion (e, operand_type, &node, operator->name))
 522         return node;
 523
 524       /* Parse the right-hand side and coerce to type
 525          OPERAND_TYPE. */
 526       rhs = parse_next_level (e);
 527       if (!type_coercion (e, operand_type, &rhs, operator->name))
 528         return NULL;
 529       node = expr_allocate_binary (e, operator->type, node, rhs);
 530     }
 531
 532   if (op_count > 1 && chain_warning != NULL)
 533     msg (SW, chain_warning);
 534
 535   return node;
 536 }
 537
 538 static union any_node *
 539 parse_inverting_unary_operator (struct expression *e,
 540                                 const struct operator *op,
 541                                 parse_recursively_func *parse_next_level)
 542 {
 543   union any_node *node;
 544   unsigned op_count;
 545
 546   check_operator (op, 1, get_operand_type (op));
 547
 548   op_count = 0;
 549   while (match_operator (op, 1, NULL))
 550     op_count++;
 551
 552   node = parse_next_level (e);
 553   if (op_count > 0
 554       && type_coercion (e, get_operand_type (op), &node, op->name)
 555       && op_count % 2 != 0)
 556     return expr_allocate_unary (e, op->type, node);
 557   else
 558     return node;
 559 }
 560
 561 /* Parses the OR level. */
 562 static union any_node *
 563 parse_or (struct expression *e)
 564 {
 565   static const struct operator op =
 566     { T_OR, OP_OR, "logical disjunction (\"OR\")" };
 567
 568   return parse_binary_operators (e, parse_and (e), &op, 1, parse_and, NULL);
 569 }
 570
 571 /* Parses the AND level. */
 572 static union any_node *
 573 parse_and (struct expression *e)
 574 {
 575   static const struct operator op =
 576     { T_AND, OP_AND, "logical conjunction (\"AND\")" };
 577
 578   return parse_binary_operators (e, parse_not (e), &op, 1, parse_not, NULL);
 579 }
 580
 581 /* Parses the NOT level. */
 582 static union any_node *
 583 parse_not (struct expression *e)
 584 {
 585   static const struct operator op
 586     = { T_NOT, OP_NOT, "logical negation (\"NOT\")" };
 587   return parse_inverting_unary_operator (e, &op, parse_rel);
 588 }
 589
 590 /* Parse relational operators. */
 591 static union any_node *
 592 parse_rel (struct expression *e)
 593 {
 594   const char *chain_warning =
 595     _("Chaining relational operators (e.g. \"a < b < c\") will "
 596       "not produce the mathematically expected result.  "
 597       "Use the AND logical operator to fix the problem "
 598       "(e.g. \"a < b AND b < c\").  "
 599       "If chaining is really intended, parentheses will disable "
 600       "this warning (e.g. \"(a < b) < c\".)");
 601
 602   union any_node *node = parse_add (e);
 603
 604   if (node == NULL)
 605     return NULL;
 606
 607   switch (expr_node_returns (node))
 608     {
 609     case OP_number:
 610     case OP_boolean:
 611       {
 612         static const struct operator ops[] =
 613           {
 614             { '=', OP_EQ, "numeric equality (\"=\")" },
 615             { T_EQ, OP_EQ, "numeric equality (\"EQ\")" },
 616             { T_GE, OP_GE, "numeric greater-than-or-equal-to (\">=\")" },
 617             { T_GT, OP_GT, "numeric greater than (\">\")" },
 618             { T_LE, OP_LE, "numeric less-than-or-equal-to (\"<=\")" },
 619             { T_LT, OP_LT, "numeric less than (\"<\")" },
 620             { T_NE, OP_NE, "numeric inequality (\"<>\")" },
 621           };
 622
 623         return parse_binary_operators (e, node, ops, sizeof ops / sizeof *ops,
 624                                        parse_add, chain_warning);
 625       }
 626
 627     case OP_string:
 628       {
 629         static const struct operator ops[] =
 630           {
 631             { '=', OP_EQ_STRING, "string equality (\"=\")" },
 632             { T_EQ, OP_EQ_STRING, "string equality (\"EQ\")" },
 633             { T_GE, OP_GE_STRING, "string greater-than-or-equal-to (\">=\")" },
 634             { T_GT, OP_GT_STRING, "string greater than (\">\")" },
 635             { T_LE, OP_LE_STRING, "string less-than-or-equal-to (\"<=\")" },
 636             { T_LT, OP_LT_STRING, "string less than (\"<\")" },
 637             { T_NE, OP_NE_STRING, "string inequality (\"<>\")" },
 638           };
 639
 640         return parse_binary_operators (e, node, ops, sizeof ops / sizeof *ops,
 641                                        parse_add, chain_warning);
 642       }
 643
 644     default:
 645       return node;
 646     }
 647 }
 648
 649 /* Parses the addition and subtraction level. */
 650 static union any_node *
 651 parse_add (struct expression *e)
 652 {
 653   static const struct operator ops[] =
 654     {
 655       { '+', OP_ADD, "addition (\"+\")" },
 656       { '-', OP_SUB, "subtraction (\"-\")-" },
 657     };
 658
 659   return parse_binary_operators (e, parse_mul (e),
 660                                  ops, sizeof ops / sizeof *ops,
 661                                  parse_mul, NULL);
 662 }
 663
 664 /* Parses the multiplication and division level. */
 665 static union any_node *
 666 parse_mul (struct expression *e)
 667 {
 668   static const struct operator ops[] =
 669     {
 670       { '*', OP_MUL, "multiplication (\"*\")" },
 671       { '/', OP_DIV, "division (\"/\")" },
 672     };
 673
 674   return parse_binary_operators (e, parse_neg (e),
 675                                  ops, sizeof ops / sizeof *ops,
 676                                  parse_neg, NULL);
 677 }
 678
 679 /* Parses the unary minus level. */
 680 static union any_node *
 681 parse_neg (struct expression *e)
 682 {
 683   static const struct operator op = { '-', OP_NEG, "negation (\"-\")" };
 684   return parse_inverting_unary_operator (e, &op, parse_exp);
 685 }
 686
 687 static union any_node *
 688 parse_exp (struct expression *e)
 689 {
 690   static const struct operator op =
 691     { T_EXP, OP_POW, "exponentiation (\"**\")" };
 692
 693   const char *chain_warning =
 694     _("The exponentiation operator (\"**\") is left-associative, "
 695       "even though right-associative semantics are more useful.  "
 696       "That is, \"a**b**c\" equals \"(a**b)**c\", not as \"a**(b**c)\".  "
 697       "To disable this warning, insert parentheses.");
 698
 699   return parse_binary_operators (e, parse_primary (e), &op, 1,
 700                                  parse_primary, chain_warning);
 701 }
 702
 703 /* Parses system variables. */
 704 static union any_node *
 705 parse_sysvar (struct expression *e)
 706 {
 707   if (lex_match_id ("$CASENUM"))
 708     return expr_allocate_nullary (e, OP_CASENUM);
 709   else if (lex_match_id ("$DATE"))
 710     {
 711       static const char *months[12] =
 712         {
 713           "JAN", "FEB", "MAR", "APR", "MAY", "JUN",
 714           "JUL", "AUG", "SEP", "OCT", "NOV", "DEC",
 715         };
 716
 717       struct tm *time;
 718       char temp_buf[10];
 719
 720       time = localtime (&last_vfm_invocation);
 721       sprintf (temp_buf, "%02d %s %02d", abs (time->tm_mday) % 100,
 722                months[abs (time->tm_mon) % 12], abs (time->tm_year) % 100);
 723
 724       return expr_allocate_string_buffer (e, temp_buf, strlen (temp_buf));
 725     }
 726   else if (lex_match_id ("$TRUE"))
 727     return expr_allocate_boolean (e, 1.0);
 728   else if (lex_match_id ("$FALSE"))
 729     return expr_allocate_boolean (e, 0.0);
 730   else if (lex_match_id ("$SYSMIS"))
 731     return expr_allocate_number (e, SYSMIS);
 732   else if (lex_match_id ("$JDATE"))
 733     {
 734       struct tm *time = localtime (&last_vfm_invocation);
 735       return expr_allocate_number (e, expr_ymd_to_ofs (time->tm_year + 1900,
 736                                                        time->tm_mon + 1,
 737                                                        time->tm_mday));
 738     }
 739   else if (lex_match_id ("$TIME"))
 740     {
 741       struct tm *time = localtime (&last_vfm_invocation);
 742       return expr_allocate_number (e,
 743                                    expr_ymd_to_date (time->tm_year + 1900,
 744                                                      time->tm_mon + 1,
 745                                                      time->tm_mday)
 746                                    + time->tm_hour * 60 * 60.
 747                                    + time->tm_min * 60.
 748                                    + time->tm_sec);
 749     }
 750   else if (lex_match_id ("$LENGTH"))
 751     return expr_allocate_number (e, get_viewlength ());
 752   else if (lex_match_id ("$WIDTH"))
 753     return expr_allocate_number (e, get_viewwidth ());
 754   else
 755     {
 756       msg (SE, _("Unknown system variable %s."), tokid);
 757       return NULL;
 758     }
 759 }
 760
 761 /* Parses numbers, varnames, etc. */
 762 static union any_node *
 763 parse_primary (struct expression *e)
 764 {
 765   switch (token)
 766     {
 767     case T_ID:
 768       if (lex_look_ahead () == '(')
 769         {
 770           /* An identifier followed by a left parenthesis may be
 771              a vector element reference.  If not, it's a function
 772              call. */
 773           if (e->dict != NULL && dict_lookup_vector (e->dict, tokid) != NULL)
 774             return parse_vector_element (e);
 775           else
 776             return parse_function (e);
 777         }
 778       else if (tokid[0] == '$')
 779         {
 780           /* $ at the beginning indicates a system variable. */
 781           return parse_sysvar (e);
 782         }
 783       else if (e->dict != NULL && dict_lookup_var (e->dict, tokid))
 784         {
 785           /* It looks like a user variable.
 786              (It could be a format specifier, but we'll assume
 787              it's a variable unless proven otherwise. */
 788           return allocate_unary_variable (e, parse_dict_variable (e->dict));
 789         }
 790       else
 791         {
 792           /* Try to parse it as a format specifier. */
 793           struct fmt_spec fmt;
 794           if (parse_format_specifier (&fmt, FMTP_SUPPRESS_ERRORS))
 795             return expr_allocate_format (e, &fmt);
 796
 797           /* All attempts failed. */
 798           msg (SE, _("Unknown identifier %s."), tokid);
 799           return NULL;
 800         }
 801       break;
 802
 803     case T_NUM:
 804       {
 805         union any_node *node = expr_allocate_number (e, tokval);
 806         lex_get ();
 807         return node;
 808       }
 809
 810     case T_STRING:
 811       {
 812         union any_node *node = expr_allocate_string_buffer (e, ds_c_str (&tokstr),
 813                                                        ds_length (&tokstr));
 814         lex_get ();
 815         return node;
 816       }
 817
 818     case '(':
 819       {
 820         union any_node *node;
 821         lex_get ();
 822         node = parse_or (e);
 823         if (node != NULL && !lex_match (')'))
 824           {
 825             lex_error (_("expecting `)'"));
 826             return NULL;
 827           }
 828         return node;
 829       }
 830
 831     default:
 832       lex_error (_("in expression"));
 833       return NULL;
 834     }
 835 }
 836
 837 static union any_node *
 838 parse_vector_element (struct expression *e)
 839 {
 840   const struct vector *vector;
 841   union any_node *element;
 842
 843   /* Find vector, skip token.
 844      The caller must already have verified that the current token
 845      is the name of a vector. */
 846   vector = dict_lookup_vector (default_dict, tokid);
 847   assert (vector != NULL);
 848   lex_get ();
 849
 850   /* Skip left parenthesis token.
 851      The caller must have verified that the lookahead is a left
 852      parenthesis. */
 853   assert (token == '(');
 854   lex_get ();
 855
 856   element = parse_or (e);
 857   if (!type_coercion (e, OP_number, &element, "vector indexing")
 858       || !lex_match (')'))
 859     return NULL;
 860
 861   return expr_allocate_binary (e, (vector->var[0]->type == NUMERIC
 862                                    ? OP_VEC_ELEM_NUM : OP_VEC_ELEM_STR),
 863                                expr_allocate_vector (e, vector), element);
 864 }
 865 \f
 866 /* Individual function parsing. */
 867
 868 struct operation operations[OP_first + OP_cnt] = {
 869 #include "parse.inc"
 870 };
 871
 872 static bool
 873 word_matches (const char **test, const char **name)
 874 {
 875   size_t test_len = strcspn (*test, ".");
 876   size_t name_len = strcspn (*name, ".");
 877   if (test_len == name_len)
 878     {
 879       if (memcmp (*test, *name, test_len))
 880         return false;
 881     }
 882   else if (test_len < 3 || test_len > name_len)
 883     return false;
 884   else
 885     {
 886       if (memcmp (*test, *name, test_len))
 887         return false;
 888     }
 889
 890   *test += test_len;
 891   *name += name_len;
 892   if (**test != **name)
 893     return false;
 894
 895   if (**test == '.')
 896     {
 897       (*test)++;
 898       (*name)++;
 899     }
 900   return true;
 901 }
 902
 903 static int
 904 compare_names (const char *test, const char *name)
 905 {
 906   for (;;)
 907     {
 908       if (!word_matches (&test, &name))
 909         return true;
 910       if (*name == '\0' && *test == '\0')
 911         return false;
 912     }
 913 }
 914
 915 static bool
 916 lookup_function_helper (const char *name,
 917                         int (*compare) (const char *test, const char *name),
 918                         const struct operation **first,
 919                         const struct operation **last)
 920 {
 921   struct operation *f;
 922
 923   for (f = operations + OP_function_first;
 924        f <= operations + OP_function_last; f++)
 925     if (!compare (name, f->name))
 926       {
 927         *first = f;
 928
 929         while (f <= operations + OP_function_last && !compare (name, f->name))
 930           f++;
 931         *last = f;
 932
 933         return true;
 934       }
 935
 936   return false;
 937 }
 938
 939 static bool
 940 lookup_function (const char *name,
 941                  const struct operation **first,
 942                  const struct operation **last)
 943 {
 944   *first = *last = NULL;
 945   return (lookup_function_helper (name, strcmp, first, last)
 946           || lookup_function_helper (name, compare_names, first, last));
 947 }
 948
 949 static int
 950 extract_min_valid (char *s)
 951 {
 952   char *p = strrchr (s, '.');
 953   if (p == NULL
 954       || p[1] < '0' || p[1] > '9'
 955       || strspn (p + 1, "0123456789") != strlen (p + 1))
 956     return -1;
 957   *p = '\0';
 958   return atoi (p + 1);
 959 }
 960
 961 static atom_type
 962 function_arg_type (const struct operation *f, size_t arg_idx)
 963 {
 964   assert (arg_idx < f->arg_cnt || (f->flags & OPF_ARRAY_OPERAND));
 965
 966   return f->args[arg_idx < f->arg_cnt ? arg_idx : f->arg_cnt - 1];
 967 }
 968
 969 static bool
 970 match_function (union any_node **args, int arg_cnt, const struct operation *f)
 971 {
 972   size_t i;
 973
 974   if (arg_cnt < f->arg_cnt
 975       || (arg_cnt > f->arg_cnt && (f->flags & OPF_ARRAY_OPERAND) == 0)
 976       || arg_cnt - (f->arg_cnt - 1) < f->array_min_elems)
 977     return false;
 978
 979   for (i = 0; i < arg_cnt; i++)
 980     if (!is_coercible (function_arg_type (f, i), &args[i]))
 981       return false;
 982
 983   return true;
 984 }
 985
 986 static void
 987 coerce_function_args (struct expression *e, const struct operation *f,
 988                       union any_node **args, size_t arg_cnt)
 989 {
 990   int i;
 991
 992   for (i = 0; i < arg_cnt; i++)
 993     type_coercion_assert (e, function_arg_type (f, i), &args[i]);
 994 }
 995
 996 static bool
 997 validate_function_args (const struct operation *f, int arg_cnt, int min_valid)
 998 {
 999   int array_arg_cnt = arg_cnt - (f->arg_cnt - 1);
1000   if (array_arg_cnt < f->array_min_elems)
1001     {
1002       msg (SE, _("%s must have at least %d arguments in list."),
1003            f->prototype, f->array_min_elems);
1004       return false;
1005     }
1006
1007   if ((f->flags & OPF_ARRAY_OPERAND)
1008       && array_arg_cnt % f->array_granularity != 0)
1009     {
1010       if (f->array_granularity == 2)
1011         msg (SE, _("%s must have even number of arguments in list."),
1012              f->prototype);
1013       else
1014         msg (SE, _("%s must have multiple of %d arguments in list."),
1015              f->prototype, f->array_granularity);
1016       return false;
1017     }
1018
1019   if (min_valid != -1)
1020     {
1021       if (f->array_min_elems == 0)
1022         {
1023           assert ((f->flags & OPF_MIN_VALID) == 0);
1024           msg (SE, _("%s function does not accept a minimum valid "
1025                      "argument count."));
1026           return false;
1027         }
1028       else
1029         {
1030           assert (f->flags & OPF_MIN_VALID);
1031           if (array_arg_cnt < f->array_min_elems)
1032             {
1033               msg (SE, _("%s requires at least %d valid arguments in list."),
1034                    f->prototype);
1035               return false;
1036             }
1037           else if (min_valid > array_arg_cnt)
1038             {
1039               msg (SE, _("With %s, "
1040                          "using minimum valid argument count of %d "
1041                          "does not make sense when passing only %d "
1042                          "arguments in list."),
1043                    f->prototype, min_valid, array_arg_cnt);
1044               return false;
1045             }
1046         }
1047     }
1048
1049   return true;
1050 }
1051
1052 static void
1053 add_arg (union any_node ***args, int *arg_cnt, int *arg_cap,
1054          union any_node *arg)
1055 {
1056   if (*arg_cnt >= *arg_cap)
1057     {
1058       *arg_cap += 8;
1059       *args = xrealloc (*args, sizeof **args * *arg_cap);
1060     }
1061
1062   (*args)[(*arg_cnt)++] = arg;
1063 }
1064
1065 static void
1066 put_invocation (struct string *s,
1067                 const char *func_name, union any_node **args, size_t arg_cnt)
1068 {
1069   size_t i;
1070
1071   ds_printf (s, "%s(", func_name);
1072   for (i = 0; i < arg_cnt; i++)
1073     {
1074       if (i > 0)
1075         ds_puts (s, ", ");
1076       ds_puts (s, operations[expr_node_returns (args[i])].prototype);
1077     }
1078   ds_putc (s, ')');
1079 }
1080
1081 static void
1082 no_match (const char *func_name,
1083           union any_node **args, size_t arg_cnt,
1084           const struct operation *first, const struct operation *last)
1085 {
1086   struct string s;
1087   const struct operation *f;
1088
1089   ds_init (&s, 128);
1090
1091   if (last - first == 1)
1092     {
1093       ds_printf (&s, _("Type mismatch invoking %s as "), first->prototype);
1094       put_invocation (&s, func_name, args, arg_cnt);
1095     }
1096   else
1097     {
1098       ds_create (&s, _("Function invocation "));
1099       put_invocation (&s, func_name, args, arg_cnt);
1100       ds_puts (&s, _(" does not match any known function.  Candidates are:"));
1101
1102       for (f = first; f < last; f++)
1103         {
1104           ds_printf (&s, "\n%s", f->prototype);
1105         }
1106     }
1107   ds_putc (&s, '.');
1108
1109   msg (SE, "%s", ds_c_str (&s));
1110
1111   ds_destroy (&s);
1112 }
1113
1114 static union any_node *
1115 parse_function (struct expression *e)
1116 {
1117   int min_valid;
1118   const struct operation *f, *first, *last;
1119
1120   union any_node **args = NULL;
1121   int arg_cnt = 0;
1122   int arg_cap = 0;
1123
1124   struct fixed_string func_name;
1125
1126   union any_node *n;
1127
1128   ls_create (&func_name, ds_c_str (&tokstr));
1129   min_valid = extract_min_valid (ds_c_str (&tokstr));
1130   if (!lookup_function (ds_c_str (&tokstr), &first, &last))
1131     {
1132       msg (SE, _("No function or vector named %s."), ds_c_str (&tokstr));
1133       ls_destroy (&func_name);
1134       return NULL;
1135     }
1136
1137   lex_get ();
1138   if (!lex_force_match ('('))
1139     {
1140       ls_destroy (&func_name);
1141       return NULL;
1142     }
1143
1144   args = NULL;
1145   arg_cnt = arg_cap = 0;
1146   if (token != ')')
1147     for (;;)
1148       {
1149         if (token == T_ID && lex_look_ahead () == 'T')
1150           {
1151             struct variable **vars;
1152             int var_cnt;
1153             int i;
1154
1155             if (!parse_variables (default_dict, &vars, &var_cnt, PV_SINGLE))
1156               goto fail;
1157             for (i = 0; i < var_cnt; i++)
1158               add_arg (&args, &arg_cnt, &arg_cap,
1159                        allocate_unary_variable (e, vars[i]));
1160             free (vars);
1161           }
1162         else
1163           {
1164             union any_node *arg = parse_or (e);
1165             if (arg == NULL)
1166               goto fail;
1167
1168             add_arg (&args, &arg_cnt, &arg_cap, arg);
1169           }
1170         if (lex_match (')'))
1171           break;
1172         else if (!lex_match (','))
1173           {
1174             lex_error (_("expecting `,' or `)' invoking %s function"),
1175                        first->name);
1176             goto fail;
1177           }
1178       }
1179
1180   for (f = first; f < last; f++)
1181     if (match_function (args, arg_cnt, f))
1182       break;
1183   if (f >= last)
1184     {
1185       no_match (ls_c_str (&func_name), args, arg_cnt, first, last);
1186       goto fail;
1187     }
1188
1189   coerce_function_args (e, f, args, arg_cnt);
1190   if (!validate_function_args (f, arg_cnt, min_valid))
1191     goto fail;
1192
1193   if ((f->flags & OPF_EXTENSION) && get_syntax () == COMPATIBLE)
1194     msg (SW, _("%s is a PSPP extension."), f->prototype);
1195   if (f->flags & OPF_UNIMPLEMENTED)
1196     {
1197       msg (SE, _("%s is not yet implemented."), f->prototype);
1198       goto fail;
1199     }
1200
1201   n = expr_allocate_composite (e, f - operations, args, arg_cnt);
1202   n->composite.min_valid = min_valid != -1 ? min_valid : f->array_min_elems;
1203
1204   if (n->type == OP_LAG_Vnn || n->type == OP_LAG_Vsn)
1205     {
1206       int n_before;
1207       assert (n->composite.arg_cnt == 2);
1208       assert (n->composite.args[1]->type == OP_pos_int);
1209       n_before = n->composite.args[1]->integer.i;
1210       if (n_before > n_lag)
1211         n_lag = n_before;
1212     }
1213
1214   free (args);
1215   ls_destroy (&func_name);
1216   return n;
1217
1218 fail:
1219   free (args);
1220   ls_destroy (&func_name);
1221   return NULL;
1222 }
1223 \f
1224 /* Utility functions. */
1225
1226 static struct expression *
1227 expr_create (struct dictionary *dict)
1228 {
1229   struct pool *pool = pool_create ();
1230   struct expression *e = pool_alloc (pool, sizeof *e);
1231   e->expr_pool = pool;
1232   e->dict = dict;
1233   e->eval_pool = pool_create_subpool (e->expr_pool);
1234   e->ops = NULL;
1235   e->op_types = NULL;
1236   e->op_cnt = e->op_cap = 0;
1237   return e;
1238 }
1239
1240 atom_type
1241 expr_node_returns (const union any_node *n)
1242 {
1243   assert (n != NULL);
1244   assert (is_operation (n->type));
1245   if (is_atom (n->type))
1246     return n->type;
1247   else if (is_composite (n->type))
1248     return operations[n->type].returns;
1249   else
1250     abort ();
1251 }
1252
1253 static const char *
1254 atom_type_name (atom_type type)
1255 {
1256   assert (is_atom (type));
1257   return operations[type].name;
1258 }
1259
1260 union any_node *
1261 expr_allocate_nullary (struct expression *e, operation_type op)
1262 {
1263   return expr_allocate_composite (e, op, NULL, 0);
1264 }
1265
1266 union any_node *
1267 expr_allocate_unary (struct expression *e, operation_type op,
1268 union any_node *arg0)
1269 {
1270   return expr_allocate_composite (e, op, &arg0, 1);
1271 }
1272
1273 union any_node *
1274 expr_allocate_binary (struct expression *e, operation_type op,
1275                       union any_node *arg0, union any_node *arg1)
1276 {
1277   union any_node *args[2];
1278   args[0] = arg0;
1279   args[1] = arg1;
1280   return expr_allocate_composite (e, op, args, 2);
1281 }
1282
1283 static bool
1284 is_valid_node (union any_node *n)
1285 {
1286   struct operation *op;
1287   size_t i;
1288
1289   assert (n != NULL);
1290   assert (is_operation (n->type));
1291   op = &operations[n->type];
1292
1293   if (!is_atom (n->type))
1294     {
1295       struct composite_node *c = &n->composite;
1296
1297       assert (is_composite (n->type));
1298       assert (c->arg_cnt >= op->arg_cnt);
1299       for (i = 0; i < op->arg_cnt; i++)
1300         assert (expr_node_returns (c->args[i]) == op->args[i]);
1301       if (c->arg_cnt > op->arg_cnt && !is_operator (n->type))
1302         {
1303           assert (op->flags & OPF_ARRAY_OPERAND);
1304           for (i = 0; i < c->arg_cnt; i++)
1305             assert (operations[c->args[i]->type].returns
1306                     == op->args[op->arg_cnt - 1]);
1307         }
1308     }
1309
1310   return true;
1311 }
1312
1313 union any_node *
1314 expr_allocate_composite (struct expression *e, operation_type op,
1315                          union any_node **args, size_t arg_cnt)
1316 {
1317   union any_node *n;
1318   size_t i;
1319
1320   n = pool_alloc (e->expr_pool, sizeof n->composite);
1321   n->type = op;
1322   n->composite.arg_cnt = arg_cnt;
1323   n->composite.args = pool_alloc (e->expr_pool,
1324                                   sizeof *n->composite.args * arg_cnt);
1325   for (i = 0; i < arg_cnt; i++)
1326     {
1327       if (args[i] == NULL)
1328         return NULL;
1329       n->composite.args[i] = args[i];
1330     }
1331   memcpy (n->composite.args, args, sizeof *n->composite.args * arg_cnt);
1332   n->composite.min_valid = 0;
1333   assert (is_valid_node (n));
1334   return n;
1335 }
1336
1337 union any_node *
1338 expr_allocate_number (struct expression *e, double d)
1339 {
1340   union any_node *n = pool_alloc (e->expr_pool, sizeof n->number);
1341   n->type = OP_number;
1342   n->number.n = d;
1343   return n;
1344 }
1345
1346 union any_node *
1347 expr_allocate_boolean (struct expression *e, double b)
1348 {
1349   union any_node *n = pool_alloc (e->expr_pool, sizeof n->number);
1350   assert (b == 0.0 || b == 1.0 || b == SYSMIS);
1351   n->type = OP_boolean;
1352   n->number.n = b;
1353   return n;
1354 }
1355
1356 union any_node *
1357 expr_allocate_integer (struct expression *e, int i)
1358 {
1359   union any_node *n = pool_alloc (e->expr_pool, sizeof n->integer);
1360   n->type = OP_integer;
1361   n->integer.i = i;
1362   return n;
1363 }
1364
1365 union any_node *
1366 expr_allocate_pos_int (struct expression *e, int i)
1367 {
1368   union any_node *n = pool_alloc (e->expr_pool, sizeof n->integer);
1369   assert (i > 0);
1370   n->type = OP_pos_int;
1371   n->integer.i = i;
1372   return n;
1373 }
1374
1375 union any_node *
1376 expr_allocate_vector (struct expression *e, const struct vector *vector)
1377 {
1378   union any_node *n = pool_alloc (e->expr_pool, sizeof n->vector);
1379   n->type = OP_vector;
1380   n->vector.v = vector;
1381   return n;
1382 }
1383
1384 union any_node *
1385 expr_allocate_string_buffer (struct expression *e,
1386                              const char *string, size_t length)
1387 {
1388   union any_node *n = pool_alloc (e->expr_pool, sizeof n->string);
1389   n->type = OP_string;
1390   if (length > 255)
1391     length = 255;
1392   n->string.s = copy_string (e, string, length);
1393   return n;
1394 }
1395
1396 union any_node *
1397 expr_allocate_string (struct expression *e, struct fixed_string s)
1398 {
1399   union any_node *n = pool_alloc (e->expr_pool, sizeof n->string);
1400   n->type = OP_string;
1401   n->string.s = s;
1402   return n;
1403 }
1404
1405 union any_node *
1406 expr_allocate_variable (struct expression *e, struct variable *v)
1407 {
1408   union any_node *n = pool_alloc (e->expr_pool, sizeof n->variable);
1409   n->type = v->type == NUMERIC ? OP_num_var : OP_str_var;
1410   n->variable.v = v;
1411   return n;
1412 }
1413
1414 union any_node *
1415 expr_allocate_format (struct expression *e, const struct fmt_spec *format)
1416 {
1417   union any_node *n = pool_alloc (e->expr_pool, sizeof n->format);
1418   n->type = OP_format;
1419   n->format.f = *format;
1420   return n;
1421 }
1422
1423 /* Allocates a unary composite node that represents the value of
1424    variable V in expression E. */
1425 static union any_node *
1426 allocate_unary_variable (struct expression *e, struct variable *v)
1427 {
1428   assert (v != NULL);
1429   return expr_allocate_unary (e, v->type == NUMERIC ? OP_NUM_VAR : OP_STR_VAR,
1430                               expr_allocate_variable (e, v));
1431 }