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