src/language/expressions/parse.c

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