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