1 /* PSPP - a program for statistical analysis.
2 Copyright (C) 1997-9, 2000, 2006 Free Software Foundation, Inc.
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.
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.
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/>. */
27 #include <data/case.h>
28 #include <data/dictionary.h>
29 #include <data/settings.h>
30 #include <data/variable.h>
31 #include <language/lexer/format-parser.h>
32 #include <language/lexer/lexer.h>
33 #include <language/lexer/variable-parser.h>
34 #include <libpspp/alloc.h>
35 #include <libpspp/array.h>
36 #include <libpspp/assertion.h>
37 #include <libpspp/message.h>
38 #include <libpspp/misc.h>
39 #include <libpspp/pool.h>
40 #include <libpspp/str.h>
44 /* Recursive descent parser in order of increasing precedence. */
45 typedef union any_node *parse_recursively_func (struct lexer *, 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 *,
62 const struct variable *);
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 lexer *lexer, struct dataset *ds, enum expr_type type)
78 assert (type == EXPR_NUMBER || type == EXPR_STRING || type == EXPR_BOOLEAN);
81 n = parse_or (lexer, e);
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 lexer *lexer,
100 struct expression *e = expr_parse (lexer, ds, type);
102 pool_add_subpool (pool, e->expr_pool);
106 /* Free expression E. */
108 expr_free (struct expression *e)
111 pool_destroy (e->expr_pool);
115 expr_parse_any (struct lexer *lexer, struct dataset *ds, bool optimize)
118 struct expression *e;
120 e = expr_create (ds);
121 n = parse_or (lexer, e);
129 n = expr_optimize (n, e);
130 return finish_expression (n, e);
133 /* Finishing up expression building. */
135 /* Height of an expression's stacks. */
138 int number_height; /* Height of number stack. */
139 int string_height; /* Height of string stack. */
142 /* Stack heights used by different kinds of arguments. */
143 static const struct stack_heights on_number_stack = {1, 0};
144 static const struct stack_heights on_string_stack = {0, 1};
145 static const struct stack_heights not_on_stack = {0, 0};
147 /* Returns the stack heights used by an atom of the given
149 static const struct stack_heights *
150 atom_type_stack (atom_type type)
152 assert (is_atom (type));
158 return &on_number_stack;
161 return &on_string_stack;
171 return ¬_on_stack;
178 /* Measures the stack height needed for node N, supposing that
179 the stack height is initially *HEIGHT and updating *HEIGHT to
180 the final stack height. Updates *MAX, if necessary, to
181 reflect the maximum intermediate or final height. */
183 measure_stack (const union any_node *n,
184 struct stack_heights *height, struct stack_heights *max)
186 const struct stack_heights *return_height;
188 if (is_composite (n->type))
190 struct stack_heights args;
194 for (i = 0; i < n->composite.arg_cnt; i++)
195 measure_stack (n->composite.args[i], &args, max);
197 return_height = atom_type_stack (operations[n->type].returns);
200 return_height = atom_type_stack (n->type);
202 height->number_height += return_height->number_height;
203 height->string_height += return_height->string_height;
205 if (height->number_height > max->number_height)
206 max->number_height = height->number_height;
207 if (height->string_height > max->string_height)
208 max->string_height = height->string_height;
211 /* Allocates stacks within E sufficient for evaluating node N. */
213 allocate_stacks (union any_node *n, struct expression *e)
215 struct stack_heights initial = {0, 0};
216 struct stack_heights max = {0, 0};
218 measure_stack (n, &initial, &max);
219 e->number_stack = pool_alloc (e->expr_pool,
220 sizeof *e->number_stack * max.number_height);
221 e->string_stack = pool_alloc (e->expr_pool,
222 sizeof *e->string_stack * max.string_height);
225 /* Finalizes expression E for evaluating node N. */
226 static struct expression *
227 finish_expression (union any_node *n, struct expression *e)
229 /* Allocate stacks. */
230 allocate_stacks (n, e);
232 /* Output postfix representation. */
235 /* The eval_pool might have been used for allocating strings
236 during optimization. We need to keep those strings around
237 for all subsequent evaluations, so start a new eval_pool. */
238 e->eval_pool = pool_create_subpool (e->expr_pool);
243 /* Verifies that expression E, whose root node is *N, can be
244 converted to type EXPECTED_TYPE, inserting a conversion at *N
245 if necessary. Returns true if successful, false on failure. */
247 type_check (struct expression *e,
248 union any_node **n, enum expr_type expected_type)
250 atom_type actual_type = expr_node_returns (*n);
252 switch (expected_type)
256 if (actual_type != OP_number && actual_type != OP_boolean)
258 msg (SE, _("Type mismatch: expression has %s type, "
259 "but a numeric value is required here."),
260 atom_type_name (actual_type));
263 if (actual_type == OP_number && expected_type == OP_boolean)
264 *n = expr_allocate_unary (e, OP_NUM_TO_BOOLEAN, *n);
268 if (actual_type != OP_string)
270 msg (SE, _("Type mismatch: expression has %s type, "
271 "but a string value is required here."),
272 atom_type_name (actual_type));
284 /* Recursive-descent expression parser. */
286 /* Considers whether *NODE may be coerced to type REQUIRED_TYPE.
287 Returns true if possible, false if disallowed.
289 If DO_COERCION is false, then *NODE is not modified and there
292 If DO_COERCION is true, we perform the coercion if possible,
293 modifying *NODE if necessary. If the coercion is not possible
294 then we free *NODE and set *NODE to a null pointer.
296 This function's interface is somewhat awkward. Use one of the
297 wrapper functions type_coercion(), type_coercion_assert(), or
298 is_coercible() instead. */
300 type_coercion_core (struct expression *e,
301 atom_type required_type,
302 union any_node **node,
303 const char *operator_name,
306 atom_type actual_type;
308 assert (!!do_coercion == (e != NULL));
311 /* Propagate error. Whatever caused the original error
312 already emitted an error message. */
316 actual_type = expr_node_returns (*node);
317 if (actual_type == required_type)
323 switch (required_type)
326 if (actual_type == OP_boolean)
328 /* To enforce strict typing rules, insert Boolean to
329 numeric "conversion". This conversion is a no-op,
330 so it will be removed later. */
332 *node = expr_allocate_unary (e, OP_BOOLEAN_TO_NUM, *node);
338 /* No coercion to string. */
342 if (actual_type == OP_number)
344 /* Convert numeric to boolean. */
346 *node = expr_allocate_unary (e, OP_NUM_TO_BOOLEAN, *node);
356 if ((*node)->type == OP_format
357 && fmt_check_input (&(*node)->format.f)
358 && fmt_check_type_compat (&(*node)->format.f, VAR_NUMERIC))
362 (*node)->type = OP_ni_format;
370 if ((*node)->type == OP_format
371 && fmt_check_output (&(*node)->format.f)
372 && fmt_check_type_compat (&(*node)->format.f, VAR_NUMERIC))
376 (*node)->type = OP_no_format;
383 if ((*node)->type == OP_NUM_VAR)
386 *node = (*node)->composite.args[0];
392 if ((*node)->type == OP_STR_VAR)
395 *node = (*node)->composite.args[0];
401 if ((*node)->type == OP_NUM_VAR || (*node)->type == OP_STR_VAR)
404 *node = (*node)->composite.args[0];
410 if ((*node)->type == OP_number
411 && floor ((*node)->number.n) == (*node)->number.n
412 && (*node)->number.n > 0 && (*node)->number.n < INT_MAX)
415 *node = expr_allocate_pos_int (e, (*node)->number.n);
426 msg (SE, _("Type mismatch while applying %s operator: "
427 "cannot convert %s to %s."),
429 atom_type_name (actual_type), atom_type_name (required_type));
435 /* Coerces *NODE to type REQUIRED_TYPE, and returns success. If
436 *NODE cannot be coerced to the desired type then we issue an
437 error message about operator OPERATOR_NAME and free *NODE. */
439 type_coercion (struct expression *e,
440 atom_type required_type, union any_node **node,
441 const char *operator_name)
443 return type_coercion_core (e, required_type, node, operator_name, true);
446 /* Coerces *NODE to type REQUIRED_TYPE.
447 Assert-fails if the coercion is disallowed. */
449 type_coercion_assert (struct expression *e,
450 atom_type required_type, union any_node **node)
452 int success = type_coercion_core (e, required_type, node, NULL, true);
456 /* Returns true if *NODE may be coerced to type REQUIRED_TYPE,
459 is_coercible (atom_type required_type, union any_node *const *node)
461 return type_coercion_core (NULL, required_type,
462 (union any_node **) node, NULL, false);
465 /* Returns true if ACTUAL_TYPE is a kind of REQUIRED_TYPE, false
468 is_compatible (atom_type required_type, atom_type actual_type)
470 return (required_type == actual_type
471 || (required_type == OP_var
472 && (actual_type == OP_num_var || actual_type == OP_str_var)));
475 /* How to parse an operator. */
478 int token; /* Token representing operator. */
479 operation_type type; /* Operation type representing operation. */
480 const char *name; /* Name of operator. */
483 /* Attempts to match the current token against the tokens for the
484 OP_CNT operators in OPS[]. If successful, returns true
485 and, if OPERATOR is non-null, sets *OPERATOR to the operator.
486 On failure, returns false and, if OPERATOR is non-null, sets
487 *OPERATOR to a null pointer. */
489 match_operator (struct lexer *lexer, const struct operator ops[], size_t op_cnt,
490 const struct operator **operator)
492 const struct operator *op;
494 for (op = ops; op < ops + op_cnt; op++)
496 if (op->token == '-')
497 lex_negative_to_dash (lexer);
498 if (lex_match (lexer, op->token))
500 if (operator != NULL)
505 if (operator != NULL)
511 check_operator (const struct operator *op, int arg_cnt, atom_type arg_type)
513 const struct operation *o;
517 o = &operations[op->type];
518 assert (o->arg_cnt == arg_cnt);
519 assert ((o->flags & OPF_ARRAY_OPERAND) == 0);
520 for (i = 0; i < arg_cnt; i++)
521 assert (is_compatible (arg_type, o->args[i]));
526 check_binary_operators (const struct operator ops[], size_t op_cnt,
531 for (i = 0; i < op_cnt; i++)
532 check_operator (&ops[i], 2, arg_type);
537 get_operand_type (const struct operator *op)
539 return operations[op->type].args[0];
542 /* Parses a chain of left-associative operator/operand pairs.
543 There are OP_CNT operators, specified in OPS[]. The
544 operators' operands must all be the same type. The next
545 higher level is parsed by PARSE_NEXT_LEVEL. If CHAIN_WARNING
546 is non-null, then it will be issued as a warning if more than
547 one operator/operand pair is parsed. */
548 static union any_node *
549 parse_binary_operators (struct lexer *lexer, struct expression *e, union any_node *node,
550 const struct operator ops[], size_t op_cnt,
551 parse_recursively_func *parse_next_level,
552 const char *chain_warning)
554 atom_type operand_type = get_operand_type (&ops[0]);
556 const struct operator *operator;
558 assert (check_binary_operators (ops, op_cnt, operand_type));
562 for (op_count = 0; match_operator (lexer, ops, op_cnt, &operator); op_count++)
566 /* Convert the left-hand side to type OPERAND_TYPE. */
567 if (!type_coercion (e, operand_type, &node, operator->name))
570 /* Parse the right-hand side and coerce to type
572 rhs = parse_next_level (lexer, e);
573 if (!type_coercion (e, operand_type, &rhs, operator->name))
575 node = expr_allocate_binary (e, operator->type, node, rhs);
578 if (op_count > 1 && chain_warning != NULL)
579 msg (SW, chain_warning);
584 static union any_node *
585 parse_inverting_unary_operator (struct lexer *lexer, struct expression *e,
586 const struct operator *op,
587 parse_recursively_func *parse_next_level)
589 union any_node *node;
592 check_operator (op, 1, get_operand_type (op));
595 while (match_operator (lexer, op, 1, NULL))
598 node = parse_next_level (lexer, e);
600 && type_coercion (e, get_operand_type (op), &node, op->name)
601 && op_count % 2 != 0)
602 return expr_allocate_unary (e, op->type, node);
607 /* Parses the OR level. */
608 static union any_node *
609 parse_or (struct lexer *lexer, struct expression *e)
611 static const struct operator op =
612 { T_OR, OP_OR, "logical disjunction (\"OR\")" };
614 return parse_binary_operators (lexer, e, parse_and (lexer, e), &op, 1, parse_and, NULL);
617 /* Parses the AND level. */
618 static union any_node *
619 parse_and (struct lexer *lexer, struct expression *e)
621 static const struct operator op =
622 { T_AND, OP_AND, "logical conjunction (\"AND\")" };
624 return parse_binary_operators (lexer, e, parse_not (lexer, e),
625 &op, 1, parse_not, NULL);
628 /* Parses the NOT level. */
629 static union any_node *
630 parse_not (struct lexer *lexer, struct expression *e)
632 static const struct operator op
633 = { T_NOT, OP_NOT, "logical negation (\"NOT\")" };
634 return parse_inverting_unary_operator (lexer, e, &op, parse_rel);
637 /* Parse relational operators. */
638 static union any_node *
639 parse_rel (struct lexer *lexer, struct expression *e)
641 const char *chain_warning =
642 _("Chaining relational operators (e.g. \"a < b < c\") will "
643 "not produce the mathematically expected result. "
644 "Use the AND logical operator to fix the problem "
645 "(e.g. \"a < b AND b < c\"). "
646 "If chaining is really intended, parentheses will disable "
647 "this warning (e.g. \"(a < b) < c\".)");
649 union any_node *node = parse_add (lexer, e);
654 switch (expr_node_returns (node))
659 static const struct operator ops[] =
661 { '=', OP_EQ, "numeric equality (\"=\")" },
662 { T_EQ, OP_EQ, "numeric equality (\"EQ\")" },
663 { T_GE, OP_GE, "numeric greater-than-or-equal-to (\">=\")" },
664 { T_GT, OP_GT, "numeric greater than (\">\")" },
665 { T_LE, OP_LE, "numeric less-than-or-equal-to (\"<=\")" },
666 { T_LT, OP_LT, "numeric less than (\"<\")" },
667 { T_NE, OP_NE, "numeric inequality (\"<>\")" },
670 return parse_binary_operators (lexer, e, node, ops,
671 sizeof ops / sizeof *ops,
672 parse_add, chain_warning);
677 static const struct operator ops[] =
679 { '=', OP_EQ_STRING, "string equality (\"=\")" },
680 { T_EQ, OP_EQ_STRING, "string equality (\"EQ\")" },
681 { T_GE, OP_GE_STRING, "string greater-than-or-equal-to (\">=\")" },
682 { T_GT, OP_GT_STRING, "string greater than (\">\")" },
683 { T_LE, OP_LE_STRING, "string less-than-or-equal-to (\"<=\")" },
684 { T_LT, OP_LT_STRING, "string less than (\"<\")" },
685 { T_NE, OP_NE_STRING, "string inequality (\"<>\")" },
688 return parse_binary_operators (lexer, e, node, ops,
689 sizeof ops / sizeof *ops,
690 parse_add, chain_warning);
698 /* Parses the addition and subtraction level. */
699 static union any_node *
700 parse_add (struct lexer *lexer, struct expression *e)
702 static const struct operator ops[] =
704 { '+', OP_ADD, "addition (\"+\")" },
705 { '-', OP_SUB, "subtraction (\"-\")" },
708 return parse_binary_operators (lexer, e, parse_mul (lexer, e),
709 ops, sizeof ops / sizeof *ops,
713 /* Parses the multiplication and division level. */
714 static union any_node *
715 parse_mul (struct lexer *lexer, struct expression *e)
717 static const struct operator ops[] =
719 { '*', OP_MUL, "multiplication (\"*\")" },
720 { '/', OP_DIV, "division (\"/\")" },
723 return parse_binary_operators (lexer, e, parse_neg (lexer, e),
724 ops, sizeof ops / sizeof *ops,
728 /* Parses the unary minus level. */
729 static union any_node *
730 parse_neg (struct lexer *lexer, struct expression *e)
732 static const struct operator op = { '-', OP_NEG, "negation (\"-\")" };
733 return parse_inverting_unary_operator (lexer, e, &op, parse_exp);
736 static union any_node *
737 parse_exp (struct lexer *lexer, struct expression *e)
739 static const struct operator op =
740 { T_EXP, OP_POW, "exponentiation (\"**\")" };
742 const char *chain_warning =
743 _("The exponentiation operator (\"**\") is left-associative, "
744 "even though right-associative semantics are more useful. "
745 "That is, \"a**b**c\" equals \"(a**b)**c\", not as \"a**(b**c)\". "
746 "To disable this warning, insert parentheses.");
748 return parse_binary_operators (lexer, e, parse_primary (lexer, e), &op, 1,
749 parse_primary, chain_warning);
752 /* Parses system variables. */
753 static union any_node *
754 parse_sysvar (struct lexer *lexer, struct expression *e)
756 if (lex_match_id (lexer, "$CASENUM"))
757 return expr_allocate_nullary (e, OP_CASENUM);
758 else if (lex_match_id (lexer, "$DATE"))
760 static const char *months[12] =
762 "JAN", "FEB", "MAR", "APR", "MAY", "JUN",
763 "JUL", "AUG", "SEP", "OCT", "NOV", "DEC",
766 time_t last_proc_time = time_of_last_procedure (e->ds);
770 time = localtime (&last_proc_time);
771 sprintf (temp_buf, "%02d %s %02d", abs (time->tm_mday) % 100,
772 months[abs (time->tm_mon) % 12], abs (time->tm_year) % 100);
774 return expr_allocate_string_buffer (e, temp_buf, strlen (temp_buf));
776 else if (lex_match_id (lexer, "$TRUE"))
777 return expr_allocate_boolean (e, 1.0);
778 else if (lex_match_id (lexer, "$FALSE"))
779 return expr_allocate_boolean (e, 0.0);
780 else if (lex_match_id (lexer, "$SYSMIS"))
781 return expr_allocate_number (e, SYSMIS);
782 else if (lex_match_id (lexer, "$JDATE"))
784 time_t time = time_of_last_procedure (e->ds);
785 struct tm *tm = localtime (&time);
786 return expr_allocate_number (e, expr_ymd_to_ofs (tm->tm_year + 1900,
790 else if (lex_match_id (lexer, "$TIME"))
792 time_t time = time_of_last_procedure (e->ds);
793 struct tm *tm = localtime (&time);
794 return expr_allocate_number (e,
795 expr_ymd_to_date (tm->tm_year + 1900,
798 + tm->tm_hour * 60 * 60.
802 else if (lex_match_id (lexer, "$LENGTH"))
803 return expr_allocate_number (e, get_viewlength ());
804 else if (lex_match_id (lexer, "$WIDTH"))
805 return expr_allocate_number (e, get_viewwidth ());
808 msg (SE, _("Unknown system variable %s."), lex_tokid (lexer));
813 /* Parses numbers, varnames, etc. */
814 static union any_node *
815 parse_primary (struct lexer *lexer, struct expression *e)
817 switch (lex_token (lexer))
820 if (lex_look_ahead (lexer) == '(')
822 /* An identifier followed by a left parenthesis may be
823 a vector element reference. If not, it's a function
825 if (e->ds != NULL && dict_lookup_vector (dataset_dict (e->ds), lex_tokid (lexer)) != NULL)
826 return parse_vector_element (lexer, e);
828 return parse_function (lexer, e);
830 else if (lex_tokid (lexer)[0] == '$')
832 /* $ at the beginning indicates a system variable. */
833 return parse_sysvar (lexer, e);
835 else if (e->ds != NULL && dict_lookup_var (dataset_dict (e->ds), lex_tokid (lexer)))
837 /* It looks like a user variable.
838 (It could be a format specifier, but we'll assume
839 it's a variable unless proven otherwise. */
840 return allocate_unary_variable (e, parse_variable (lexer, dataset_dict (e->ds)));
844 /* Try to parse it as a format specifier. */
849 ok = parse_format_specifier (lexer, &fmt);
853 return expr_allocate_format (e, &fmt);
855 /* All attempts failed. */
856 msg (SE, _("Unknown identifier %s."), lex_tokid (lexer));
864 union any_node *node = expr_allocate_number (e, lex_tokval (lexer) );
871 union any_node *node = expr_allocate_string_buffer (
872 e, ds_cstr (lex_tokstr (lexer) ), ds_length (lex_tokstr (lexer) ));
879 union any_node *node;
881 node = parse_or (lexer, e);
882 if (node != NULL && !lex_match (lexer, ')'))
884 lex_error (lexer, _("expecting `)'"));
891 lex_error (lexer, _("in expression"));
896 static union any_node *
897 parse_vector_element (struct lexer *lexer, struct expression *e)
899 const struct vector *vector;
900 union any_node *element;
902 /* Find vector, skip token.
903 The caller must already have verified that the current token
904 is the name of a vector. */
905 vector = dict_lookup_vector (dataset_dict (e->ds), lex_tokid (lexer));
906 assert (vector != NULL);
909 /* Skip left parenthesis token.
910 The caller must have verified that the lookahead is a left
912 assert (lex_token (lexer) == '(');
915 element = parse_or (lexer, e);
916 if (!type_coercion (e, OP_number, &element, "vector indexing")
917 || !lex_match (lexer, ')'))
920 return expr_allocate_binary (e, (vector_get_type (vector) == VAR_NUMERIC
921 ? OP_VEC_ELEM_NUM : OP_VEC_ELEM_STR),
922 element, expr_allocate_vector (e, vector));
925 /* Individual function parsing. */
927 const struct operation operations[OP_first + OP_cnt] = {
932 word_matches (const char **test, const char **name)
934 size_t test_len = strcspn (*test, ".");
935 size_t name_len = strcspn (*name, ".");
936 if (test_len == name_len)
938 if (buf_compare_case (*test, *name, test_len))
941 else if (test_len < 3 || test_len > name_len)
945 if (buf_compare_case (*test, *name, test_len))
951 if (**test != **name)
963 compare_names (const char *test, const char *name, bool abbrev_ok)
970 if (!word_matches (&test, &name))
972 if (*name == '\0' && *test == '\0')
978 compare_strings (const char *test, const char *name, bool abbrev_ok UNUSED)
980 return strcasecmp (test, name);
984 lookup_function_helper (const char *name,
985 int (*compare) (const char *test, const char *name,
987 const struct operation **first,
988 const struct operation **last)
990 const struct operation *f;
992 for (f = operations + OP_function_first;
993 f <= operations + OP_function_last; f++)
994 if (!compare (name, f->name, !(f->flags & OPF_NO_ABBREV)))
998 while (f <= operations + OP_function_last
999 && !compare (name, f->name, !(f->flags & OPF_NO_ABBREV)))
1010 lookup_function (const char *name,
1011 const struct operation **first,
1012 const struct operation **last)
1014 *first = *last = NULL;
1015 return (lookup_function_helper (name, compare_strings, first, last)
1016 || lookup_function_helper (name, compare_names, first, last));
1020 extract_min_valid (char *s)
1022 char *p = strrchr (s, '.');
1024 || p[1] < '0' || p[1] > '9'
1025 || strspn (p + 1, "0123456789") != strlen (p + 1))
1028 return atoi (p + 1);
1032 function_arg_type (const struct operation *f, size_t arg_idx)
1034 assert (arg_idx < f->arg_cnt || (f->flags & OPF_ARRAY_OPERAND));
1036 return f->args[arg_idx < f->arg_cnt ? arg_idx : f->arg_cnt - 1];
1040 match_function (union any_node **args, int arg_cnt, const struct operation *f)
1044 if (arg_cnt < f->arg_cnt
1045 || (arg_cnt > f->arg_cnt && (f->flags & OPF_ARRAY_OPERAND) == 0)
1046 || arg_cnt - (f->arg_cnt - 1) < f->array_min_elems)
1049 for (i = 0; i < arg_cnt; i++)
1050 if (!is_coercible (function_arg_type (f, i), &args[i]))
1057 coerce_function_args (struct expression *e, const struct operation *f,
1058 union any_node **args, size_t arg_cnt)
1062 for (i = 0; i < arg_cnt; i++)
1063 type_coercion_assert (e, function_arg_type (f, i), &args[i]);
1067 validate_function_args (const struct operation *f, int arg_cnt, int min_valid)
1069 int array_arg_cnt = arg_cnt - (f->arg_cnt - 1);
1070 if (array_arg_cnt < f->array_min_elems)
1072 msg (SE, _("%s must have at least %d arguments in list."),
1073 f->prototype, f->array_min_elems);
1077 if ((f->flags & OPF_ARRAY_OPERAND)
1078 && array_arg_cnt % f->array_granularity != 0)
1080 if (f->array_granularity == 2)
1081 msg (SE, _("%s must have even number of arguments in list."),
1084 msg (SE, _("%s must have multiple of %d arguments in list."),
1085 f->prototype, f->array_granularity);
1089 if (min_valid != -1)
1091 if (f->array_min_elems == 0)
1093 assert ((f->flags & OPF_MIN_VALID) == 0);
1094 msg (SE, _("%s function does not accept a minimum valid "
1095 "argument count."), f->prototype);
1100 assert (f->flags & OPF_MIN_VALID);
1101 if (array_arg_cnt < f->array_min_elems)
1103 msg (SE, _("%s requires at least %d valid arguments in list."),
1104 f->prototype, f->array_min_elems);
1107 else if (min_valid > array_arg_cnt)
1109 msg (SE, _("With %s, "
1110 "using minimum valid argument count of %d "
1111 "does not make sense when passing only %d "
1112 "arguments in list."),
1113 f->prototype, min_valid, array_arg_cnt);
1123 add_arg (union any_node ***args, int *arg_cnt, int *arg_cap,
1124 union any_node *arg)
1126 if (*arg_cnt >= *arg_cap)
1129 *args = xrealloc (*args, sizeof **args * *arg_cap);
1132 (*args)[(*arg_cnt)++] = arg;
1136 put_invocation (struct string *s,
1137 const char *func_name, union any_node **args, size_t arg_cnt)
1141 ds_put_format (s, "%s(", func_name);
1142 for (i = 0; i < arg_cnt; i++)
1145 ds_put_cstr (s, ", ");
1146 ds_put_cstr (s, operations[expr_node_returns (args[i])].prototype);
1148 ds_put_char (s, ')');
1152 no_match (const char *func_name,
1153 union any_node **args, size_t arg_cnt,
1154 const struct operation *first, const struct operation *last)
1157 const struct operation *f;
1161 if (last - first == 1)
1163 ds_put_format (&s, _("Type mismatch invoking %s as "), first->prototype);
1164 put_invocation (&s, func_name, args, arg_cnt);
1168 ds_put_cstr (&s, _("Function invocation "));
1169 put_invocation (&s, func_name, args, arg_cnt);
1170 ds_put_cstr (&s, _(" does not match any known function. Candidates are:"));
1172 for (f = first; f < last; f++)
1173 ds_put_format (&s, "\n%s", f->prototype);
1175 ds_put_char (&s, '.');
1177 msg (SE, "%s", ds_cstr (&s));
1182 static union any_node *
1183 parse_function (struct lexer *lexer, struct expression *e)
1186 const struct operation *f, *first, *last;
1188 union any_node **args = NULL;
1192 struct string func_name;
1196 ds_init_string (&func_name, lex_tokstr (lexer));
1197 min_valid = extract_min_valid (ds_cstr (lex_tokstr (lexer)));
1198 if (!lookup_function (ds_cstr (lex_tokstr (lexer)), &first, &last))
1200 msg (SE, _("No function or vector named %s."), ds_cstr (lex_tokstr (lexer)));
1201 ds_destroy (&func_name);
1206 if (!lex_force_match (lexer, '('))
1208 ds_destroy (&func_name);
1213 arg_cnt = arg_cap = 0;
1214 if (lex_token (lexer) != ')')
1217 if (lex_token (lexer) == T_ID
1218 && toupper (lex_look_ahead (lexer)) == 'T')
1220 const struct variable **vars;
1224 if (!parse_variables_const (lexer, dataset_dict (e->ds), &vars, &var_cnt, PV_SINGLE))
1226 for (i = 0; i < var_cnt; i++)
1227 add_arg (&args, &arg_cnt, &arg_cap,
1228 allocate_unary_variable (e, vars[i]));
1233 union any_node *arg = parse_or (lexer, e);
1237 add_arg (&args, &arg_cnt, &arg_cap, arg);
1239 if (lex_match (lexer, ')'))
1241 else if (!lex_match (lexer, ','))
1243 lex_error (lexer, _("expecting `,' or `)' invoking %s function"),
1249 for (f = first; f < last; f++)
1250 if (match_function (args, arg_cnt, f))
1254 no_match (ds_cstr (&func_name), args, arg_cnt, first, last);
1258 coerce_function_args (e, f, args, arg_cnt);
1259 if (!validate_function_args (f, arg_cnt, min_valid))
1262 if ((f->flags & OPF_EXTENSION) && get_syntax () == COMPATIBLE)
1263 msg (SW, _("%s is a PSPP extension."), f->prototype);
1264 if (f->flags & OPF_UNIMPLEMENTED)
1266 msg (SE, _("%s is not yet implemented."), f->prototype);
1269 if ((f->flags & OPF_PERM_ONLY) &&
1270 proc_in_temporary_transformations (e->ds))
1272 msg (SE, _("%s may not appear after TEMPORARY."), f->prototype);
1276 n = expr_allocate_composite (e, f - operations, args, arg_cnt);
1277 n->composite.min_valid = min_valid != -1 ? min_valid : f->array_min_elems;
1279 if (n->type == OP_LAG_Vn || n->type == OP_LAG_Vs)
1280 dataset_need_lag (e->ds, 1);
1281 else if (n->type == OP_LAG_Vnn || n->type == OP_LAG_Vsn)
1284 assert (n->composite.arg_cnt == 2);
1285 assert (n->composite.args[1]->type == OP_pos_int);
1286 n_before = n->composite.args[1]->integer.i;
1287 dataset_need_lag (e->ds, n_before);
1291 ds_destroy (&func_name);
1296 ds_destroy (&func_name);
1300 /* Utility functions. */
1302 static struct expression *
1303 expr_create (struct dataset *ds)
1305 struct pool *pool = pool_create ();
1306 struct expression *e = pool_alloc (pool, sizeof *e);
1307 e->expr_pool = pool;
1309 e->eval_pool = pool_create_subpool (e->expr_pool);
1312 e->op_cnt = e->op_cap = 0;
1317 expr_node_returns (const union any_node *n)
1320 assert (is_operation (n->type));
1321 if (is_atom (n->type))
1323 else if (is_composite (n->type))
1324 return operations[n->type].returns;
1330 atom_type_name (atom_type type)
1332 assert (is_atom (type));
1333 return operations[type].name;
1337 expr_allocate_nullary (struct expression *e, operation_type op)
1339 return expr_allocate_composite (e, op, NULL, 0);
1343 expr_allocate_unary (struct expression *e, operation_type op,
1344 union any_node *arg0)
1346 return expr_allocate_composite (e, op, &arg0, 1);
1350 expr_allocate_binary (struct expression *e, operation_type op,
1351 union any_node *arg0, union any_node *arg1)
1353 union any_node *args[2];
1356 return expr_allocate_composite (e, op, args, 2);
1360 is_valid_node (union any_node *n)
1362 const struct operation *op;
1366 assert (is_operation (n->type));
1367 op = &operations[n->type];
1369 if (!is_atom (n->type))
1371 struct composite_node *c = &n->composite;
1373 assert (is_composite (n->type));
1374 assert (c->arg_cnt >= op->arg_cnt);
1375 for (i = 0; i < op->arg_cnt; i++)
1376 assert (is_compatible (op->args[i], expr_node_returns (c->args[i])));
1377 if (c->arg_cnt > op->arg_cnt && !is_operator (n->type))
1379 assert (op->flags & OPF_ARRAY_OPERAND);
1380 for (i = 0; i < c->arg_cnt; i++)
1381 assert (is_compatible (op->args[op->arg_cnt - 1],
1382 expr_node_returns (c->args[i])));
1390 expr_allocate_composite (struct expression *e, operation_type op,
1391 union any_node **args, size_t arg_cnt)
1396 n = pool_alloc (e->expr_pool, sizeof n->composite);
1398 n->composite.arg_cnt = arg_cnt;
1399 n->composite.args = pool_alloc (e->expr_pool,
1400 sizeof *n->composite.args * arg_cnt);
1401 for (i = 0; i < arg_cnt; i++)
1403 if (args[i] == NULL)
1405 n->composite.args[i] = args[i];
1407 memcpy (n->composite.args, args, sizeof *n->composite.args * arg_cnt);
1408 n->composite.min_valid = 0;
1409 assert (is_valid_node (n));
1414 expr_allocate_number (struct expression *e, double d)
1416 union any_node *n = pool_alloc (e->expr_pool, sizeof n->number);
1417 n->type = OP_number;
1423 expr_allocate_boolean (struct expression *e, double b)
1425 union any_node *n = pool_alloc (e->expr_pool, sizeof n->number);
1426 assert (b == 0.0 || b == 1.0 || b == SYSMIS);
1427 n->type = OP_boolean;
1433 expr_allocate_integer (struct expression *e, int i)
1435 union any_node *n = pool_alloc (e->expr_pool, sizeof n->integer);
1436 n->type = OP_integer;
1442 expr_allocate_pos_int (struct expression *e, int i)
1444 union any_node *n = pool_alloc (e->expr_pool, sizeof n->integer);
1446 n->type = OP_pos_int;
1452 expr_allocate_vector (struct expression *e, const struct vector *vector)
1454 union any_node *n = pool_alloc (e->expr_pool, sizeof n->vector);
1455 n->type = OP_vector;
1456 n->vector.v = vector;
1461 expr_allocate_string_buffer (struct expression *e,
1462 const char *string, size_t length)
1464 union any_node *n = pool_alloc (e->expr_pool, sizeof n->string);
1465 n->type = OP_string;
1466 if (length > MAX_STRING)
1467 length = MAX_STRING;
1468 n->string.s = copy_string (e, string, length);
1473 expr_allocate_string (struct expression *e, struct substring s)
1475 union any_node *n = pool_alloc (e->expr_pool, sizeof n->string);
1476 n->type = OP_string;
1482 expr_allocate_variable (struct expression *e, const struct variable *v)
1484 union any_node *n = pool_alloc (e->expr_pool, sizeof n->variable);
1485 n->type = var_is_numeric (v) ? OP_num_var : OP_str_var;
1491 expr_allocate_format (struct expression *e, const struct fmt_spec *format)
1493 union any_node *n = pool_alloc (e->expr_pool, sizeof n->format);
1494 n->type = OP_format;
1495 n->format.f = *format;
1499 /* Allocates a unary composite node that represents the value of
1500 variable V in expression E. */
1501 static union any_node *
1502 allocate_unary_variable (struct expression *e, const struct variable *v)
1505 return expr_allocate_unary (e, var_is_numeric (v) ? OP_NUM_VAR : OP_STR_VAR,
1506 expr_allocate_variable (e, v));
1509 /* Export function details to other modules. */
1511 /* Returns the operation structure for the function with the
1513 const struct operation *
1514 expr_get_function (size_t idx)
1516 assert (idx < OP_function_cnt);
1517 return &operations[OP_function_first + idx];
1520 /* Returns the number of expression functions. */
1522 expr_get_function_cnt (void)
1524 return OP_function_cnt;
1527 /* Returns the name of operation OP. */
1529 expr_operation_get_name (const struct operation *op)
1534 /* Returns the human-readable prototype for operation OP. */
1536 expr_operation_get_prototype (const struct operation *op)
1538 return op->prototype;
1541 /* Returns the number of arguments for operation OP. */
1543 expr_operation_get_arg_cnt (const struct operation *op)