src/language/expressions/parse.c

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