src/language/expressions/parse.c

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