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/lexer.h>
33 #include <language/lexer/variable-parser.h>
34 #include <libpspp/misc.h>
35 #include <libpspp/pool.h>
36 #include <data/settings.h>
37 #include <libpspp/str.h>
38 #include <data/variable.h>
42 /* Recursive descent parser in order of increasing precedence. */
43 typedef union any_node *parse_recursively_func (struct expression *);
44 static parse_recursively_func parse_or, parse_and, parse_not;
45 static parse_recursively_func parse_rel, parse_add, parse_mul;
46 static parse_recursively_func parse_neg, parse_exp;
47 static parse_recursively_func parse_primary;
48 static parse_recursively_func parse_vector_element, parse_function;
50 /* Utility functions. */
51 static struct expression *expr_create (struct dictionary *);
52 atom_type expr_node_returns (const union any_node *);
54 static const char *atom_type_name (atom_type);
55 static struct expression *finish_expression (union any_node *,
57 static bool type_check (struct expression *, union any_node **,
58 enum expr_type expected_type);
59 static union any_node *allocate_unary_variable (struct expression *,
62 /* Public functions. */
64 /* Parses an expression of the given TYPE.
65 If DICT is nonnull then variables and vectors within it may be
66 referenced within the expression; otherwise, the expression
67 must not reference any variables or vectors.
68 Returns the new expression if successful or a null pointer
71 expr_parse (struct dictionary *dict, enum expr_type type)
76 assert (type == EXPR_NUMBER || type == EXPR_STRING || type == EXPR_BOOLEAN);
78 e = expr_create (dict);
80 if (n != NULL && type_check (e, &n, type))
81 return finish_expression (expr_optimize (n, e), e);
89 /* Parses and returns an expression of the given TYPE, as
90 expr_parse(), and sets up so that destroying POOL will free
91 the expression as well. */
93 expr_parse_pool (struct pool *pool,
94 struct dictionary *dict, enum expr_type type)
96 struct expression *e = expr_parse (dict, type);
98 pool_add_subpool (pool, e->expr_pool);
102 /* Free expression E. */
104 expr_free (struct expression *e)
107 pool_destroy (e->expr_pool);
111 expr_parse_any (struct dictionary *dict, bool optimize)
114 struct expression *e;
116 e = expr_create (dict);
125 n = expr_optimize (n, e);
126 return finish_expression (n, e);
129 /* Finishing up expression building. */
131 /* Height of an expression's stacks. */
134 int number_height; /* Height of number stack. */
135 int string_height; /* Height of string stack. */
138 /* Stack heights used by different kinds of arguments. */
139 static const struct stack_heights on_number_stack = {1, 0};
140 static const struct stack_heights on_string_stack = {0, 1};
141 static const struct stack_heights not_on_stack = {0, 0};
143 /* Returns the stack heights used by an atom of the given
145 static const struct stack_heights *
146 atom_type_stack (atom_type type)
148 assert (is_atom (type));
154 return &on_number_stack;
157 return &on_string_stack;
167 return ¬_on_stack;
174 /* Measures the stack height needed for node N, supposing that
175 the stack height is initially *HEIGHT and updating *HEIGHT to
176 the final stack height. Updates *MAX, if necessary, to
177 reflect the maximum intermediate or final height. */
179 measure_stack (const union any_node *n,
180 struct stack_heights *height, struct stack_heights *max)
182 const struct stack_heights *return_height;
184 if (is_composite (n->type))
186 struct stack_heights args;
190 for (i = 0; i < n->composite.arg_cnt; i++)
191 measure_stack (n->composite.args[i], &args, max);
193 return_height = atom_type_stack (operations[n->type].returns);
196 return_height = atom_type_stack (n->type);
198 height->number_height += return_height->number_height;
199 height->string_height += return_height->string_height;
201 if (height->number_height > max->number_height)
202 max->number_height = height->number_height;
203 if (height->string_height > max->string_height)
204 max->string_height = height->string_height;
207 /* Allocates stacks within E sufficient for evaluating node N. */
209 allocate_stacks (union any_node *n, struct expression *e)
211 struct stack_heights initial = {0, 0};
212 struct stack_heights max = {0, 0};
214 measure_stack (n, &initial, &max);
215 e->number_stack = pool_alloc (e->expr_pool,
216 sizeof *e->number_stack * max.number_height);
217 e->string_stack = pool_alloc (e->expr_pool,
218 sizeof *e->string_stack * max.string_height);
221 /* Finalizes expression E for evaluating node N. */
222 static struct expression *
223 finish_expression (union any_node *n, struct expression *e)
225 /* Allocate stacks. */
226 allocate_stacks (n, e);
228 /* Output postfix representation. */
231 /* The eval_pool might have been used for allocating strings
232 during optimization. We need to keep those strings around
233 for all subsequent evaluations, so start a new eval_pool. */
234 e->eval_pool = pool_create_subpool (e->expr_pool);
239 /* Verifies that expression E, whose root node is *N, can be
240 converted to type EXPECTED_TYPE, inserting a conversion at *N
241 if necessary. Returns true if successful, false on failure. */
243 type_check (struct expression *e,
244 union any_node **n, enum expr_type expected_type)
246 atom_type actual_type = expr_node_returns (*n);
248 switch (expected_type)
252 if (actual_type != OP_number && actual_type != OP_boolean)
254 msg (SE, _("Type mismatch: expression has %s type, "
255 "but a numeric value is required here."),
256 atom_type_name (actual_type));
259 if (actual_type == OP_number && expected_type == OP_boolean)
260 *n = expr_allocate_unary (e, OP_NUM_TO_BOOLEAN, *n);
264 if (actual_type != OP_string)
266 msg (SE, _("Type mismatch: expression has %s type, "
267 "but a string value is required here."),
268 atom_type_name (actual_type));
280 /* Recursive-descent expression parser. */
282 /* Considers whether *NODE may be coerced to type REQUIRED_TYPE.
283 Returns true if possible, false if disallowed.
285 If DO_COERCION is false, then *NODE is not modified and there
288 If DO_COERCION is true, we perform the coercion if possible,
289 modifying *NODE if necessary. If the coercion is not possible
290 then we free *NODE and set *NODE to a null pointer.
292 This function's interface is somewhat awkward. Use one of the
293 wrapper functions type_coercion(), type_coercion_assert(), or
294 is_coercible() instead. */
296 type_coercion_core (struct expression *e,
297 atom_type required_type,
298 union any_node **node,
299 const char *operator_name,
302 atom_type actual_type;
304 assert (!!do_coercion == (e != NULL));
307 /* Propagate error. Whatever caused the original error
308 already emitted an error message. */
312 actual_type = expr_node_returns (*node);
313 if (actual_type == required_type)
319 switch (required_type)
322 if (actual_type == OP_boolean)
324 /* To enforce strict typing rules, insert Boolean to
325 numeric "conversion". This conversion is a no-op,
326 so it will be removed later. */
328 *node = expr_allocate_unary (e, OP_BOOLEAN_TO_NUM, *node);
334 /* No coercion to string. */
338 if (actual_type == OP_number)
340 /* Convert numeric to boolean. */
342 *node = expr_allocate_unary (e, OP_NUM_TO_BOOLEAN, *node);
351 if ((*node)->type == OP_format
352 && check_input_specifier (&(*node)->format.f, false)
353 && check_specifier_type (&(*node)->format.f, NUMERIC, false))
356 (*node)->type = OP_ni_format;
362 if ((*node)->type == OP_format
363 && check_output_specifier (&(*node)->format.f, false)
364 && check_specifier_type (&(*node)->format.f, NUMERIC, false))
367 (*node)->type = OP_no_format;
373 if ((*node)->type == OP_NUM_VAR)
376 *node = (*node)->composite.args[0];
382 if ((*node)->type == OP_STR_VAR)
385 *node = (*node)->composite.args[0];
391 if ((*node)->type == OP_number
392 && floor ((*node)->number.n) == (*node)->number.n
393 && (*node)->number.n > 0 && (*node)->number.n < INT_MAX)
396 *node = expr_allocate_pos_int (e, (*node)->number.n);
407 msg (SE, _("Type mismatch while applying %s operator: "
408 "cannot convert %s to %s."),
410 atom_type_name (actual_type), atom_type_name (required_type));
416 /* Coerces *NODE to type REQUIRED_TYPE, and returns success. If
417 *NODE cannot be coerced to the desired type then we issue an
418 error message about operator OPERATOR_NAME and free *NODE. */
420 type_coercion (struct expression *e,
421 atom_type required_type, union any_node **node,
422 const char *operator_name)
424 return type_coercion_core (e, required_type, node, operator_name, true);
427 /* Coerces *NODE to type REQUIRED_TYPE.
428 Assert-fails if the coercion is disallowed. */
430 type_coercion_assert (struct expression *e,
431 atom_type required_type, union any_node **node)
433 int success = type_coercion_core (e, required_type, node, NULL, true);
437 /* Returns true if *NODE may be coerced to type REQUIRED_TYPE,
440 is_coercible (atom_type required_type, union any_node *const *node)
442 return type_coercion_core (NULL, required_type,
443 (union any_node **) node, NULL, false);
446 /* How to parse an operator. */
449 int token; /* Token representing operator. */
450 operation_type type; /* Operation type representing operation. */
451 const char *name; /* Name of operator. */
454 /* Attempts to match the current token against the tokens for the
455 OP_CNT operators in OPS[]. If successful, returns true
456 and, if OPERATOR is non-null, sets *OPERATOR to the operator.
457 On failure, returns false and, if OPERATOR is non-null, sets
458 *OPERATOR to a null pointer. */
460 match_operator (const struct operator ops[], size_t op_cnt,
461 const struct operator **operator)
463 const struct operator *op;
465 for (op = ops; op < ops + op_cnt; op++)
467 if (op->token == '-')
468 lex_negative_to_dash ();
469 if (lex_match (op->token))
471 if (operator != NULL)
476 if (operator != NULL)
482 check_operator (const struct operator *op, int arg_cnt, atom_type arg_type)
484 const struct operation *o;
488 o = &operations[op->type];
489 assert (o->arg_cnt == arg_cnt);
490 assert ((o->flags & OPF_ARRAY_OPERAND) == 0);
491 for (i = 0; i < arg_cnt; i++)
492 assert (o->args[i] == arg_type);
497 check_binary_operators (const struct operator ops[], size_t op_cnt,
502 for (i = 0; i < op_cnt; i++)
503 check_operator (&ops[i], 2, arg_type);
508 get_operand_type (const struct operator *op)
510 return operations[op->type].args[0];
513 /* Parses a chain of left-associative operator/operand pairs.
514 There are OP_CNT operators, specified in OPS[]. The
515 operators' operands must all be the same type. The next
516 higher level is parsed by PARSE_NEXT_LEVEL. If CHAIN_WARNING
517 is non-null, then it will be issued as a warning if more than
518 one operator/operand pair is parsed. */
519 static union any_node *
520 parse_binary_operators (struct expression *e, union any_node *node,
521 const struct operator ops[], size_t op_cnt,
522 parse_recursively_func *parse_next_level,
523 const char *chain_warning)
525 atom_type operand_type = get_operand_type (&ops[0]);
527 const struct operator *operator;
529 assert (check_binary_operators (ops, op_cnt, operand_type));
533 for (op_count = 0; match_operator (ops, op_cnt, &operator); op_count++)
537 /* Convert the left-hand side to type OPERAND_TYPE. */
538 if (!type_coercion (e, operand_type, &node, operator->name))
541 /* Parse the right-hand side and coerce to type
543 rhs = parse_next_level (e);
544 if (!type_coercion (e, operand_type, &rhs, operator->name))
546 node = expr_allocate_binary (e, operator->type, node, rhs);
549 if (op_count > 1 && chain_warning != NULL)
550 msg (SW, chain_warning);
555 static union any_node *
556 parse_inverting_unary_operator (struct expression *e,
557 const struct operator *op,
558 parse_recursively_func *parse_next_level)
560 union any_node *node;
563 check_operator (op, 1, get_operand_type (op));
566 while (match_operator (op, 1, NULL))
569 node = parse_next_level (e);
571 && type_coercion (e, get_operand_type (op), &node, op->name)
572 && op_count % 2 != 0)
573 return expr_allocate_unary (e, op->type, node);
578 /* Parses the OR level. */
579 static union any_node *
580 parse_or (struct expression *e)
582 static const struct operator op =
583 { T_OR, OP_OR, "logical disjunction (\"OR\")" };
585 return parse_binary_operators (e, parse_and (e), &op, 1, parse_and, NULL);
588 /* Parses the AND level. */
589 static union any_node *
590 parse_and (struct expression *e)
592 static const struct operator op =
593 { T_AND, OP_AND, "logical conjunction (\"AND\")" };
595 return parse_binary_operators (e, parse_not (e), &op, 1, parse_not, NULL);
598 /* Parses the NOT level. */
599 static union any_node *
600 parse_not (struct expression *e)
602 static const struct operator op
603 = { T_NOT, OP_NOT, "logical negation (\"NOT\")" };
604 return parse_inverting_unary_operator (e, &op, parse_rel);
607 /* Parse relational operators. */
608 static union any_node *
609 parse_rel (struct expression *e)
611 const char *chain_warning =
612 _("Chaining relational operators (e.g. \"a < b < c\") will "
613 "not produce the mathematically expected result. "
614 "Use the AND logical operator to fix the problem "
615 "(e.g. \"a < b AND b < c\"). "
616 "If chaining is really intended, parentheses will disable "
617 "this warning (e.g. \"(a < b) < c\".)");
619 union any_node *node = parse_add (e);
624 switch (expr_node_returns (node))
629 static const struct operator ops[] =
631 { '=', OP_EQ, "numeric equality (\"=\")" },
632 { T_EQ, OP_EQ, "numeric equality (\"EQ\")" },
633 { T_GE, OP_GE, "numeric greater-than-or-equal-to (\">=\")" },
634 { T_GT, OP_GT, "numeric greater than (\">\")" },
635 { T_LE, OP_LE, "numeric less-than-or-equal-to (\"<=\")" },
636 { T_LT, OP_LT, "numeric less than (\"<\")" },
637 { T_NE, OP_NE, "numeric inequality (\"<>\")" },
640 return parse_binary_operators (e, node, ops, sizeof ops / sizeof *ops,
641 parse_add, chain_warning);
646 static const struct operator ops[] =
648 { '=', OP_EQ_STRING, "string equality (\"=\")" },
649 { T_EQ, OP_EQ_STRING, "string equality (\"EQ\")" },
650 { T_GE, OP_GE_STRING, "string greater-than-or-equal-to (\">=\")" },
651 { T_GT, OP_GT_STRING, "string greater than (\">\")" },
652 { T_LE, OP_LE_STRING, "string less-than-or-equal-to (\"<=\")" },
653 { T_LT, OP_LT_STRING, "string less than (\"<\")" },
654 { T_NE, OP_NE_STRING, "string inequality (\"<>\")" },
657 return parse_binary_operators (e, node, ops, sizeof ops / sizeof *ops,
658 parse_add, chain_warning);
666 /* Parses the addition and subtraction level. */
667 static union any_node *
668 parse_add (struct expression *e)
670 static const struct operator ops[] =
672 { '+', OP_ADD, "addition (\"+\")" },
673 { '-', OP_SUB, "subtraction (\"-\")" },
676 return parse_binary_operators (e, parse_mul (e),
677 ops, sizeof ops / sizeof *ops,
681 /* Parses the multiplication and division level. */
682 static union any_node *
683 parse_mul (struct expression *e)
685 static const struct operator ops[] =
687 { '*', OP_MUL, "multiplication (\"*\")" },
688 { '/', OP_DIV, "division (\"/\")" },
691 return parse_binary_operators (e, parse_neg (e),
692 ops, sizeof ops / sizeof *ops,
696 /* Parses the unary minus level. */
697 static union any_node *
698 parse_neg (struct expression *e)
700 static const struct operator op = { '-', OP_NEG, "negation (\"-\")" };
701 return parse_inverting_unary_operator (e, &op, parse_exp);
704 static union any_node *
705 parse_exp (struct expression *e)
707 static const struct operator op =
708 { T_EXP, OP_POW, "exponentiation (\"**\")" };
710 const char *chain_warning =
711 _("The exponentiation operator (\"**\") is left-associative, "
712 "even though right-associative semantics are more useful. "
713 "That is, \"a**b**c\" equals \"(a**b)**c\", not as \"a**(b**c)\". "
714 "To disable this warning, insert parentheses.");
716 return parse_binary_operators (e, parse_primary (e), &op, 1,
717 parse_primary, chain_warning);
720 /* Parses system variables. */
721 static union any_node *
722 parse_sysvar (struct expression *e)
724 if (lex_match_id ("$CASENUM"))
725 return expr_allocate_nullary (e, OP_CASENUM);
726 else if (lex_match_id ("$DATE"))
728 static const char *months[12] =
730 "JAN", "FEB", "MAR", "APR", "MAY", "JUN",
731 "JUL", "AUG", "SEP", "OCT", "NOV", "DEC",
734 time_t last_proc_time = time_of_last_procedure ();
738 time = localtime (&last_proc_time);
739 sprintf (temp_buf, "%02d %s %02d", abs (time->tm_mday) % 100,
740 months[abs (time->tm_mon) % 12], abs (time->tm_year) % 100);
742 return expr_allocate_string_buffer (e, temp_buf, strlen (temp_buf));
744 else if (lex_match_id ("$TRUE"))
745 return expr_allocate_boolean (e, 1.0);
746 else if (lex_match_id ("$FALSE"))
747 return expr_allocate_boolean (e, 0.0);
748 else if (lex_match_id ("$SYSMIS"))
749 return expr_allocate_number (e, SYSMIS);
750 else if (lex_match_id ("$JDATE"))
752 time_t time = time_of_last_procedure ();
753 struct tm *tm = localtime (&time);
754 return expr_allocate_number (e, expr_ymd_to_ofs (tm->tm_year + 1900,
758 else if (lex_match_id ("$TIME"))
760 time_t time = time_of_last_procedure ();
761 struct tm *tm = localtime (&time);
762 return expr_allocate_number (e,
763 expr_ymd_to_date (tm->tm_year + 1900,
766 + tm->tm_hour * 60 * 60.
770 else if (lex_match_id ("$LENGTH"))
771 return expr_allocate_number (e, get_viewlength ());
772 else if (lex_match_id ("$WIDTH"))
773 return expr_allocate_number (e, get_viewwidth ());
776 msg (SE, _("Unknown system variable %s."), tokid);
781 /* Parses numbers, varnames, etc. */
782 static union any_node *
783 parse_primary (struct expression *e)
788 if (lex_look_ahead () == '(')
790 /* An identifier followed by a left parenthesis may be
791 a vector element reference. If not, it's a function
793 if (e->dict != NULL && dict_lookup_vector (e->dict, tokid) != NULL)
794 return parse_vector_element (e);
796 return parse_function (e);
798 else if (tokid[0] == '$')
800 /* $ at the beginning indicates a system variable. */
801 return parse_sysvar (e);
803 else if (e->dict != NULL && dict_lookup_var (e->dict, tokid))
805 /* It looks like a user variable.
806 (It could be a format specifier, but we'll assume
807 it's a variable unless proven otherwise. */
808 return allocate_unary_variable (e, parse_dict_variable (e->dict));
812 /* Try to parse it as a format specifier. */
814 if (parse_format_specifier (&fmt, FMTP_SUPPRESS_ERRORS))
815 return expr_allocate_format (e, &fmt);
817 /* All attempts failed. */
818 msg (SE, _("Unknown identifier %s."), tokid);
826 union any_node *node = expr_allocate_number (e, tokval);
833 union any_node *node = expr_allocate_string_buffer (
834 e, ds_cstr (&tokstr), ds_length (&tokstr));
841 union any_node *node;
844 if (node != NULL && !lex_match (')'))
846 lex_error (_("expecting `)'"));
853 lex_error (_("in expression"));
858 static union any_node *
859 parse_vector_element (struct expression *e)
861 const struct vector *vector;
862 union any_node *element;
864 /* Find vector, skip token.
865 The caller must already have verified that the current token
866 is the name of a vector. */
867 vector = dict_lookup_vector (default_dict, tokid);
868 assert (vector != NULL);
871 /* Skip left parenthesis token.
872 The caller must have verified that the lookahead is a left
874 assert (token == '(');
877 element = parse_or (e);
878 if (!type_coercion (e, OP_number, &element, "vector indexing")
882 return expr_allocate_binary (e, (vector->var[0]->type == NUMERIC
883 ? OP_VEC_ELEM_NUM : OP_VEC_ELEM_STR),
884 element, expr_allocate_vector (e, vector));
887 /* Individual function parsing. */
889 struct operation operations[OP_first + OP_cnt] = {
894 word_matches (const char **test, const char **name)
896 size_t test_len = strcspn (*test, ".");
897 size_t name_len = strcspn (*name, ".");
898 if (test_len == name_len)
900 if (buf_compare_case (*test, *name, test_len))
903 else if (test_len < 3 || test_len > name_len)
907 if (buf_compare_case (*test, *name, test_len))
913 if (**test != **name)
925 compare_names (const char *test, const char *name)
929 if (!word_matches (&test, &name))
931 if (*name == '\0' && *test == '\0')
937 compare_strings (const char *test, const char *name)
939 return strcasecmp (test, name);
943 lookup_function_helper (const char *name,
944 int (*compare) (const char *test, const char *name),
945 const struct operation **first,
946 const struct operation **last)
950 for (f = operations + OP_function_first;
951 f <= operations + OP_function_last; f++)
952 if (!compare (name, f->name))
956 while (f <= operations + OP_function_last && !compare (name, f->name))
967 lookup_function (const char *name,
968 const struct operation **first,
969 const struct operation **last)
971 *first = *last = NULL;
972 return (lookup_function_helper (name, compare_strings, first, last)
973 || lookup_function_helper (name, compare_names, first, last));
977 extract_min_valid (char *s)
979 char *p = strrchr (s, '.');
981 || p[1] < '0' || p[1] > '9'
982 || strspn (p + 1, "0123456789") != strlen (p + 1))
989 function_arg_type (const struct operation *f, size_t arg_idx)
991 assert (arg_idx < f->arg_cnt || (f->flags & OPF_ARRAY_OPERAND));
993 return f->args[arg_idx < f->arg_cnt ? arg_idx : f->arg_cnt - 1];
997 match_function (union any_node **args, int arg_cnt, const struct operation *f)
1001 if (arg_cnt < f->arg_cnt
1002 || (arg_cnt > f->arg_cnt && (f->flags & OPF_ARRAY_OPERAND) == 0)
1003 || arg_cnt - (f->arg_cnt - 1) < f->array_min_elems)
1006 for (i = 0; i < arg_cnt; i++)
1007 if (!is_coercible (function_arg_type (f, i), &args[i]))
1014 coerce_function_args (struct expression *e, const struct operation *f,
1015 union any_node **args, size_t arg_cnt)
1019 for (i = 0; i < arg_cnt; i++)
1020 type_coercion_assert (e, function_arg_type (f, i), &args[i]);
1024 validate_function_args (const struct operation *f, int arg_cnt, int min_valid)
1026 int array_arg_cnt = arg_cnt - (f->arg_cnt - 1);
1027 if (array_arg_cnt < f->array_min_elems)
1029 msg (SE, _("%s must have at least %d arguments in list."),
1030 f->prototype, f->array_min_elems);
1034 if ((f->flags & OPF_ARRAY_OPERAND)
1035 && array_arg_cnt % f->array_granularity != 0)
1037 if (f->array_granularity == 2)
1038 msg (SE, _("%s must have even number of arguments in list."),
1041 msg (SE, _("%s must have multiple of %d arguments in list."),
1042 f->prototype, f->array_granularity);
1046 if (min_valid != -1)
1048 if (f->array_min_elems == 0)
1050 assert ((f->flags & OPF_MIN_VALID) == 0);
1051 msg (SE, _("%s function does not accept a minimum valid "
1052 "argument count."), f->prototype);
1057 assert (f->flags & OPF_MIN_VALID);
1058 if (array_arg_cnt < f->array_min_elems)
1060 msg (SE, _("%s requires at least %d valid arguments in list."),
1061 f->prototype, f->array_min_elems);
1064 else if (min_valid > array_arg_cnt)
1066 msg (SE, _("With %s, "
1067 "using minimum valid argument count of %d "
1068 "does not make sense when passing only %d "
1069 "arguments in list."),
1070 f->prototype, min_valid, array_arg_cnt);
1080 add_arg (union any_node ***args, int *arg_cnt, int *arg_cap,
1081 union any_node *arg)
1083 if (*arg_cnt >= *arg_cap)
1086 *args = xrealloc (*args, sizeof **args * *arg_cap);
1089 (*args)[(*arg_cnt)++] = arg;
1093 put_invocation (struct string *s,
1094 const char *func_name, union any_node **args, size_t arg_cnt)
1098 ds_put_format (s, "%s(", func_name);
1099 for (i = 0; i < arg_cnt; i++)
1102 ds_put_cstr (s, ", ");
1103 ds_put_cstr (s, operations[expr_node_returns (args[i])].prototype);
1105 ds_put_char (s, ')');
1109 no_match (const char *func_name,
1110 union any_node **args, size_t arg_cnt,
1111 const struct operation *first, const struct operation *last)
1114 const struct operation *f;
1118 if (last - first == 1)
1120 ds_put_format (&s, _("Type mismatch invoking %s as "), first->prototype);
1121 put_invocation (&s, func_name, args, arg_cnt);
1125 ds_put_cstr (&s, _("Function invocation "));
1126 put_invocation (&s, func_name, args, arg_cnt);
1127 ds_put_cstr (&s, _(" does not match any known function. Candidates are:"));
1129 for (f = first; f < last; f++)
1130 ds_put_format (&s, "\n%s", f->prototype);
1132 ds_put_char (&s, '.');
1134 msg (SE, "%s", ds_cstr (&s));
1139 static union any_node *
1140 parse_function (struct expression *e)
1143 const struct operation *f, *first, *last;
1145 union any_node **args = NULL;
1149 struct string func_name;
1153 ds_init_string (&func_name, &tokstr);
1154 min_valid = extract_min_valid (ds_cstr (&tokstr));
1155 if (!lookup_function (ds_cstr (&tokstr), &first, &last))
1157 msg (SE, _("No function or vector named %s."), ds_cstr (&tokstr));
1158 ds_destroy (&func_name);
1163 if (!lex_force_match ('('))
1165 ds_destroy (&func_name);
1170 arg_cnt = arg_cap = 0;
1174 if (token == T_ID && lex_look_ahead () == 'T')
1176 struct variable **vars;
1180 if (!parse_variables (default_dict, &vars, &var_cnt, PV_SINGLE))
1182 for (i = 0; i < var_cnt; i++)
1183 add_arg (&args, &arg_cnt, &arg_cap,
1184 allocate_unary_variable (e, vars[i]));
1189 union any_node *arg = parse_or (e);
1193 add_arg (&args, &arg_cnt, &arg_cap, arg);
1195 if (lex_match (')'))
1197 else if (!lex_match (','))
1199 lex_error (_("expecting `,' or `)' invoking %s function"),
1205 for (f = first; f < last; f++)
1206 if (match_function (args, arg_cnt, f))
1210 no_match (ds_cstr (&func_name), args, arg_cnt, first, last);
1214 coerce_function_args (e, f, args, arg_cnt);
1215 if (!validate_function_args (f, arg_cnt, min_valid))
1218 if ((f->flags & OPF_EXTENSION) && get_syntax () == COMPATIBLE)
1219 msg (SW, _("%s is a PSPP extension."), f->prototype);
1220 if (f->flags & OPF_UNIMPLEMENTED)
1222 msg (SE, _("%s is not yet implemented."), f->prototype);
1225 if ((f->flags & OPF_PERM_ONLY) && proc_in_temporary_transformations ())
1227 msg (SE, _("%s may not appear after TEMPORARY."), f->prototype);
1231 n = expr_allocate_composite (e, f - operations, args, arg_cnt);
1232 n->composite.min_valid = min_valid != -1 ? min_valid : f->array_min_elems;
1234 if (n->type == OP_LAG_Vn || n->type == OP_LAG_Vs)
1239 else if (n->type == OP_LAG_Vnn || n->type == OP_LAG_Vsn)
1242 assert (n->composite.arg_cnt == 2);
1243 assert (n->composite.args[1]->type == OP_pos_int);
1244 n_before = n->composite.args[1]->integer.i;
1245 if (n_lag < n_before)
1250 ds_destroy (&func_name);
1255 ds_destroy (&func_name);
1259 /* Utility functions. */
1261 static struct expression *
1262 expr_create (struct dictionary *dict)
1264 struct pool *pool = pool_create ();
1265 struct expression *e = pool_alloc (pool, sizeof *e);
1266 e->expr_pool = pool;
1268 e->eval_pool = pool_create_subpool (e->expr_pool);
1271 e->op_cnt = e->op_cap = 0;
1276 expr_node_returns (const union any_node *n)
1279 assert (is_operation (n->type));
1280 if (is_atom (n->type))
1282 else if (is_composite (n->type))
1283 return operations[n->type].returns;
1289 atom_type_name (atom_type type)
1291 assert (is_atom (type));
1292 return operations[type].name;
1296 expr_allocate_nullary (struct expression *e, operation_type op)
1298 return expr_allocate_composite (e, op, NULL, 0);
1302 expr_allocate_unary (struct expression *e, operation_type op,
1303 union any_node *arg0)
1305 return expr_allocate_composite (e, op, &arg0, 1);
1309 expr_allocate_binary (struct expression *e, operation_type op,
1310 union any_node *arg0, union any_node *arg1)
1312 union any_node *args[2];
1315 return expr_allocate_composite (e, op, args, 2);
1319 is_valid_node (union any_node *n)
1321 struct operation *op;
1325 assert (is_operation (n->type));
1326 op = &operations[n->type];
1328 if (!is_atom (n->type))
1330 struct composite_node *c = &n->composite;
1332 assert (is_composite (n->type));
1333 assert (c->arg_cnt >= op->arg_cnt);
1334 for (i = 0; i < op->arg_cnt; i++)
1335 assert (expr_node_returns (c->args[i]) == op->args[i]);
1336 if (c->arg_cnt > op->arg_cnt && !is_operator (n->type))
1338 assert (op->flags & OPF_ARRAY_OPERAND);
1339 for (i = 0; i < c->arg_cnt; i++)
1340 assert (operations[c->args[i]->type].returns
1341 == op->args[op->arg_cnt - 1]);
1349 expr_allocate_composite (struct expression *e, operation_type op,
1350 union any_node **args, size_t arg_cnt)
1355 n = pool_alloc (e->expr_pool, sizeof n->composite);
1357 n->composite.arg_cnt = arg_cnt;
1358 n->composite.args = pool_alloc (e->expr_pool,
1359 sizeof *n->composite.args * arg_cnt);
1360 for (i = 0; i < arg_cnt; i++)
1362 if (args[i] == NULL)
1364 n->composite.args[i] = args[i];
1366 memcpy (n->composite.args, args, sizeof *n->composite.args * arg_cnt);
1367 n->composite.min_valid = 0;
1368 assert (is_valid_node (n));
1373 expr_allocate_number (struct expression *e, double d)
1375 union any_node *n = pool_alloc (e->expr_pool, sizeof n->number);
1376 n->type = OP_number;
1382 expr_allocate_boolean (struct expression *e, double b)
1384 union any_node *n = pool_alloc (e->expr_pool, sizeof n->number);
1385 assert (b == 0.0 || b == 1.0 || b == SYSMIS);
1386 n->type = OP_boolean;
1392 expr_allocate_integer (struct expression *e, int i)
1394 union any_node *n = pool_alloc (e->expr_pool, sizeof n->integer);
1395 n->type = OP_integer;
1401 expr_allocate_pos_int (struct expression *e, int i)
1403 union any_node *n = pool_alloc (e->expr_pool, sizeof n->integer);
1405 n->type = OP_pos_int;
1411 expr_allocate_vector (struct expression *e, const struct vector *vector)
1413 union any_node *n = pool_alloc (e->expr_pool, sizeof n->vector);
1414 n->type = OP_vector;
1415 n->vector.v = vector;
1420 expr_allocate_string_buffer (struct expression *e,
1421 const char *string, size_t length)
1423 union any_node *n = pool_alloc (e->expr_pool, sizeof n->string);
1424 n->type = OP_string;
1425 if (length > MAX_STRING)
1426 length = MAX_STRING;
1427 n->string.s = copy_string (e, string, length);
1432 expr_allocate_string (struct expression *e, struct substring s)
1434 union any_node *n = pool_alloc (e->expr_pool, sizeof n->string);
1435 n->type = OP_string;
1441 expr_allocate_variable (struct expression *e, struct variable *v)
1443 union any_node *n = pool_alloc (e->expr_pool, sizeof n->variable);
1444 n->type = v->type == NUMERIC ? OP_num_var : OP_str_var;
1450 expr_allocate_format (struct expression *e, const struct fmt_spec *format)
1452 union any_node *n = pool_alloc (e->expr_pool, sizeof n->format);
1453 n->type = OP_format;
1454 n->format.f = *format;
1458 /* Allocates a unary composite node that represents the value of
1459 variable V in expression E. */
1460 static union any_node *
1461 allocate_unary_variable (struct expression *e, struct variable *v)
1464 return expr_allocate_unary (e, v->type == NUMERIC ? OP_NUM_VAR : OP_STR_VAR,
1465 expr_allocate_variable (e, v));