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