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