src/language/expressions/parse.c

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