1 /* PSPP - computes sample statistics.
2 Copyright (C) 1997-9, 2000 Free Software Foundation, Inc.
3 Written by Ben Pfaff <blp@gnu.org>.
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.
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.
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
26 #include <libpspp/array.h>
27 #include <libpspp/alloc.h>
28 #include <data/case.h>
29 #include <data/dictionary.h>
30 #include <libpspp/message.h>
32 #include <language/lexer/format-parser.h>
33 #include <language/lexer/lexer.h>
34 #include <language/lexer/variable-parser.h>
35 #include <libpspp/assertion.h>
36 #include <libpspp/misc.h>
37 #include <libpspp/pool.h>
38 #include <data/settings.h>
39 #include <libpspp/str.h>
40 #include <data/variable.h>
44 /* Recursive descent parser in order of increasing precedence. */
45 typedef union any_node *parse_recursively_func (struct expression *);
46 static parse_recursively_func parse_or, parse_and, parse_not;
47 static parse_recursively_func parse_rel, parse_add, parse_mul;
48 static parse_recursively_func parse_neg, parse_exp;
49 static parse_recursively_func parse_primary;
50 static parse_recursively_func parse_vector_element, parse_function;
52 /* Utility functions. */
53 static struct expression *expr_create (struct dataset *ds);
54 atom_type expr_node_returns (const union any_node *);
56 static const char *atom_type_name (atom_type);
57 static struct expression *finish_expression (union any_node *,
59 static bool type_check (struct expression *, union any_node **,
60 enum expr_type expected_type);
61 static union any_node *allocate_unary_variable (struct expression *,
64 /* Public functions. */
66 /* Parses an expression of the given TYPE.
67 If DICT is nonnull then variables and vectors within it may be
68 referenced within the expression; otherwise, the expression
69 must not reference any variables or vectors.
70 Returns the new expression if successful or a null pointer
73 expr_parse (struct dataset *ds, enum expr_type type)
78 assert (type == EXPR_NUMBER || type == EXPR_STRING || type == EXPR_BOOLEAN);
82 if (n != NULL && type_check (e, &n, type))
83 return finish_expression (expr_optimize (n, e), e);
91 /* Parses and returns an expression of the given TYPE, as
92 expr_parse(), and sets up so that destroying POOL will free
93 the expression as well. */
95 expr_parse_pool (struct pool *pool,
99 struct expression *e = expr_parse (ds, type);
101 pool_add_subpool (pool, e->expr_pool);
105 /* Free expression E. */
107 expr_free (struct expression *e)
110 pool_destroy (e->expr_pool);
114 expr_parse_any (struct dataset *ds, bool optimize)
117 struct expression *e;
119 e = expr_create (ds);
128 n = expr_optimize (n, e);
129 return finish_expression (n, e);
132 /* Finishing up expression building. */
134 /* Height of an expression's stacks. */
137 int number_height; /* Height of number stack. */
138 int string_height; /* Height of string stack. */
141 /* Stack heights used by different kinds of arguments. */
142 static const struct stack_heights on_number_stack = {1, 0};
143 static const struct stack_heights on_string_stack = {0, 1};
144 static const struct stack_heights not_on_stack = {0, 0};
146 /* Returns the stack heights used by an atom of the given
148 static const struct stack_heights *
149 atom_type_stack (atom_type type)
151 assert (is_atom (type));
157 return &on_number_stack;
160 return &on_string_stack;
170 return ¬_on_stack;
177 /* Measures the stack height needed for node N, supposing that
178 the stack height is initially *HEIGHT and updating *HEIGHT to
179 the final stack height. Updates *MAX, if necessary, to
180 reflect the maximum intermediate or final height. */
182 measure_stack (const union any_node *n,
183 struct stack_heights *height, struct stack_heights *max)
185 const struct stack_heights *return_height;
187 if (is_composite (n->type))
189 struct stack_heights args;
193 for (i = 0; i < n->composite.arg_cnt; i++)
194 measure_stack (n->composite.args[i], &args, max);
196 return_height = atom_type_stack (operations[n->type].returns);
199 return_height = atom_type_stack (n->type);
201 height->number_height += return_height->number_height;
202 height->string_height += return_height->string_height;
204 if (height->number_height > max->number_height)
205 max->number_height = height->number_height;
206 if (height->string_height > max->string_height)
207 max->string_height = height->string_height;
210 /* Allocates stacks within E sufficient for evaluating node N. */
212 allocate_stacks (union any_node *n, struct expression *e)
214 struct stack_heights initial = {0, 0};
215 struct stack_heights max = {0, 0};
217 measure_stack (n, &initial, &max);
218 e->number_stack = pool_alloc (e->expr_pool,
219 sizeof *e->number_stack * max.number_height);
220 e->string_stack = pool_alloc (e->expr_pool,
221 sizeof *e->string_stack * max.string_height);
224 /* Finalizes expression E for evaluating node N. */
225 static struct expression *
226 finish_expression (union any_node *n, struct expression *e)
228 /* Allocate stacks. */
229 allocate_stacks (n, e);
231 /* Output postfix representation. */
234 /* The eval_pool might have been used for allocating strings
235 during optimization. We need to keep those strings around
236 for all subsequent evaluations, so start a new eval_pool. */
237 e->eval_pool = pool_create_subpool (e->expr_pool);
242 /* Verifies that expression E, whose root node is *N, can be
243 converted to type EXPECTED_TYPE, inserting a conversion at *N
244 if necessary. Returns true if successful, false on failure. */
246 type_check (struct expression *e,
247 union any_node **n, enum expr_type expected_type)
249 atom_type actual_type = expr_node_returns (*n);
251 switch (expected_type)
255 if (actual_type != OP_number && actual_type != OP_boolean)
257 msg (SE, _("Type mismatch: expression has %s type, "
258 "but a numeric value is required here."),
259 atom_type_name (actual_type));
262 if (actual_type == OP_number && expected_type == OP_boolean)
263 *n = expr_allocate_unary (e, OP_NUM_TO_BOOLEAN, *n);
267 if (actual_type != OP_string)
269 msg (SE, _("Type mismatch: expression has %s type, "
270 "but a string value is required here."),
271 atom_type_name (actual_type));
283 /* Recursive-descent expression parser. */
285 /* Considers whether *NODE may be coerced to type REQUIRED_TYPE.
286 Returns true if possible, false if disallowed.
288 If DO_COERCION is false, then *NODE is not modified and there
291 If DO_COERCION is true, we perform the coercion if possible,
292 modifying *NODE if necessary. If the coercion is not possible
293 then we free *NODE and set *NODE to a null pointer.
295 This function's interface is somewhat awkward. Use one of the
296 wrapper functions type_coercion(), type_coercion_assert(), or
297 is_coercible() instead. */
299 type_coercion_core (struct expression *e,
300 atom_type required_type,
301 union any_node **node,
302 const char *operator_name,
305 atom_type actual_type;
307 assert (!!do_coercion == (e != NULL));
310 /* Propagate error. Whatever caused the original error
311 already emitted an error message. */
315 actual_type = expr_node_returns (*node);
316 if (actual_type == required_type)
322 switch (required_type)
325 if (actual_type == OP_boolean)
327 /* To enforce strict typing rules, insert Boolean to
328 numeric "conversion". This conversion is a no-op,
329 so it will be removed later. */
331 *node = expr_allocate_unary (e, OP_BOOLEAN_TO_NUM, *node);
337 /* No coercion to string. */
341 if (actual_type == OP_number)
343 /* Convert numeric to boolean. */
345 *node = expr_allocate_unary (e, OP_NUM_TO_BOOLEAN, *node);
354 if ((*node)->type == OP_format
355 && check_input_specifier (&(*node)->format.f, false)
356 && check_specifier_type (&(*node)->format.f, NUMERIC, false))
359 (*node)->type = OP_ni_format;
365 if ((*node)->type == OP_format
366 && check_output_specifier (&(*node)->format.f, false)
367 && check_specifier_type (&(*node)->format.f, NUMERIC, false))
370 (*node)->type = OP_no_format;
376 if ((*node)->type == OP_NUM_VAR)
379 *node = (*node)->composite.args[0];
385 if ((*node)->type == OP_STR_VAR)
388 *node = (*node)->composite.args[0];
394 if ((*node)->type == OP_number
395 && floor ((*node)->number.n) == (*node)->number.n
396 && (*node)->number.n > 0 && (*node)->number.n < INT_MAX)
399 *node = expr_allocate_pos_int (e, (*node)->number.n);
410 msg (SE, _("Type mismatch while applying %s operator: "
411 "cannot convert %s to %s."),
413 atom_type_name (actual_type), atom_type_name (required_type));
419 /* Coerces *NODE to type REQUIRED_TYPE, and returns success. If
420 *NODE cannot be coerced to the desired type then we issue an
421 error message about operator OPERATOR_NAME and free *NODE. */
423 type_coercion (struct expression *e,
424 atom_type required_type, union any_node **node,
425 const char *operator_name)
427 return type_coercion_core (e, required_type, node, operator_name, true);
430 /* Coerces *NODE to type REQUIRED_TYPE.
431 Assert-fails if the coercion is disallowed. */
433 type_coercion_assert (struct expression *e,
434 atom_type required_type, union any_node **node)
436 int success = type_coercion_core (e, required_type, node, NULL, true);
440 /* Returns true if *NODE may be coerced to type REQUIRED_TYPE,
443 is_coercible (atom_type required_type, union any_node *const *node)
445 return type_coercion_core (NULL, required_type,
446 (union any_node **) node, NULL, false);
449 /* How to parse an operator. */
452 int token; /* Token representing operator. */
453 operation_type type; /* Operation type representing operation. */
454 const char *name; /* Name of operator. */
457 /* Attempts to match the current token against the tokens for the
458 OP_CNT operators in OPS[]. If successful, returns true
459 and, if OPERATOR is non-null, sets *OPERATOR to the operator.
460 On failure, returns false and, if OPERATOR is non-null, sets
461 *OPERATOR to a null pointer. */
463 match_operator (const struct operator ops[], size_t op_cnt,
464 const struct operator **operator)
466 const struct operator *op;
468 for (op = ops; op < ops + op_cnt; op++)
470 if (op->token == '-')
471 lex_negative_to_dash ();
472 if (lex_match (op->token))
474 if (operator != NULL)
479 if (operator != NULL)
485 check_operator (const struct operator *op, int arg_cnt, atom_type arg_type)
487 const struct operation *o;
491 o = &operations[op->type];
492 assert (o->arg_cnt == arg_cnt);
493 assert ((o->flags & OPF_ARRAY_OPERAND) == 0);
494 for (i = 0; i < arg_cnt; i++)
495 assert (o->args[i] == arg_type);
500 check_binary_operators (const struct operator ops[], size_t op_cnt,
505 for (i = 0; i < op_cnt; i++)
506 check_operator (&ops[i], 2, arg_type);
511 get_operand_type (const struct operator *op)
513 return operations[op->type].args[0];
516 /* Parses a chain of left-associative operator/operand pairs.
517 There are OP_CNT operators, specified in OPS[]. The
518 operators' operands must all be the same type. The next
519 higher level is parsed by PARSE_NEXT_LEVEL. If CHAIN_WARNING
520 is non-null, then it will be issued as a warning if more than
521 one operator/operand pair is parsed. */
522 static union any_node *
523 parse_binary_operators (struct expression *e, union any_node *node,
524 const struct operator ops[], size_t op_cnt,
525 parse_recursively_func *parse_next_level,
526 const char *chain_warning)
528 atom_type operand_type = get_operand_type (&ops[0]);
530 const struct operator *operator;
532 assert (check_binary_operators (ops, op_cnt, operand_type));
536 for (op_count = 0; match_operator (ops, op_cnt, &operator); op_count++)
540 /* Convert the left-hand side to type OPERAND_TYPE. */
541 if (!type_coercion (e, operand_type, &node, operator->name))
544 /* Parse the right-hand side and coerce to type
546 rhs = parse_next_level (e);
547 if (!type_coercion (e, operand_type, &rhs, operator->name))
549 node = expr_allocate_binary (e, operator->type, node, rhs);
552 if (op_count > 1 && chain_warning != NULL)
553 msg (SW, chain_warning);
558 static union any_node *
559 parse_inverting_unary_operator (struct expression *e,
560 const struct operator *op,
561 parse_recursively_func *parse_next_level)
563 union any_node *node;
566 check_operator (op, 1, get_operand_type (op));
569 while (match_operator (op, 1, NULL))
572 node = parse_next_level (e);
574 && type_coercion (e, get_operand_type (op), &node, op->name)
575 && op_count % 2 != 0)
576 return expr_allocate_unary (e, op->type, node);
581 /* Parses the OR level. */
582 static union any_node *
583 parse_or (struct expression *e)
585 static const struct operator op =
586 { T_OR, OP_OR, "logical disjunction (\"OR\")" };
588 return parse_binary_operators (e, parse_and (e), &op, 1, parse_and, NULL);
591 /* Parses the AND level. */
592 static union any_node *
593 parse_and (struct expression *e)
595 static const struct operator op =
596 { T_AND, OP_AND, "logical conjunction (\"AND\")" };
598 return parse_binary_operators (e, parse_not (e), &op, 1, parse_not, NULL);
601 /* Parses the NOT level. */
602 static union any_node *
603 parse_not (struct expression *e)
605 static const struct operator op
606 = { T_NOT, OP_NOT, "logical negation (\"NOT\")" };
607 return parse_inverting_unary_operator (e, &op, parse_rel);
610 /* Parse relational operators. */
611 static union any_node *
612 parse_rel (struct expression *e)
614 const char *chain_warning =
615 _("Chaining relational operators (e.g. \"a < b < c\") will "
616 "not produce the mathematically expected result. "
617 "Use the AND logical operator to fix the problem "
618 "(e.g. \"a < b AND b < c\"). "
619 "If chaining is really intended, parentheses will disable "
620 "this warning (e.g. \"(a < b) < c\".)");
622 union any_node *node = parse_add (e);
627 switch (expr_node_returns (node))
632 static const struct operator ops[] =
634 { '=', OP_EQ, "numeric equality (\"=\")" },
635 { T_EQ, OP_EQ, "numeric equality (\"EQ\")" },
636 { T_GE, OP_GE, "numeric greater-than-or-equal-to (\">=\")" },
637 { T_GT, OP_GT, "numeric greater than (\">\")" },
638 { T_LE, OP_LE, "numeric less-than-or-equal-to (\"<=\")" },
639 { T_LT, OP_LT, "numeric less than (\"<\")" },
640 { T_NE, OP_NE, "numeric inequality (\"<>\")" },
643 return parse_binary_operators (e, node, ops, sizeof ops / sizeof *ops,
644 parse_add, chain_warning);
649 static const struct operator ops[] =
651 { '=', OP_EQ_STRING, "string equality (\"=\")" },
652 { T_EQ, OP_EQ_STRING, "string equality (\"EQ\")" },
653 { T_GE, OP_GE_STRING, "string greater-than-or-equal-to (\">=\")" },
654 { T_GT, OP_GT_STRING, "string greater than (\">\")" },
655 { T_LE, OP_LE_STRING, "string less-than-or-equal-to (\"<=\")" },
656 { T_LT, OP_LT_STRING, "string less than (\"<\")" },
657 { T_NE, OP_NE_STRING, "string inequality (\"<>\")" },
660 return parse_binary_operators (e, node, ops, sizeof ops / sizeof *ops,
661 parse_add, chain_warning);
669 /* Parses the addition and subtraction level. */
670 static union any_node *
671 parse_add (struct expression *e)
673 static const struct operator ops[] =
675 { '+', OP_ADD, "addition (\"+\")" },
676 { '-', OP_SUB, "subtraction (\"-\")" },
679 return parse_binary_operators (e, parse_mul (e),
680 ops, sizeof ops / sizeof *ops,
684 /* Parses the multiplication and division level. */
685 static union any_node *
686 parse_mul (struct expression *e)
688 static const struct operator ops[] =
690 { '*', OP_MUL, "multiplication (\"*\")" },
691 { '/', OP_DIV, "division (\"/\")" },
694 return parse_binary_operators (e, parse_neg (e),
695 ops, sizeof ops / sizeof *ops,
699 /* Parses the unary minus level. */
700 static union any_node *
701 parse_neg (struct expression *e)
703 static const struct operator op = { '-', OP_NEG, "negation (\"-\")" };
704 return parse_inverting_unary_operator (e, &op, parse_exp);
707 static union any_node *
708 parse_exp (struct expression *e)
710 static const struct operator op =
711 { T_EXP, OP_POW, "exponentiation (\"**\")" };
713 const char *chain_warning =
714 _("The exponentiation operator (\"**\") is left-associative, "
715 "even though right-associative semantics are more useful. "
716 "That is, \"a**b**c\" equals \"(a**b)**c\", not as \"a**(b**c)\". "
717 "To disable this warning, insert parentheses.");
719 return parse_binary_operators (e, parse_primary (e), &op, 1,
720 parse_primary, chain_warning);
723 /* Parses system variables. */
724 static union any_node *
725 parse_sysvar (struct expression *e)
727 if (lex_match_id ("$CASENUM"))
728 return expr_allocate_nullary (e, OP_CASENUM);
729 else if (lex_match_id ("$DATE"))
731 static const char *months[12] =
733 "JAN", "FEB", "MAR", "APR", "MAY", "JUN",
734 "JUL", "AUG", "SEP", "OCT", "NOV", "DEC",
737 time_t last_proc_time = time_of_last_procedure (e->ds);
741 time = localtime (&last_proc_time);
742 sprintf (temp_buf, "%02d %s %02d", abs (time->tm_mday) % 100,
743 months[abs (time->tm_mon) % 12], abs (time->tm_year) % 100);
745 return expr_allocate_string_buffer (e, temp_buf, strlen (temp_buf));
747 else if (lex_match_id ("$TRUE"))
748 return expr_allocate_boolean (e, 1.0);
749 else if (lex_match_id ("$FALSE"))
750 return expr_allocate_boolean (e, 0.0);
751 else if (lex_match_id ("$SYSMIS"))
752 return expr_allocate_number (e, SYSMIS);
753 else if (lex_match_id ("$JDATE"))
755 time_t time = time_of_last_procedure (e->ds);
756 struct tm *tm = localtime (&time);
757 return expr_allocate_number (e, expr_ymd_to_ofs (tm->tm_year + 1900,
761 else if (lex_match_id ("$TIME"))
763 time_t time = time_of_last_procedure (e->ds);
764 struct tm *tm = localtime (&time);
765 return expr_allocate_number (e,
766 expr_ymd_to_date (tm->tm_year + 1900,
769 + tm->tm_hour * 60 * 60.
773 else if (lex_match_id ("$LENGTH"))
774 return expr_allocate_number (e, get_viewlength ());
775 else if (lex_match_id ("$WIDTH"))
776 return expr_allocate_number (e, get_viewwidth ());
779 msg (SE, _("Unknown system variable %s."), tokid);
784 /* Parses numbers, varnames, etc. */
785 static union any_node *
786 parse_primary (struct expression *e)
791 if (lex_look_ahead () == '(')
793 /* An identifier followed by a left parenthesis may be
794 a vector element reference. If not, it's a function
796 if (e->ds != NULL && dict_lookup_vector (dataset_dict (e->ds), tokid) != NULL)
797 return parse_vector_element (e);
799 return parse_function (e);
801 else if (tokid[0] == '$')
803 /* $ at the beginning indicates a system variable. */
804 return parse_sysvar (e);
806 else if (e->ds != NULL && dict_lookup_var (dataset_dict (e->ds), tokid))
808 /* It looks like a user variable.
809 (It could be a format specifier, but we'll assume
810 it's a variable unless proven otherwise. */
811 return allocate_unary_variable (e, parse_variable (dataset_dict (e->ds)));
815 /* Try to parse it as a format specifier. */
820 ok = parse_format_specifier (&fmt);
824 return expr_allocate_format (e, &fmt);
826 /* All attempts failed. */
827 msg (SE, _("Unknown identifier %s."), tokid);
835 union any_node *node = expr_allocate_number (e, tokval);
842 union any_node *node = expr_allocate_string_buffer (
843 e, ds_cstr (&tokstr), ds_length (&tokstr));
850 union any_node *node;
853 if (node != NULL && !lex_match (')'))
855 lex_error (_("expecting `)'"));
862 lex_error (_("in expression"));
867 static union any_node *
868 parse_vector_element (struct expression *e)
870 const struct vector *vector;
871 union any_node *element;
873 /* Find vector, skip token.
874 The caller must already have verified that the current token
875 is the name of a vector. */
876 vector = dict_lookup_vector (dataset_dict (e->ds), tokid);
877 assert (vector != NULL);
880 /* Skip left parenthesis token.
881 The caller must have verified that the lookahead is a left
883 assert (token == '(');
886 element = parse_or (e);
887 if (!type_coercion (e, OP_number, &element, "vector indexing")
891 return expr_allocate_binary (e, (vector->var[0]->type == NUMERIC
892 ? OP_VEC_ELEM_NUM : OP_VEC_ELEM_STR),
893 element, expr_allocate_vector (e, vector));
896 /* Individual function parsing. */
898 const struct operation operations[OP_first + OP_cnt] = {
903 word_matches (const char **test, const char **name)
905 size_t test_len = strcspn (*test, ".");
906 size_t name_len = strcspn (*name, ".");
907 if (test_len == name_len)
909 if (buf_compare_case (*test, *name, test_len))
912 else if (test_len < 3 || test_len > name_len)
916 if (buf_compare_case (*test, *name, test_len))
922 if (**test != **name)
934 compare_names (const char *test, const char *name)
938 if (!word_matches (&test, &name))
940 if (*name == '\0' && *test == '\0')
946 compare_strings (const char *test, const char *name)
948 return strcasecmp (test, name);
952 lookup_function_helper (const char *name,
953 int (*compare) (const char *test, const char *name),
954 const struct operation **first,
955 const struct operation **last)
957 const struct operation *f;
959 for (f = operations + OP_function_first;
960 f <= operations + OP_function_last; f++)
961 if (!compare (name, f->name))
965 while (f <= operations + OP_function_last && !compare (name, f->name))
976 lookup_function (const char *name,
977 const struct operation **first,
978 const struct operation **last)
980 *first = *last = NULL;
981 return (lookup_function_helper (name, compare_strings, first, last)
982 || lookup_function_helper (name, compare_names, first, last));
986 extract_min_valid (char *s)
988 char *p = strrchr (s, '.');
990 || p[1] < '0' || p[1] > '9'
991 || strspn (p + 1, "0123456789") != strlen (p + 1))
998 function_arg_type (const struct operation *f, size_t arg_idx)
1000 assert (arg_idx < f->arg_cnt || (f->flags & OPF_ARRAY_OPERAND));
1002 return f->args[arg_idx < f->arg_cnt ? arg_idx : f->arg_cnt - 1];
1006 match_function (union any_node **args, int arg_cnt, const struct operation *f)
1010 if (arg_cnt < f->arg_cnt
1011 || (arg_cnt > f->arg_cnt && (f->flags & OPF_ARRAY_OPERAND) == 0)
1012 || arg_cnt - (f->arg_cnt - 1) < f->array_min_elems)
1015 for (i = 0; i < arg_cnt; i++)
1016 if (!is_coercible (function_arg_type (f, i), &args[i]))
1023 coerce_function_args (struct expression *e, const struct operation *f,
1024 union any_node **args, size_t arg_cnt)
1028 for (i = 0; i < arg_cnt; i++)
1029 type_coercion_assert (e, function_arg_type (f, i), &args[i]);
1033 validate_function_args (const struct operation *f, int arg_cnt, int min_valid)
1035 int array_arg_cnt = arg_cnt - (f->arg_cnt - 1);
1036 if (array_arg_cnt < f->array_min_elems)
1038 msg (SE, _("%s must have at least %d arguments in list."),
1039 f->prototype, f->array_min_elems);
1043 if ((f->flags & OPF_ARRAY_OPERAND)
1044 && array_arg_cnt % f->array_granularity != 0)
1046 if (f->array_granularity == 2)
1047 msg (SE, _("%s must have even number of arguments in list."),
1050 msg (SE, _("%s must have multiple of %d arguments in list."),
1051 f->prototype, f->array_granularity);
1055 if (min_valid != -1)
1057 if (f->array_min_elems == 0)
1059 assert ((f->flags & OPF_MIN_VALID) == 0);
1060 msg (SE, _("%s function does not accept a minimum valid "
1061 "argument count."), f->prototype);
1066 assert (f->flags & OPF_MIN_VALID);
1067 if (array_arg_cnt < f->array_min_elems)
1069 msg (SE, _("%s requires at least %d valid arguments in list."),
1070 f->prototype, f->array_min_elems);
1073 else if (min_valid > array_arg_cnt)
1075 msg (SE, _("With %s, "
1076 "using minimum valid argument count of %d "
1077 "does not make sense when passing only %d "
1078 "arguments in list."),
1079 f->prototype, min_valid, array_arg_cnt);
1089 add_arg (union any_node ***args, int *arg_cnt, int *arg_cap,
1090 union any_node *arg)
1092 if (*arg_cnt >= *arg_cap)
1095 *args = xrealloc (*args, sizeof **args * *arg_cap);
1098 (*args)[(*arg_cnt)++] = arg;
1102 put_invocation (struct string *s,
1103 const char *func_name, union any_node **args, size_t arg_cnt)
1107 ds_put_format (s, "%s(", func_name);
1108 for (i = 0; i < arg_cnt; i++)
1111 ds_put_cstr (s, ", ");
1112 ds_put_cstr (s, operations[expr_node_returns (args[i])].prototype);
1114 ds_put_char (s, ')');
1118 no_match (const char *func_name,
1119 union any_node **args, size_t arg_cnt,
1120 const struct operation *first, const struct operation *last)
1123 const struct operation *f;
1127 if (last - first == 1)
1129 ds_put_format (&s, _("Type mismatch invoking %s as "), first->prototype);
1130 put_invocation (&s, func_name, args, arg_cnt);
1134 ds_put_cstr (&s, _("Function invocation "));
1135 put_invocation (&s, func_name, args, arg_cnt);
1136 ds_put_cstr (&s, _(" does not match any known function. Candidates are:"));
1138 for (f = first; f < last; f++)
1139 ds_put_format (&s, "\n%s", f->prototype);
1141 ds_put_char (&s, '.');
1143 msg (SE, "%s", ds_cstr (&s));
1148 static union any_node *
1149 parse_function (struct expression *e)
1152 const struct operation *f, *first, *last;
1154 union any_node **args = NULL;
1158 struct string func_name;
1162 ds_init_string (&func_name, &tokstr);
1163 min_valid = extract_min_valid (ds_cstr (&tokstr));
1164 if (!lookup_function (ds_cstr (&tokstr), &first, &last))
1166 msg (SE, _("No function or vector named %s."), ds_cstr (&tokstr));
1167 ds_destroy (&func_name);
1172 if (!lex_force_match ('('))
1174 ds_destroy (&func_name);
1179 arg_cnt = arg_cap = 0;
1183 if (token == T_ID && lex_look_ahead () == 'T')
1185 struct variable **vars;
1189 if (!parse_variables (dataset_dict (e->ds), &vars, &var_cnt, PV_SINGLE))
1191 for (i = 0; i < var_cnt; i++)
1192 add_arg (&args, &arg_cnt, &arg_cap,
1193 allocate_unary_variable (e, vars[i]));
1198 union any_node *arg = parse_or (e);
1202 add_arg (&args, &arg_cnt, &arg_cap, arg);
1204 if (lex_match (')'))
1206 else if (!lex_match (','))
1208 lex_error (_("expecting `,' or `)' invoking %s function"),
1214 for (f = first; f < last; f++)
1215 if (match_function (args, arg_cnt, f))
1219 no_match (ds_cstr (&func_name), args, arg_cnt, first, last);
1223 coerce_function_args (e, f, args, arg_cnt);
1224 if (!validate_function_args (f, arg_cnt, min_valid))
1227 if ((f->flags & OPF_EXTENSION) && get_syntax () == COMPATIBLE)
1228 msg (SW, _("%s is a PSPP extension."), f->prototype);
1229 if (f->flags & OPF_UNIMPLEMENTED)
1231 msg (SE, _("%s is not yet implemented."), f->prototype);
1234 if ((f->flags & OPF_PERM_ONLY) &&
1235 proc_in_temporary_transformations (e->ds))
1237 msg (SE, _("%s may not appear after TEMPORARY."), f->prototype);
1241 n = expr_allocate_composite (e, f - operations, args, arg_cnt);
1242 n->composite.min_valid = min_valid != -1 ? min_valid : f->array_min_elems;
1244 if (n->type == OP_LAG_Vn || n->type == OP_LAG_Vs)
1246 if (dataset_n_lag (e->ds) < 1)
1247 dataset_set_n_lag (e->ds, 1);
1249 else if (n->type == OP_LAG_Vnn || n->type == OP_LAG_Vsn)
1252 assert (n->composite.arg_cnt == 2);
1253 assert (n->composite.args[1]->type == OP_pos_int);
1254 n_before = n->composite.args[1]->integer.i;
1255 if ( dataset_n_lag (e->ds) < n_before)
1256 dataset_set_n_lag (e->ds, n_before);
1260 ds_destroy (&func_name);
1265 ds_destroy (&func_name);
1269 /* Utility functions. */
1271 static struct expression *
1272 expr_create (struct dataset *ds)
1274 struct pool *pool = pool_create ();
1275 struct expression *e = pool_alloc (pool, sizeof *e);
1276 e->expr_pool = pool;
1278 e->eval_pool = pool_create_subpool (e->expr_pool);
1281 e->op_cnt = e->op_cap = 0;
1286 expr_node_returns (const union any_node *n)
1289 assert (is_operation (n->type));
1290 if (is_atom (n->type))
1292 else if (is_composite (n->type))
1293 return operations[n->type].returns;
1299 atom_type_name (atom_type type)
1301 assert (is_atom (type));
1302 return operations[type].name;
1306 expr_allocate_nullary (struct expression *e, operation_type op)
1308 return expr_allocate_composite (e, op, NULL, 0);
1312 expr_allocate_unary (struct expression *e, operation_type op,
1313 union any_node *arg0)
1315 return expr_allocate_composite (e, op, &arg0, 1);
1319 expr_allocate_binary (struct expression *e, operation_type op,
1320 union any_node *arg0, union any_node *arg1)
1322 union any_node *args[2];
1325 return expr_allocate_composite (e, op, args, 2);
1329 is_valid_node (union any_node *n)
1331 const struct operation *op;
1335 assert (is_operation (n->type));
1336 op = &operations[n->type];
1338 if (!is_atom (n->type))
1340 struct composite_node *c = &n->composite;
1342 assert (is_composite (n->type));
1343 assert (c->arg_cnt >= op->arg_cnt);
1344 for (i = 0; i < op->arg_cnt; i++)
1345 assert (expr_node_returns (c->args[i]) == op->args[i]);
1346 if (c->arg_cnt > op->arg_cnt && !is_operator (n->type))
1348 assert (op->flags & OPF_ARRAY_OPERAND);
1349 for (i = 0; i < c->arg_cnt; i++)
1350 assert (operations[c->args[i]->type].returns
1351 == op->args[op->arg_cnt - 1]);
1359 expr_allocate_composite (struct expression *e, operation_type op,
1360 union any_node **args, size_t arg_cnt)
1365 n = pool_alloc (e->expr_pool, sizeof n->composite);
1367 n->composite.arg_cnt = arg_cnt;
1368 n->composite.args = pool_alloc (e->expr_pool,
1369 sizeof *n->composite.args * arg_cnt);
1370 for (i = 0; i < arg_cnt; i++)
1372 if (args[i] == NULL)
1374 n->composite.args[i] = args[i];
1376 memcpy (n->composite.args, args, sizeof *n->composite.args * arg_cnt);
1377 n->composite.min_valid = 0;
1378 assert (is_valid_node (n));
1383 expr_allocate_number (struct expression *e, double d)
1385 union any_node *n = pool_alloc (e->expr_pool, sizeof n->number);
1386 n->type = OP_number;
1392 expr_allocate_boolean (struct expression *e, double b)
1394 union any_node *n = pool_alloc (e->expr_pool, sizeof n->number);
1395 assert (b == 0.0 || b == 1.0 || b == SYSMIS);
1396 n->type = OP_boolean;
1402 expr_allocate_integer (struct expression *e, int i)
1404 union any_node *n = pool_alloc (e->expr_pool, sizeof n->integer);
1405 n->type = OP_integer;
1411 expr_allocate_pos_int (struct expression *e, int i)
1413 union any_node *n = pool_alloc (e->expr_pool, sizeof n->integer);
1415 n->type = OP_pos_int;
1421 expr_allocate_vector (struct expression *e, const struct vector *vector)
1423 union any_node *n = pool_alloc (e->expr_pool, sizeof n->vector);
1424 n->type = OP_vector;
1425 n->vector.v = vector;
1430 expr_allocate_string_buffer (struct expression *e,
1431 const char *string, size_t length)
1433 union any_node *n = pool_alloc (e->expr_pool, sizeof n->string);
1434 n->type = OP_string;
1435 if (length > MAX_STRING)
1436 length = MAX_STRING;
1437 n->string.s = copy_string (e, string, length);
1442 expr_allocate_string (struct expression *e, struct substring s)
1444 union any_node *n = pool_alloc (e->expr_pool, sizeof n->string);
1445 n->type = OP_string;
1451 expr_allocate_variable (struct expression *e, struct variable *v)
1453 union any_node *n = pool_alloc (e->expr_pool, sizeof n->variable);
1454 n->type = v->type == NUMERIC ? OP_num_var : OP_str_var;
1460 expr_allocate_format (struct expression *e, const struct fmt_spec *format)
1462 union any_node *n = pool_alloc (e->expr_pool, sizeof n->format);
1463 n->type = OP_format;
1464 n->format.f = *format;
1468 /* Allocates a unary composite node that represents the value of
1469 variable V in expression E. */
1470 static union any_node *
1471 allocate_unary_variable (struct expression *e, struct variable *v)
1474 return expr_allocate_unary (e, v->type == NUMERIC ? OP_NUM_VAR : OP_STR_VAR,
1475 expr_allocate_variable (e, v));