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