src/language/expressions/parse.c

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