src/language/expressions/parse.c

   1 /* PSPP - a program for statistical analysis.
   2    Copyright (C) 1997-9, 2000, 2006, 2010, 2011 Free Software Foundation, Inc.
   3
   4    This program is free software: you can redistribute it and/or modify
   5    it under the terms of the GNU General Public License as published by
   6    the Free Software Foundation, either version 3 of the License, or
   7    (at your option) any later version.
   8
   9    This program is distributed in the hope that it will be useful,
  10    but WITHOUT ANY WARRANTY; without even the implied warranty of
  11    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12    GNU General Public License for more details.
  13
  14    You should have received a copy of the GNU General Public License
  15    along with this program.  If not, see <http://www.gnu.org/licenses/>. */
  16
  17 #include <config.h>
  18
  19 #include "private.h"
  20
  21 #include <ctype.h>
  22 #include <float.h>
  23 #include <limits.h>
  24 #include <stdlib.h>
  25
  26 #include "data/case.h"
  27 #include "data/dictionary.h"
  28 #include "data/settings.h"
  29 #include "data/variable.h"
  30 #include "language/expressions/helpers.h"
  31 #include "language/lexer/format-parser.h"
  32 #include "language/lexer/lexer.h"
  33 #include "language/lexer/variable-parser.h"
  34 #include "libpspp/array.h"
  35 #include "libpspp/assertion.h"
  36 #include "libpspp/i18n.h"
  37 #include "libpspp/message.h"
  38 #include "libpspp/misc.h"
  39 #include "libpspp/pool.h"
  40 #include "libpspp/str.h"
  41
  42 #include "gl/xalloc.h"
  43 \f
  44 /* Declarations. */
  45
  46 /* Recursive descent parser in order of increasing precedence. */
  47 typedef union any_node *parse_recursively_func (struct lexer *, struct expression *);
  48 static parse_recursively_func parse_or, parse_and, parse_not;
  49 static parse_recursively_func parse_rel, parse_add, parse_mul;
  50 static parse_recursively_func parse_neg, parse_exp;
  51 static parse_recursively_func parse_primary;
  52 static parse_recursively_func parse_vector_element, parse_function;
  53
  54 /* Utility functions. */
  55 static struct expression *expr_create (struct dataset *ds);
  56 atom_type expr_node_returns (const union any_node *);
  57
  58 static const char *atom_type_name (atom_type);
  59 static struct expression *finish_expression (union any_node *,
  60                                              struct expression *);
  61 static bool type_check (struct expression *, union any_node **,
  62                         enum expr_type expected_type);
  63 static union any_node *allocate_unary_variable (struct expression *,
  64                                                 const struct variable *);
  65 \f
  66 /* Public functions. */
  67
  68 /* Parses an expression of the given TYPE.
  69    If DICT is nonnull then variables and vectors within it may be
  70    referenced within the expression; otherwise, the expression
  71    must not reference any variables or vectors.
  72    Returns the new expression if successful or a null pointer
  73    otherwise. */
  74 struct expression *
  75 expr_parse (struct lexer *lexer, struct dataset *ds, enum expr_type type)
  76 {
  77   union any_node *n;
  78   struct expression *e;
  79
  80   assert (type == EXPR_NUMBER || type == EXPR_STRING || type == EXPR_BOOLEAN);
  81
  82   e = expr_create (ds);
  83   n = parse_or (lexer, e);
  84   if (n != NULL && type_check (e, &n, type))
  85     return finish_expression (expr_optimize (n, e), e);
  86   else
  87     {
  88       expr_free (e);
  89       return NULL;
  90     }
  91 }
  92
  93 /* Parses and returns an expression of the given TYPE, as
  94    expr_parse(), and sets up so that destroying POOL will free
  95    the expression as well. */
  96 struct expression *
  97 expr_parse_pool (struct lexer *lexer,
  98                  struct pool *pool,
  99                  struct dataset *ds,
 100                  enum expr_type type)
 101 {
 102   struct expression *e = expr_parse (lexer, 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 lexer *lexer, 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 (lexer, 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             {
 349               union any_node *op_name;
 350
 351               op_name = expr_allocate_string (e, ss_cstr (operator_name));
 352               *node = expr_allocate_binary (e, OP_NUM_TO_BOOLEAN, *node,
 353                                             op_name);
 354             }
 355           return true;
 356         }
 357       break;
 358
 359     case OP_format:
 360       NOT_REACHED ();
 361
 362     case OP_ni_format:
 363       msg_disable ();
 364       if ((*node)->type == OP_format
 365           && fmt_check_input (&(*node)->format.f)
 366           && fmt_check_type_compat (&(*node)->format.f, VAL_NUMERIC))
 367         {
 368           msg_enable ();
 369           if (do_coercion)
 370             (*node)->type = OP_ni_format;
 371           return true;
 372         }
 373       msg_enable ();
 374       break;
 375
 376     case OP_no_format:
 377       msg_disable ();
 378       if ((*node)->type == OP_format
 379           && fmt_check_output (&(*node)->format.f)
 380           && fmt_check_type_compat (&(*node)->format.f, VAL_NUMERIC))
 381         {
 382           msg_enable ();
 383           if (do_coercion)
 384             (*node)->type = OP_no_format;
 385           return true;
 386         }
 387       msg_enable ();
 388       break;
 389
 390     case OP_num_var:
 391       if ((*node)->type == OP_NUM_VAR)
 392         {
 393           if (do_coercion)
 394             *node = (*node)->composite.args[0];
 395           return true;
 396         }
 397       break;
 398
 399     case OP_str_var:
 400       if ((*node)->type == OP_STR_VAR)
 401         {
 402           if (do_coercion)
 403             *node = (*node)->composite.args[0];
 404           return true;
 405         }
 406       break;
 407
 408     case OP_var:
 409       if ((*node)->type == OP_NUM_VAR || (*node)->type == OP_STR_VAR)
 410         {
 411           if (do_coercion)
 412             *node = (*node)->composite.args[0];
 413           return true;
 414         }
 415       break;
 416
 417     case OP_pos_int:
 418       if ((*node)->type == OP_number
 419           && floor ((*node)->number.n) == (*node)->number.n
 420           && (*node)->number.n > 0 && (*node)->number.n < INT_MAX)
 421         {
 422           if (do_coercion)
 423             *node = expr_allocate_pos_int (e, (*node)->number.n);
 424           return true;
 425         }
 426       break;
 427
 428     default:
 429       NOT_REACHED ();
 430     }
 431
 432   if (do_coercion)
 433     {
 434       msg (SE, _("Type mismatch while applying %s operator: "
 435                  "cannot convert %s to %s."),
 436            operator_name,
 437            atom_type_name (actual_type), atom_type_name (required_type));
 438       *node = NULL;
 439     }
 440   return false;
 441 }
 442
 443 /* Coerces *NODE to type REQUIRED_TYPE, and returns success.  If
 444    *NODE cannot be coerced to the desired type then we issue an
 445    error message about operator OPERATOR_NAME and free *NODE. */
 446 static bool
 447 type_coercion (struct expression *e,
 448                atom_type required_type, union any_node **node,
 449                const char *operator_name)
 450 {
 451   return type_coercion_core (e, required_type, node, operator_name, true);
 452 }
 453
 454 /* Coerces *NODE to type REQUIRED_TYPE.
 455    Assert-fails if the coercion is disallowed. */
 456 static void
 457 type_coercion_assert (struct expression *e,
 458                       atom_type required_type, union any_node **node)
 459 {
 460   int success = type_coercion_core (e, required_type, node, NULL, true);
 461   assert (success);
 462 }
 463
 464 /* Returns true if *NODE may be coerced to type REQUIRED_TYPE,
 465    false otherwise. */
 466 static bool
 467 is_coercible (atom_type required_type, union any_node *const *node)
 468 {
 469   return type_coercion_core (NULL, required_type,
 470                              (union any_node **) node, NULL, false);
 471 }
 472
 473 /* Returns true if ACTUAL_TYPE is a kind of REQUIRED_TYPE, false
 474    otherwise. */
 475 static bool
 476 is_compatible (atom_type required_type, atom_type actual_type)
 477 {
 478   return (required_type == actual_type
 479           || (required_type == OP_var
 480               && (actual_type == OP_num_var || actual_type == OP_str_var)));
 481 }
 482
 483 /* How to parse an operator. */
 484 struct operator
 485   {
 486     int token;                  /* Token representing operator. */
 487     operation_type type;        /* Operation type representing operation. */
 488     const char *name;           /* Name of operator. */
 489   };
 490
 491 /* Attempts to match the current token against the tokens for the
 492    OP_CNT operators in OPS[].  If successful, returns true
 493    and, if OPERATOR is non-null, sets *OPERATOR to the operator.
 494    On failure, returns false and, if OPERATOR is non-null, sets
 495    *OPERATOR to a null pointer. */
 496 static bool
 497 match_operator (struct lexer *lexer, const struct operator ops[], size_t op_cnt,
 498                 const struct operator **operator)
 499 {
 500   const struct operator *op;
 501
 502   for (op = ops; op < ops + op_cnt; op++)
 503     if (lex_token (lexer) == op->token)
 504       {
 505         if (op->token != T_NEG_NUM)
 506           lex_get (lexer);
 507         if (operator != NULL)
 508           *operator = op;
 509         return true;
 510       }
 511   if (operator != NULL)
 512     *operator = NULL;
 513   return false;
 514 }
 515
 516 static bool
 517 check_operator (const struct operator *op, int arg_cnt, atom_type arg_type)
 518 {
 519   const struct operation *o;
 520   size_t i;
 521
 522   assert (op != NULL);
 523   o = &operations[op->type];
 524   assert (o->arg_cnt == arg_cnt);
 525   assert ((o->flags & OPF_ARRAY_OPERAND) == 0);
 526   for (i = 0; i < arg_cnt; i++)
 527     assert (is_compatible (arg_type, o->args[i]));
 528   return true;
 529 }
 530
 531 static bool
 532 check_binary_operators (const struct operator ops[], size_t op_cnt,
 533                         atom_type arg_type)
 534 {
 535   size_t i;
 536
 537   for (i = 0; i < op_cnt; i++)
 538     check_operator (&ops[i], 2, arg_type);
 539   return true;
 540 }
 541
 542 static atom_type
 543 get_operand_type (const struct operator *op)
 544 {
 545   return operations[op->type].args[0];
 546 }
 547
 548 /* Parses a chain of left-associative operator/operand pairs.
 549    There are OP_CNT operators, specified in OPS[].  The
 550    operators' operands must all be the same type.  The next
 551    higher level is parsed by PARSE_NEXT_LEVEL.  If CHAIN_WARNING
 552    is non-null, then it will be issued as a warning if more than
 553    one operator/operand pair is parsed. */
 554 static union any_node *
 555 parse_binary_operators (struct lexer *lexer, struct expression *e, union any_node *node,
 556                         const struct operator ops[], size_t op_cnt,
 557                         parse_recursively_func *parse_next_level,
 558                         const char *chain_warning)
 559 {
 560   atom_type operand_type = get_operand_type (&ops[0]);
 561   int op_count;
 562   const struct operator *operator;
 563
 564   assert (check_binary_operators (ops, op_cnt, operand_type));
 565   if (node == NULL)
 566     return node;
 567
 568   for (op_count = 0; match_operator (lexer, ops, op_cnt, &operator); op_count++)
 569     {
 570       union any_node *rhs;
 571
 572       /* Convert the left-hand side to type OPERAND_TYPE. */
 573       if (!type_coercion (e, operand_type, &node, operator->name))
 574         return NULL;
 575
 576       /* Parse the right-hand side and coerce to type
 577          OPERAND_TYPE. */
 578       rhs = parse_next_level (lexer, e);
 579       if (!type_coercion (e, operand_type, &rhs, operator->name))
 580         return NULL;
 581       node = expr_allocate_binary (e, operator->type, node, rhs);
 582     }
 583
 584   if (op_count > 1 && chain_warning != NULL)
 585     msg (SW, "%s", chain_warning);
 586
 587   return node;
 588 }
 589
 590 static union any_node *
 591 parse_inverting_unary_operator (struct lexer *lexer, struct expression *e,
 592                                 const struct operator *op,
 593                                 parse_recursively_func *parse_next_level)
 594 {
 595   union any_node *node;
 596   unsigned op_count;
 597
 598   check_operator (op, 1, get_operand_type (op));
 599
 600   op_count = 0;
 601   while (match_operator (lexer, op, 1, NULL))
 602     op_count++;
 603
 604   node = parse_next_level (lexer, e);
 605   if (op_count > 0
 606       && type_coercion (e, get_operand_type (op), &node, op->name)
 607       && op_count % 2 != 0)
 608     return expr_allocate_unary (e, op->type, node);
 609   else
 610     return node;
 611 }
 612
 613 /* Parses the OR level. */
 614 static union any_node *
 615 parse_or (struct lexer *lexer, struct expression *e)
 616 {
 617   static const struct operator op =
 618     { T_OR, OP_OR, "logical disjunction (`OR')" };
 619
 620   return parse_binary_operators (lexer, e, parse_and (lexer, e), &op, 1, parse_and, NULL);
 621 }
 622
 623 /* Parses the AND level. */
 624 static union any_node *
 625 parse_and (struct lexer *lexer, struct expression *e)
 626 {
 627   static const struct operator op =
 628     { T_AND, OP_AND, "logical conjunction (`AND')" };
 629
 630   return parse_binary_operators (lexer, e, parse_not (lexer, e),
 631                                  &op, 1, parse_not, NULL);
 632 }
 633
 634 /* Parses the NOT level. */
 635 static union any_node *
 636 parse_not (struct lexer *lexer, struct expression *e)
 637 {
 638   static const struct operator op
 639     = { T_NOT, OP_NOT, "logical negation (`NOT')" };
 640   return parse_inverting_unary_operator (lexer, e, &op, parse_rel);
 641 }
 642
 643 /* Parse relational operators. */
 644 static union any_node *
 645 parse_rel (struct lexer *lexer, struct expression *e)
 646 {
 647   const char *chain_warning =
 648     _("Chaining relational operators (e.g. `a < b < c') will "
 649       "not produce the mathematically expected result.  "
 650       "Use the AND logical operator to fix the problem "
 651       "(e.g. `a < b AND b < c').  "
 652       "If chaining is really intended, parentheses will disable "
 653       "this warning (e.g. `(a < b) < c'.)");
 654
 655   union any_node *node = parse_add (lexer, e);
 656
 657   if (node == NULL)
 658     return NULL;
 659
 660   switch (expr_node_returns (node))
 661     {
 662     case OP_number:
 663     case OP_boolean:
 664       {
 665         static const struct operator ops[] =
 666           {
 667             { T_EQUALS, OP_EQ, "numeric equality (`=')" },
 668             { T_EQ, OP_EQ, "numeric equality (`EQ')" },
 669             { T_GE, OP_GE, "numeric greater-than-or-equal-to (`>=')" },
 670             { T_GT, OP_GT, "numeric greater than (`>')" },
 671             { T_LE, OP_LE, "numeric less-than-or-equal-to (`<=')" },
 672             { T_LT, OP_LT, "numeric less than (`<')" },
 673             { T_NE, OP_NE, "numeric inequality (`<>')" },
 674           };
 675
 676         return parse_binary_operators (lexer, e, node, ops,
 677                                        sizeof ops / sizeof *ops,
 678                                        parse_add, chain_warning);
 679       }
 680
 681     case OP_string:
 682       {
 683         static const struct operator ops[] =
 684           {
 685             { T_EQUALS, OP_EQ_STRING, "string equality (`=')" },
 686             { T_EQ, OP_EQ_STRING, "string equality (`EQ')" },
 687             { T_GE, OP_GE_STRING, "string greater-than-or-equal-to (`>=')" },
 688             { T_GT, OP_GT_STRING, "string greater than (`>')" },
 689             { T_LE, OP_LE_STRING, "string less-than-or-equal-to (`<=')" },
 690             { T_LT, OP_LT_STRING, "string less than (`<')" },
 691             { T_NE, OP_NE_STRING, "string inequality (`<>')" },
 692           };
 693
 694         return parse_binary_operators (lexer, e, node, ops,
 695                                        sizeof ops / sizeof *ops,
 696                                        parse_add, chain_warning);
 697       }
 698
 699     default:
 700       return node;
 701     }
 702 }
 703
 704 /* Parses the addition and subtraction level. */
 705 static union any_node *
 706 parse_add (struct lexer *lexer, struct expression *e)
 707 {
 708   static const struct operator ops[] =
 709     {
 710       { T_PLUS, OP_ADD, "addition (`+')" },
 711       { T_DASH, OP_SUB, "subtraction (`-')" },
 712       { T_NEG_NUM, OP_ADD, "subtraction (`-')" },
 713     };
 714
 715   return parse_binary_operators (lexer, e, parse_mul (lexer, e),
 716                                  ops, sizeof ops / sizeof *ops,
 717                                  parse_mul, NULL);
 718 }
 719
 720 /* Parses the multiplication and division level. */
 721 static union any_node *
 722 parse_mul (struct lexer *lexer, struct expression *e)
 723 {
 724   static const struct operator ops[] =
 725     {
 726       { T_ASTERISK, OP_MUL, "multiplication (`*')" },
 727       { T_SLASH, OP_DIV, "division (`/')" },
 728     };
 729
 730   return parse_binary_operators (lexer, e, parse_neg (lexer, e),
 731                                  ops, sizeof ops / sizeof *ops,
 732                                  parse_neg, NULL);
 733 }
 734
 735 /* Parses the unary minus level. */
 736 static union any_node *
 737 parse_neg (struct lexer *lexer, struct expression *e)
 738 {
 739   static const struct operator op = { T_DASH, OP_NEG, "negation (`-')" };
 740   return parse_inverting_unary_operator (lexer, e, &op, parse_exp);
 741 }
 742
 743 static union any_node *
 744 parse_exp (struct lexer *lexer, struct expression *e)
 745 {
 746   static const struct operator op =
 747     { T_EXP, OP_POW, "exponentiation (`**')" };
 748
 749   const char *chain_warning =
 750     _("The exponentiation operator (`**') is left-associative, "
 751       "even though right-associative semantics are more useful.  "
 752       "That is, `a**b**c' equals `(a**b)**c', not as `a**(b**c)'.  "
 753       "To disable this warning, insert parentheses.");
 754
 755   union any_node *lhs, *node;
 756   bool negative = false;
 757
 758   if (lex_token (lexer) == T_NEG_NUM)
 759     {
 760       lhs = expr_allocate_number (e, -lex_tokval (lexer));
 761       negative = true;
 762       lex_get (lexer);
 763     }
 764   else
 765     lhs = parse_primary (lexer, e);
 766
 767   node = parse_binary_operators (lexer, e, lhs, &op, 1,
 768                                   parse_primary, chain_warning);
 769   return negative ? expr_allocate_unary (e, OP_NEG, node) : node;
 770 }
 771
 772 /* Parses system variables. */
 773 static union any_node *
 774 parse_sysvar (struct lexer *lexer, struct expression *e)
 775 {
 776   if (lex_match_id (lexer, "$CASENUM"))
 777     return expr_allocate_nullary (e, OP_CASENUM);
 778   else if (lex_match_id (lexer, "$DATE"))
 779     {
 780       static const char *months[12] =
 781         {
 782           "JAN", "FEB", "MAR", "APR", "MAY", "JUN",
 783           "JUL", "AUG", "SEP", "OCT", "NOV", "DEC",
 784         };
 785
 786       time_t last_proc_time = time_of_last_procedure (e->ds);
 787       struct tm *time;
 788       char temp_buf[10];
 789       struct substring s;
 790
 791       time = localtime (&last_proc_time);
 792       sprintf (temp_buf, "%02d %s %02d", abs (time->tm_mday) % 100,
 793                months[abs (time->tm_mon) % 12], abs (time->tm_year) % 100);
 794
 795       ss_alloc_substring (&s, ss_cstr (temp_buf));
 796       return expr_allocate_string (e, s);
 797     }
 798   else if (lex_match_id (lexer, "$TRUE"))
 799     return expr_allocate_boolean (e, 1.0);
 800   else if (lex_match_id (lexer, "$FALSE"))
 801     return expr_allocate_boolean (e, 0.0);
 802   else if (lex_match_id (lexer, "$SYSMIS"))
 803     return expr_allocate_number (e, SYSMIS);
 804   else if (lex_match_id (lexer, "$JDATE"))
 805     {
 806       time_t time = time_of_last_procedure (e->ds);
 807       struct tm *tm = localtime (&time);
 808       return expr_allocate_number (e, expr_ymd_to_ofs (tm->tm_year + 1900,
 809                                                        tm->tm_mon + 1,
 810                                                        tm->tm_mday));
 811     }
 812   else if (lex_match_id (lexer, "$TIME"))
 813     {
 814       time_t time = time_of_last_procedure (e->ds);
 815       struct tm *tm = localtime (&time);
 816       return expr_allocate_number (e,
 817                                    expr_ymd_to_date (tm->tm_year + 1900,
 818                                                      tm->tm_mon + 1,
 819                                                      tm->tm_mday)
 820                                    + tm->tm_hour * 60 * 60.
 821                                    + tm->tm_min * 60.
 822                                    + tm->tm_sec);
 823     }
 824   else if (lex_match_id (lexer, "$LENGTH"))
 825     return expr_allocate_number (e, settings_get_viewlength ());
 826   else if (lex_match_id (lexer, "$WIDTH"))
 827     return expr_allocate_number (e, settings_get_viewwidth ());
 828   else
 829     {
 830       msg (SE, _("Unknown system variable %s."), lex_tokcstr (lexer));
 831       return NULL;
 832     }
 833 }
 834
 835 /* Parses numbers, varnames, etc. */
 836 static union any_node *
 837 parse_primary (struct lexer *lexer, struct expression *e)
 838 {
 839   switch (lex_token (lexer))
 840     {
 841     case T_ID:
 842       if (lex_next_token (lexer, 1) == T_LPAREN)
 843         {
 844           /* An identifier followed by a left parenthesis may be
 845              a vector element reference.  If not, it's a function
 846              call. */
 847           if (e->ds != NULL && dict_lookup_vector (dataset_dict (e->ds), lex_tokcstr (lexer)) != NULL)
 848             return parse_vector_element (lexer, e);
 849           else
 850             return parse_function (lexer, e);
 851         }
 852       else if (lex_tokcstr (lexer)[0] == '$')
 853         {
 854           /* $ at the beginning indicates a system variable. */
 855           return parse_sysvar (lexer, e);
 856         }
 857       else if (e->ds != NULL && dict_lookup_var (dataset_dict (e->ds), lex_tokcstr (lexer)))
 858         {
 859           /* It looks like a user variable.
 860              (It could be a format specifier, but we'll assume
 861              it's a variable unless proven otherwise. */
 862           return allocate_unary_variable (e, parse_variable (lexer, dataset_dict (e->ds)));
 863         }
 864       else
 865         {
 866           /* Try to parse it as a format specifier. */
 867           struct fmt_spec fmt;
 868           bool ok;
 869
 870           msg_disable ();
 871           ok = parse_format_specifier (lexer, &fmt);
 872           msg_enable ();
 873
 874           if (ok)
 875             return expr_allocate_format (e, &fmt);
 876
 877           /* All attempts failed. */
 878           msg (SE, _("Unknown identifier %s."), lex_tokcstr (lexer));
 879           return NULL;
 880         }
 881       break;
 882
 883     case T_POS_NUM:
 884     case T_NEG_NUM:
 885       {
 886         union any_node *node = expr_allocate_number (e, lex_tokval (lexer) );
 887         lex_get (lexer);
 888         return node;
 889       }
 890
 891     case T_STRING:
 892       {
 893         const char *dict_encoding;
 894         union any_node *node;
 895         char *s;
 896
 897         dict_encoding = (e->ds != NULL
 898                          ? dict_get_encoding (dataset_dict (e->ds))
 899                          : "UTF-8");
 900         s = recode_string (dict_encoding, "UTF-8", lex_tokcstr (lexer),
 901                            ss_length (lex_tokss (lexer)));
 902         node = expr_allocate_string (e, ss_cstr (s));
 903
 904         lex_get (lexer);
 905         return node;
 906       }
 907
 908     case T_LPAREN:
 909       {
 910         union any_node *node;
 911         lex_get (lexer);
 912         node = parse_or (lexer, e);
 913         if (node != NULL && !lex_force_match (lexer, T_RPAREN))
 914           return NULL;
 915         return node;
 916       }
 917
 918     default:
 919       lex_error (lexer, NULL);
 920       return NULL;
 921     }
 922 }
 923
 924 static union any_node *
 925 parse_vector_element (struct lexer *lexer, struct expression *e)
 926 {
 927   const struct vector *vector;
 928   union any_node *element;
 929
 930   /* Find vector, skip token.
 931      The caller must already have verified that the current token
 932      is the name of a vector. */
 933   vector = dict_lookup_vector (dataset_dict (e->ds), lex_tokcstr (lexer));
 934   assert (vector != NULL);
 935   lex_get (lexer);
 936
 937   /* Skip left parenthesis token.
 938      The caller must have verified that the lookahead is a left
 939      parenthesis. */
 940   assert (lex_token (lexer) == T_LPAREN);
 941   lex_get (lexer);
 942
 943   element = parse_or (lexer, e);
 944   if (!type_coercion (e, OP_number, &element, "vector indexing")
 945       || !lex_match (lexer, T_RPAREN))
 946     return NULL;
 947
 948   return expr_allocate_binary (e, (vector_get_type (vector) == VAL_NUMERIC
 949                                    ? OP_VEC_ELEM_NUM : OP_VEC_ELEM_STR),
 950                                element, expr_allocate_vector (e, vector));
 951 }
 952 \f
 953 /* Individual function parsing. */
 954
 955 const struct operation operations[OP_first + OP_cnt] = {
 956 #include "parse.inc"
 957 };
 958
 959 static bool
 960 word_matches (const char **test, const char **name)
 961 {
 962   size_t test_len = strcspn (*test, ".");
 963   size_t name_len = strcspn (*name, ".");
 964   if (test_len == name_len)
 965     {
 966       if (buf_compare_case (*test, *name, test_len))
 967         return false;
 968     }
 969   else if (test_len < 3 || test_len > name_len)
 970     return false;
 971   else
 972     {
 973       if (buf_compare_case (*test, *name, test_len))
 974         return false;
 975     }
 976
 977   *test += test_len;
 978   *name += name_len;
 979   if (**test != **name)
 980     return false;
 981
 982   if (**test == '.')
 983     {
 984       (*test)++;
 985       (*name)++;
 986     }
 987   return true;
 988 }
 989
 990 static int
 991 compare_names (const char *test, const char *name, bool abbrev_ok)
 992 {
 993   if (!abbrev_ok)
 994     return true;
 995
 996   for (;;)
 997     {
 998       if (!word_matches (&test, &name))
 999         return true;
1000       if (*name == '\0' && *test == '\0')
1001         return false;
1002     }
1003 }
1004
1005 static int
1006 compare_strings (const char *test, const char *name, bool abbrev_ok UNUSED)
1007 {
1008   return strcasecmp (test, name);
1009 }
1010
1011 static bool
1012 lookup_function_helper (const char *name,
1013                         int (*compare) (const char *test, const char *name,
1014                                         bool abbrev_ok),
1015                         const struct operation **first,
1016                         const struct operation **last)
1017 {
1018   const struct operation *f;
1019
1020   for (f = operations + OP_function_first;
1021        f <= operations + OP_function_last; f++)
1022     if (!compare (name, f->name, !(f->flags & OPF_NO_ABBREV)))
1023       {
1024         *first = f;
1025
1026         while (f <= operations + OP_function_last
1027                && !compare (name, f->name, !(f->flags & OPF_NO_ABBREV)))
1028           f++;
1029         *last = f;
1030
1031         return true;
1032       }
1033
1034   return false;
1035 }
1036
1037 static bool
1038 lookup_function (const char *name,
1039                  const struct operation **first,
1040                  const struct operation **last)
1041 {
1042   *first = *last = NULL;
1043   return (lookup_function_helper (name, compare_strings, first, last)
1044           || lookup_function_helper (name, compare_names, first, last));
1045 }
1046
1047 static int
1048 extract_min_valid (const char *s)
1049 {
1050   char *p = strrchr (s, '.');
1051   if (p == NULL
1052       || p[1] < '0' || p[1] > '9'
1053       || strspn (p + 1, "0123456789") != strlen (p + 1))
1054     return -1;
1055   *p = '\0';
1056   return atoi (p + 1);
1057 }
1058
1059 static atom_type
1060 function_arg_type (const struct operation *f, size_t arg_idx)
1061 {
1062   assert (arg_idx < f->arg_cnt || (f->flags & OPF_ARRAY_OPERAND));
1063
1064   return f->args[arg_idx < f->arg_cnt ? arg_idx : f->arg_cnt - 1];
1065 }
1066
1067 static bool
1068 match_function (union any_node **args, int arg_cnt, const struct operation *f)
1069 {
1070   size_t i;
1071
1072   if (arg_cnt < f->arg_cnt
1073       || (arg_cnt > f->arg_cnt && (f->flags & OPF_ARRAY_OPERAND) == 0)
1074       || arg_cnt - (f->arg_cnt - 1) < f->array_min_elems)
1075     return false;
1076
1077   for (i = 0; i < arg_cnt; i++)
1078     if (!is_coercible (function_arg_type (f, i), &args[i]))
1079       return false;
1080
1081   return true;
1082 }
1083
1084 static void
1085 coerce_function_args (struct expression *e, const struct operation *f,
1086                       union any_node **args, size_t arg_cnt)
1087 {
1088   int i;
1089
1090   for (i = 0; i < arg_cnt; i++)
1091     type_coercion_assert (e, function_arg_type (f, i), &args[i]);
1092 }
1093
1094 static bool
1095 validate_function_args (const struct operation *f, int arg_cnt, int min_valid)
1096 {
1097   int array_arg_cnt = arg_cnt - (f->arg_cnt - 1);
1098   if (array_arg_cnt < f->array_min_elems)
1099     {
1100       msg (SE, _("%s must have at least %d arguments in list."),
1101            f->prototype, f->array_min_elems);
1102       return false;
1103     }
1104
1105   if ((f->flags & OPF_ARRAY_OPERAND)
1106       && array_arg_cnt % f->array_granularity != 0)
1107     {
1108       if (f->array_granularity == 2)
1109         msg (SE, _("%s must have an even number of arguments in list."),
1110              f->prototype);
1111       else
1112         msg (SE, _("%s must have multiple of %d arguments in list."),
1113              f->prototype, f->array_granularity);
1114       return false;
1115     }
1116
1117   if (min_valid != -1)
1118     {
1119       if (f->array_min_elems == 0)
1120         {
1121           assert ((f->flags & OPF_MIN_VALID) == 0);
1122           msg (SE, _("%s function does not accept a minimum valid "
1123                      "argument count."), f->prototype);
1124           return false;
1125         }
1126       else
1127         {
1128           assert (f->flags & OPF_MIN_VALID);
1129           if (array_arg_cnt < f->array_min_elems)
1130             {
1131               msg (SE, _("%s requires at least %d valid arguments in list."),
1132                    f->prototype, f->array_min_elems);
1133               return false;
1134             }
1135           else if (min_valid > array_arg_cnt)
1136             {
1137               msg (SE, _("With %s, "
1138                          "using minimum valid argument count of %d "
1139                          "does not make sense when passing only %d "
1140                          "arguments in list."),
1141                    f->prototype, min_valid, array_arg_cnt);
1142               return false;
1143             }
1144         }
1145     }
1146
1147   return true;
1148 }
1149
1150 static void
1151 add_arg (union any_node ***args, int *arg_cnt, int *arg_cap,
1152          union any_node *arg)
1153 {
1154   if (*arg_cnt >= *arg_cap)
1155     {
1156       *arg_cap += 8;
1157       *args = xrealloc (*args, sizeof **args * *arg_cap);
1158     }
1159
1160   (*args)[(*arg_cnt)++] = arg;
1161 }
1162
1163 static void
1164 put_invocation (struct string *s,
1165                 const char *func_name, union any_node **args, size_t arg_cnt)
1166 {
1167   size_t i;
1168
1169   ds_put_format (s, "%s(", func_name);
1170   for (i = 0; i < arg_cnt; i++)
1171     {
1172       if (i > 0)
1173         ds_put_cstr (s, ", ");
1174       ds_put_cstr (s, operations[expr_node_returns (args[i])].prototype);
1175     }
1176   ds_put_byte (s, ')');
1177 }
1178
1179 static void
1180 no_match (const char *func_name,
1181           union any_node **args, size_t arg_cnt,
1182           const struct operation *first, const struct operation *last)
1183 {
1184   struct string s;
1185   const struct operation *f;
1186
1187   ds_init_empty (&s);
1188
1189   if (last - first == 1)
1190     {
1191       ds_put_format (&s, _("Type mismatch invoking %s as "), first->prototype);
1192       put_invocation (&s, func_name, args, arg_cnt);
1193     }
1194   else
1195     {
1196       ds_put_cstr (&s, _("Function invocation "));
1197       put_invocation (&s, func_name, args, arg_cnt);
1198       ds_put_cstr (&s, _(" does not match any known function.  Candidates are:"));
1199
1200       for (f = first; f < last; f++)
1201         ds_put_format (&s, "\n%s", f->prototype);
1202     }
1203   ds_put_byte (&s, '.');
1204
1205   msg (SE, "%s", ds_cstr (&s));
1206
1207   ds_destroy (&s);
1208 }
1209
1210 static union any_node *
1211 parse_function (struct lexer *lexer, struct expression *e)
1212 {
1213   int min_valid;
1214   const struct operation *f, *first, *last;
1215
1216   union any_node **args = NULL;
1217   int arg_cnt = 0;
1218   int arg_cap = 0;
1219
1220   struct string func_name;
1221
1222   union any_node *n;
1223
1224   ds_init_substring (&func_name, lex_tokss (lexer));
1225   min_valid = extract_min_valid (lex_tokcstr (lexer));
1226   if (!lookup_function (lex_tokcstr (lexer), &first, &last))
1227     {
1228       msg (SE, _("No function or vector named %s."), lex_tokcstr (lexer));
1229       ds_destroy (&func_name);
1230       return NULL;
1231     }
1232
1233   lex_get (lexer);
1234   if (!lex_force_match (lexer, T_LPAREN))
1235     {
1236       ds_destroy (&func_name);
1237       return NULL;
1238     }
1239
1240   args = NULL;
1241   arg_cnt = arg_cap = 0;
1242   if (lex_token (lexer) != T_RPAREN)
1243     for (;;)
1244       {
1245         if (lex_token (lexer) == T_ID
1246             && lex_next_token (lexer, 1) == T_TO)
1247           {
1248             const struct variable **vars;
1249             size_t var_cnt;
1250             size_t i;
1251
1252             if (!parse_variables_const (lexer, dataset_dict (e->ds), &vars, &var_cnt, PV_SINGLE))
1253               goto fail;
1254             for (i = 0; i < var_cnt; i++)
1255               add_arg (&args, &arg_cnt, &arg_cap,
1256                        allocate_unary_variable (e, vars[i]));
1257             free (vars);
1258           }
1259         else
1260           {
1261             union any_node *arg = parse_or (lexer, e);
1262             if (arg == NULL)
1263               goto fail;
1264
1265             add_arg (&args, &arg_cnt, &arg_cap, arg);
1266           }
1267         if (lex_match (lexer, T_RPAREN))
1268           break;
1269         else if (!lex_match (lexer, T_COMMA))
1270           {
1271             lex_error (lexer, _("expecting `,' or `)' invoking %s function"),
1272                        first->name);
1273             goto fail;
1274           }
1275       }
1276
1277   for (f = first; f < last; f++)
1278     if (match_function (args, arg_cnt, f))
1279       break;
1280   if (f >= last)
1281     {
1282       no_match (ds_cstr (&func_name), args, arg_cnt, first, last);
1283       goto fail;
1284     }
1285
1286   coerce_function_args (e, f, args, arg_cnt);
1287   if (!validate_function_args (f, arg_cnt, min_valid))
1288     goto fail;
1289
1290   if ((f->flags & OPF_EXTENSION) && settings_get_syntax () == COMPATIBLE)
1291     msg (SW, _("%s is a PSPP extension."), f->prototype);
1292   if (f->flags & OPF_UNIMPLEMENTED)
1293     {
1294       msg (SE, _("%s is not yet implemented."), f->prototype);
1295       goto fail;
1296     }
1297   if ((f->flags & OPF_PERM_ONLY) &&
1298       proc_in_temporary_transformations (e->ds))
1299     {
1300       msg (SE, _("%s may not appear after TEMPORARY."), f->prototype);
1301       goto fail;
1302     }
1303
1304   n = expr_allocate_composite (e, f - operations, args, arg_cnt);
1305   n->composite.min_valid = min_valid != -1 ? min_valid : f->array_min_elems;
1306
1307   if (n->type == OP_LAG_Vn || n->type == OP_LAG_Vs)
1308     dataset_need_lag (e->ds, 1);
1309   else if (n->type == OP_LAG_Vnn || n->type == OP_LAG_Vsn)
1310     {
1311       int n_before;
1312       assert (n->composite.arg_cnt == 2);
1313       assert (n->composite.args[1]->type == OP_pos_int);
1314       n_before = n->composite.args[1]->integer.i;
1315       dataset_need_lag (e->ds, n_before);
1316     }
1317
1318   free (args);
1319   ds_destroy (&func_name);
1320   return n;
1321
1322 fail:
1323   free (args);
1324   ds_destroy (&func_name);
1325   return NULL;
1326 }
1327 \f
1328 /* Utility functions. */
1329
1330 static struct expression *
1331 expr_create (struct dataset *ds)
1332 {
1333   struct pool *pool = pool_create ();
1334   struct expression *e = pool_alloc (pool, sizeof *e);
1335   e->expr_pool = pool;
1336   e->ds = ds;
1337   e->eval_pool = pool_create_subpool (e->expr_pool);
1338   e->ops = NULL;
1339   e->op_types = NULL;
1340   e->op_cnt = e->op_cap = 0;
1341   return e;
1342 }
1343
1344 atom_type
1345 expr_node_returns (const union any_node *n)
1346 {
1347   assert (n != NULL);
1348   assert (is_operation (n->type));
1349   if (is_atom (n->type))
1350     return n->type;
1351   else if (is_composite (n->type))
1352     return operations[n->type].returns;
1353   else
1354     NOT_REACHED ();
1355 }
1356
1357 static const char *
1358 atom_type_name (atom_type type)
1359 {
1360   assert (is_atom (type));
1361   return operations[type].name;
1362 }
1363
1364 union any_node *
1365 expr_allocate_nullary (struct expression *e, operation_type op)
1366 {
1367   return expr_allocate_composite (e, op, NULL, 0);
1368 }
1369
1370 union any_node *
1371 expr_allocate_unary (struct expression *e, operation_type op,
1372                      union any_node *arg0)
1373 {
1374   return expr_allocate_composite (e, op, &arg0, 1);
1375 }
1376
1377 union any_node *
1378 expr_allocate_binary (struct expression *e, operation_type op,
1379                       union any_node *arg0, union any_node *arg1)
1380 {
1381   union any_node *args[2];
1382   args[0] = arg0;
1383   args[1] = arg1;
1384   return expr_allocate_composite (e, op, args, 2);
1385 }
1386
1387 static bool
1388 is_valid_node (union any_node *n)
1389 {
1390   const struct operation *op;
1391   size_t i;
1392
1393   assert (n != NULL);
1394   assert (is_operation (n->type));
1395   op = &operations[n->type];
1396
1397   if (!is_atom (n->type))
1398     {
1399       struct composite_node *c = &n->composite;
1400
1401       assert (is_composite (n->type));
1402       assert (c->arg_cnt >= op->arg_cnt);
1403       for (i = 0; i < op->arg_cnt; i++)
1404         assert (is_compatible (op->args[i], expr_node_returns (c->args[i])));
1405       if (c->arg_cnt > op->arg_cnt && !is_operator (n->type))
1406         {
1407           assert (op->flags & OPF_ARRAY_OPERAND);
1408           for (i = 0; i < c->arg_cnt; i++)
1409             assert (is_compatible (op->args[op->arg_cnt - 1],
1410                                    expr_node_returns (c->args[i])));
1411         }
1412     }
1413
1414   return true;
1415 }
1416
1417 union any_node *
1418 expr_allocate_composite (struct expression *e, operation_type op,
1419                          union any_node **args, size_t arg_cnt)
1420 {
1421   union any_node *n;
1422   size_t i;
1423
1424   n = pool_alloc (e->expr_pool, sizeof n->composite);
1425   n->type = op;
1426   n->composite.arg_cnt = arg_cnt;
1427   n->composite.args = pool_alloc (e->expr_pool,
1428                                   sizeof *n->composite.args * arg_cnt);
1429   for (i = 0; i < arg_cnt; i++)
1430     {
1431       if (args[i] == NULL)
1432         return NULL;
1433       n->composite.args[i] = args[i];
1434     }
1435   memcpy (n->composite.args, args, sizeof *n->composite.args * arg_cnt);
1436   n->composite.min_valid = 0;
1437   assert (is_valid_node (n));
1438   return n;
1439 }
1440
1441 union any_node *
1442 expr_allocate_number (struct expression *e, double d)
1443 {
1444   union any_node *n = pool_alloc (e->expr_pool, sizeof n->number);
1445   n->type = OP_number;
1446   n->number.n = d;
1447   return n;
1448 }
1449
1450 union any_node *
1451 expr_allocate_boolean (struct expression *e, double b)
1452 {
1453   union any_node *n = pool_alloc (e->expr_pool, sizeof n->number);
1454   assert (b == 0.0 || b == 1.0 || b == SYSMIS);
1455   n->type = OP_boolean;
1456   n->number.n = b;
1457   return n;
1458 }
1459
1460 union any_node *
1461 expr_allocate_integer (struct expression *e, int i)
1462 {
1463   union any_node *n = pool_alloc (e->expr_pool, sizeof n->integer);
1464   n->type = OP_integer;
1465   n->integer.i = i;
1466   return n;
1467 }
1468
1469 union any_node *
1470 expr_allocate_pos_int (struct expression *e, int i)
1471 {
1472   union any_node *n = pool_alloc (e->expr_pool, sizeof n->integer);
1473   assert (i > 0);
1474   n->type = OP_pos_int;
1475   n->integer.i = i;
1476   return n;
1477 }
1478
1479 union any_node *
1480 expr_allocate_vector (struct expression *e, const struct vector *vector)
1481 {
1482   union any_node *n = pool_alloc (e->expr_pool, sizeof n->vector);
1483   n->type = OP_vector;
1484   n->vector.v = vector;
1485   return n;
1486 }
1487
1488 union any_node *
1489 expr_allocate_string (struct expression *e, struct substring s)
1490 {
1491   union any_node *n = pool_alloc (e->expr_pool, sizeof n->string);
1492   n->type = OP_string;
1493   n->string.s = s;
1494   return n;
1495 }
1496
1497 union any_node *
1498 expr_allocate_variable (struct expression *e, const struct variable *v)
1499 {
1500   union any_node *n = pool_alloc (e->expr_pool, sizeof n->variable);
1501   n->type = var_is_numeric (v) ? OP_num_var : OP_str_var;
1502   n->variable.v = v;
1503   return n;
1504 }
1505
1506 union any_node *
1507 expr_allocate_format (struct expression *e, const struct fmt_spec *format)
1508 {
1509   union any_node *n = pool_alloc (e->expr_pool, sizeof n->format);
1510   n->type = OP_format;
1511   n->format.f = *format;
1512   return n;
1513 }
1514
1515 /* Allocates a unary composite node that represents the value of
1516    variable V in expression E. */
1517 static union any_node *
1518 allocate_unary_variable (struct expression *e, const struct variable *v)
1519 {
1520   assert (v != NULL);
1521   return expr_allocate_unary (e, var_is_numeric (v) ? OP_NUM_VAR : OP_STR_VAR,
1522                               expr_allocate_variable (e, v));
1523 }
1524 \f
1525 /* Export function details to other modules. */
1526
1527 /* Returns the operation structure for the function with the
1528    given IDX. */
1529 const struct operation *
1530 expr_get_function (size_t idx)
1531 {
1532   assert (idx < OP_function_cnt);
1533   return &operations[OP_function_first + idx];
1534 }
1535
1536 /* Returns the number of expression functions. */
1537 size_t
1538 expr_get_function_cnt (void)
1539 {
1540   return OP_function_cnt;
1541 }
1542
1543 /* Returns the name of operation OP. */
1544 const char *
1545 expr_operation_get_name (const struct operation *op)
1546 {
1547   return op->name;
1548 }
1549
1550 /* Returns the human-readable prototype for operation OP. */
1551 const char *
1552 expr_operation_get_prototype (const struct operation *op)
1553 {
1554   return op->prototype;
1555 }
1556
1557 /* Returns the number of arguments for operation OP. */
1558 int
1559 expr_operation_get_arg_cnt (const struct operation *op)
1560 {
1561   return op->arg_cnt;
1562 }