src/language/expressions/parse.c

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