1 /* PSPP - a program for statistical analysis.
2 Copyright (C) 1997-9, 2000, 2006, 2010, 2011 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/>. */
26 #include "data/case.h"
27 #include "data/dictionary.h"
28 #include "data/settings.h"
29 #include "data/variable.h"
30 #include "language/expressions/helpers.h"
31 #include "language/lexer/format-parser.h"
32 #include "language/lexer/lexer.h"
33 #include "language/lexer/variable-parser.h"
34 #include "libpspp/array.h"
35 #include "libpspp/assertion.h"
36 #include "libpspp/i18n.h"
37 #include "libpspp/message.h"
38 #include "libpspp/misc.h"
39 #include "libpspp/pool.h"
40 #include "libpspp/str.h"
42 #include "gl/xalloc.h"
46 /* Recursive descent parser in order of increasing precedence. */
47 typedef union any_node *parse_recursively_func (struct lexer *, struct expression *);
48 static parse_recursively_func parse_or, parse_and, parse_not;
49 static parse_recursively_func parse_rel, parse_add, parse_mul;
50 static parse_recursively_func parse_neg, parse_exp;
51 static parse_recursively_func parse_primary;
52 static parse_recursively_func parse_vector_element, parse_function;
54 /* Utility functions. */
55 static struct expression *expr_create (struct dataset *ds);
56 atom_type expr_node_returns (const union any_node *);
58 static const char *atom_type_name (atom_type);
59 static struct expression *finish_expression (union any_node *,
61 static bool type_check (struct expression *, union any_node **,
62 enum expr_type expected_type);
63 static union any_node *allocate_unary_variable (struct expression *,
64 const struct variable *);
66 /* Public functions. */
68 /* Parses an expression of the given TYPE.
69 If DICT is nonnull then variables and vectors within it may be
70 referenced within the expression; otherwise, the expression
71 must not reference any variables or vectors.
72 Returns the new expression if successful or a null pointer
75 expr_parse (struct lexer *lexer, struct dataset *ds, enum expr_type type)
80 assert (type == EXPR_NUMBER || type == EXPR_STRING || type == EXPR_BOOLEAN);
83 n = parse_or (lexer, e);
84 if (n != NULL && type_check (e, &n, type))
85 return finish_expression (expr_optimize (n, e), e);
93 /* Parses and returns an expression of the given TYPE, as
94 expr_parse(), and sets up so that destroying POOL will free
95 the expression as well. */
97 expr_parse_pool (struct lexer *lexer,
102 struct expression *e = expr_parse (lexer, ds, type);
104 pool_add_subpool (pool, e->expr_pool);
108 /* Free expression E. */
110 expr_free (struct expression *e)
113 pool_destroy (e->expr_pool);
117 expr_parse_any (struct lexer *lexer, struct dataset *ds, bool optimize)
120 struct expression *e;
122 e = expr_create (ds);
123 n = parse_or (lexer, e);
131 n = expr_optimize (n, e);
132 return finish_expression (n, e);
135 /* Finishing up expression building. */
137 /* Height of an expression's stacks. */
140 int number_height; /* Height of number stack. */
141 int string_height; /* Height of string stack. */
144 /* Stack heights used by different kinds of arguments. */
145 static const struct stack_heights on_number_stack = {1, 0};
146 static const struct stack_heights on_string_stack = {0, 1};
147 static const struct stack_heights not_on_stack = {0, 0};
149 /* Returns the stack heights used by an atom of the given
151 static const struct stack_heights *
152 atom_type_stack (atom_type type)
154 assert (is_atom (type));
160 return &on_number_stack;
163 return &on_string_stack;
173 return ¬_on_stack;
180 /* Measures the stack height needed for node N, supposing that
181 the stack height is initially *HEIGHT and updating *HEIGHT to
182 the final stack height. Updates *MAX, if necessary, to
183 reflect the maximum intermediate or final height. */
185 measure_stack (const union any_node *n,
186 struct stack_heights *height, struct stack_heights *max)
188 const struct stack_heights *return_height;
190 if (is_composite (n->type))
192 struct stack_heights args;
196 for (i = 0; i < n->composite.arg_cnt; i++)
197 measure_stack (n->composite.args[i], &args, max);
199 return_height = atom_type_stack (operations[n->type].returns);
202 return_height = atom_type_stack (n->type);
204 height->number_height += return_height->number_height;
205 height->string_height += return_height->string_height;
207 if (height->number_height > max->number_height)
208 max->number_height = height->number_height;
209 if (height->string_height > max->string_height)
210 max->string_height = height->string_height;
213 /* Allocates stacks within E sufficient for evaluating node N. */
215 allocate_stacks (union any_node *n, struct expression *e)
217 struct stack_heights initial = {0, 0};
218 struct stack_heights max = {0, 0};
220 measure_stack (n, &initial, &max);
221 e->number_stack = pool_alloc (e->expr_pool,
222 sizeof *e->number_stack * max.number_height);
223 e->string_stack = pool_alloc (e->expr_pool,
224 sizeof *e->string_stack * max.string_height);
227 /* Finalizes expression E for evaluating node N. */
228 static struct expression *
229 finish_expression (union any_node *n, struct expression *e)
231 /* Allocate stacks. */
232 allocate_stacks (n, e);
234 /* Output postfix representation. */
237 /* The eval_pool might have been used for allocating strings
238 during optimization. We need to keep those strings around
239 for all subsequent evaluations, so start a new eval_pool. */
240 e->eval_pool = pool_create_subpool (e->expr_pool);
245 /* Verifies that expression E, whose root node is *N, can be
246 converted to type EXPECTED_TYPE, inserting a conversion at *N
247 if necessary. Returns true if successful, false on failure. */
249 type_check (struct expression *e,
250 union any_node **n, enum expr_type expected_type)
252 atom_type actual_type = expr_node_returns (*n);
254 switch (expected_type)
258 if (actual_type != OP_number && actual_type != OP_boolean)
260 msg (SE, _("Type mismatch: expression has %s type, "
261 "but a numeric value is required here."),
262 atom_type_name (actual_type));
265 if (actual_type == OP_number && expected_type == OP_boolean)
266 *n = expr_allocate_unary (e, OP_NUM_TO_BOOLEAN, *n);
270 if (actual_type != OP_string)
272 msg (SE, _("Type mismatch: expression has %s type, "
273 "but a string value is required here."),
274 atom_type_name (actual_type));
286 /* Recursive-descent expression parser. */
288 /* Considers whether *NODE may be coerced to type REQUIRED_TYPE.
289 Returns true if possible, false if disallowed.
291 If DO_COERCION is false, then *NODE is not modified and there
294 If DO_COERCION is true, we perform the coercion if possible,
295 modifying *NODE if necessary. If the coercion is not possible
296 then we free *NODE and set *NODE to a null pointer.
298 This function's interface is somewhat awkward. Use one of the
299 wrapper functions type_coercion(), type_coercion_assert(), or
300 is_coercible() instead. */
302 type_coercion_core (struct expression *e,
303 atom_type required_type,
304 union any_node **node,
305 const char *operator_name,
308 atom_type actual_type;
310 assert (!!do_coercion == (e != NULL));
313 /* Propagate error. Whatever caused the original error
314 already emitted an error message. */
318 actual_type = expr_node_returns (*node);
319 if (actual_type == required_type)
325 switch (required_type)
328 if (actual_type == OP_boolean)
330 /* To enforce strict typing rules, insert Boolean to
331 numeric "conversion". This conversion is a no-op,
332 so it will be removed later. */
334 *node = expr_allocate_unary (e, OP_BOOLEAN_TO_NUM, *node);
340 /* No coercion to string. */
344 if (actual_type == OP_number)
346 /* Convert numeric to boolean. */
349 union any_node *op_name;
351 op_name = expr_allocate_string (e, ss_cstr (operator_name));
352 *node = expr_allocate_binary (e, OP_NUM_TO_BOOLEAN, *node,
364 if ((*node)->type == OP_format
365 && fmt_check_input (&(*node)->format.f)
366 && fmt_check_type_compat (&(*node)->format.f, VAL_NUMERIC))
370 (*node)->type = OP_ni_format;
378 if ((*node)->type == OP_format
379 && fmt_check_output (&(*node)->format.f)
380 && fmt_check_type_compat (&(*node)->format.f, VAL_NUMERIC))
384 (*node)->type = OP_no_format;
391 if ((*node)->type == OP_NUM_VAR)
394 *node = (*node)->composite.args[0];
400 if ((*node)->type == OP_STR_VAR)
403 *node = (*node)->composite.args[0];
409 if ((*node)->type == OP_NUM_VAR || (*node)->type == OP_STR_VAR)
412 *node = (*node)->composite.args[0];
418 if ((*node)->type == OP_number
419 && floor ((*node)->number.n) == (*node)->number.n
420 && (*node)->number.n > 0 && (*node)->number.n < INT_MAX)
423 *node = expr_allocate_pos_int (e, (*node)->number.n);
434 msg (SE, _("Type mismatch while applying %s operator: "
435 "cannot convert %s to %s."),
437 atom_type_name (actual_type), atom_type_name (required_type));
443 /* Coerces *NODE to type REQUIRED_TYPE, and returns success. If
444 *NODE cannot be coerced to the desired type then we issue an
445 error message about operator OPERATOR_NAME and free *NODE. */
447 type_coercion (struct expression *e,
448 atom_type required_type, union any_node **node,
449 const char *operator_name)
451 return type_coercion_core (e, required_type, node, operator_name, true);
454 /* Coerces *NODE to type REQUIRED_TYPE.
455 Assert-fails if the coercion is disallowed. */
457 type_coercion_assert (struct expression *e,
458 atom_type required_type, union any_node **node)
460 int success = type_coercion_core (e, required_type, node, NULL, true);
464 /* Returns true if *NODE may be coerced to type REQUIRED_TYPE,
467 is_coercible (atom_type required_type, union any_node *const *node)
469 return type_coercion_core (NULL, required_type,
470 (union any_node **) node, NULL, false);
473 /* Returns true if ACTUAL_TYPE is a kind of REQUIRED_TYPE, false
476 is_compatible (atom_type required_type, atom_type actual_type)
478 return (required_type == actual_type
479 || (required_type == OP_var
480 && (actual_type == OP_num_var || actual_type == OP_str_var)));
483 /* How to parse an operator. */
486 int token; /* Token representing operator. */
487 operation_type type; /* Operation type representing operation. */
488 const char *name; /* Name of operator. */
491 /* Attempts to match the current token against the tokens for the
492 OP_CNT operators in OPS[]. If successful, returns true
493 and, if OPERATOR is non-null, sets *OPERATOR to the operator.
494 On failure, returns false and, if OPERATOR is non-null, sets
495 *OPERATOR to a null pointer. */
497 match_operator (struct lexer *lexer, const struct operator ops[], size_t op_cnt,
498 const struct operator **operator)
500 const struct operator *op;
502 for (op = ops; op < ops + op_cnt; op++)
503 if (lex_token (lexer) == op->token)
505 if (op->token != T_NEG_NUM)
507 if (operator != NULL)
511 if (operator != NULL)
517 check_operator (const struct operator *op, int arg_cnt, atom_type arg_type)
519 const struct operation *o;
523 o = &operations[op->type];
524 assert (o->arg_cnt == arg_cnt);
525 assert ((o->flags & OPF_ARRAY_OPERAND) == 0);
526 for (i = 0; i < arg_cnt; i++)
527 assert (is_compatible (arg_type, o->args[i]));
532 check_binary_operators (const struct operator ops[], size_t op_cnt,
537 for (i = 0; i < op_cnt; i++)
538 check_operator (&ops[i], 2, arg_type);
543 get_operand_type (const struct operator *op)
545 return operations[op->type].args[0];
548 /* Parses a chain of left-associative operator/operand pairs.
549 There are OP_CNT operators, specified in OPS[]. The
550 operators' operands must all be the same type. The next
551 higher level is parsed by PARSE_NEXT_LEVEL. If CHAIN_WARNING
552 is non-null, then it will be issued as a warning if more than
553 one operator/operand pair is parsed. */
554 static union any_node *
555 parse_binary_operators (struct lexer *lexer, struct expression *e, union any_node *node,
556 const struct operator ops[], size_t op_cnt,
557 parse_recursively_func *parse_next_level,
558 const char *chain_warning)
560 atom_type operand_type = get_operand_type (&ops[0]);
562 const struct operator *operator;
564 assert (check_binary_operators (ops, op_cnt, operand_type));
568 for (op_count = 0; match_operator (lexer, ops, op_cnt, &operator); op_count++)
572 /* Convert the left-hand side to type OPERAND_TYPE. */
573 if (!type_coercion (e, operand_type, &node, operator->name))
576 /* Parse the right-hand side and coerce to type
578 rhs = parse_next_level (lexer, e);
579 if (!type_coercion (e, operand_type, &rhs, operator->name))
581 node = expr_allocate_binary (e, operator->type, node, rhs);
584 if (op_count > 1 && chain_warning != NULL)
585 msg (SW, "%s", chain_warning);
590 static union any_node *
591 parse_inverting_unary_operator (struct lexer *lexer, struct expression *e,
592 const struct operator *op,
593 parse_recursively_func *parse_next_level)
595 union any_node *node;
598 check_operator (op, 1, get_operand_type (op));
601 while (match_operator (lexer, op, 1, NULL))
604 node = parse_next_level (lexer, e);
606 && type_coercion (e, get_operand_type (op), &node, op->name)
607 && op_count % 2 != 0)
608 return expr_allocate_unary (e, op->type, node);
613 /* Parses the OR level. */
614 static union any_node *
615 parse_or (struct lexer *lexer, struct expression *e)
617 static const struct operator op =
618 { T_OR, OP_OR, "logical disjunction (`OR')" };
620 return parse_binary_operators (lexer, e, parse_and (lexer, e), &op, 1, parse_and, NULL);
623 /* Parses the AND level. */
624 static union any_node *
625 parse_and (struct lexer *lexer, struct expression *e)
627 static const struct operator op =
628 { T_AND, OP_AND, "logical conjunction (`AND')" };
630 return parse_binary_operators (lexer, e, parse_not (lexer, e),
631 &op, 1, parse_not, NULL);
634 /* Parses the NOT level. */
635 static union any_node *
636 parse_not (struct lexer *lexer, struct expression *e)
638 static const struct operator op
639 = { T_NOT, OP_NOT, "logical negation (`NOT')" };
640 return parse_inverting_unary_operator (lexer, e, &op, parse_rel);
643 /* Parse relational operators. */
644 static union any_node *
645 parse_rel (struct lexer *lexer, struct expression *e)
647 const char *chain_warning =
648 _("Chaining relational operators (e.g. `a < b < c') will "
649 "not produce the mathematically expected result. "
650 "Use the AND logical operator to fix the problem "
651 "(e.g. `a < b AND b < c'). "
652 "If chaining is really intended, parentheses will disable "
653 "this warning (e.g. `(a < b) < c'.)");
655 union any_node *node = parse_add (lexer, e);
660 switch (expr_node_returns (node))
665 static const struct operator ops[] =
667 { T_EQUALS, OP_EQ, "numeric equality (`=')" },
668 { T_EQ, OP_EQ, "numeric equality (`EQ')" },
669 { T_GE, OP_GE, "numeric greater-than-or-equal-to (`>=')" },
670 { T_GT, OP_GT, "numeric greater than (`>')" },
671 { T_LE, OP_LE, "numeric less-than-or-equal-to (`<=')" },
672 { T_LT, OP_LT, "numeric less than (`<')" },
673 { T_NE, OP_NE, "numeric inequality (`<>')" },
676 return parse_binary_operators (lexer, e, node, ops,
677 sizeof ops / sizeof *ops,
678 parse_add, chain_warning);
683 static const struct operator ops[] =
685 { T_EQUALS, OP_EQ_STRING, "string equality (`=')" },
686 { T_EQ, OP_EQ_STRING, "string equality (`EQ')" },
687 { T_GE, OP_GE_STRING, "string greater-than-or-equal-to (`>=')" },
688 { T_GT, OP_GT_STRING, "string greater than (`>')" },
689 { T_LE, OP_LE_STRING, "string less-than-or-equal-to (`<=')" },
690 { T_LT, OP_LT_STRING, "string less than (`<')" },
691 { T_NE, OP_NE_STRING, "string inequality (`<>')" },
694 return parse_binary_operators (lexer, e, node, ops,
695 sizeof ops / sizeof *ops,
696 parse_add, chain_warning);
704 /* Parses the addition and subtraction level. */
705 static union any_node *
706 parse_add (struct lexer *lexer, struct expression *e)
708 static const struct operator ops[] =
710 { T_PLUS, OP_ADD, "addition (`+')" },
711 { T_DASH, OP_SUB, "subtraction (`-')" },
712 { T_NEG_NUM, OP_ADD, "subtraction (`-')" },
715 return parse_binary_operators (lexer, e, parse_mul (lexer, e),
716 ops, sizeof ops / sizeof *ops,
720 /* Parses the multiplication and division level. */
721 static union any_node *
722 parse_mul (struct lexer *lexer, struct expression *e)
724 static const struct operator ops[] =
726 { T_ASTERISK, OP_MUL, "multiplication (`*')" },
727 { T_SLASH, OP_DIV, "division (`/')" },
730 return parse_binary_operators (lexer, e, parse_neg (lexer, e),
731 ops, sizeof ops / sizeof *ops,
735 /* Parses the unary minus level. */
736 static union any_node *
737 parse_neg (struct lexer *lexer, struct expression *e)
739 static const struct operator op = { T_DASH, OP_NEG, "negation (`-')" };
740 return parse_inverting_unary_operator (lexer, e, &op, parse_exp);
743 static union any_node *
744 parse_exp (struct lexer *lexer, struct expression *e)
746 static const struct operator op =
747 { T_EXP, OP_POW, "exponentiation (`**')" };
749 const char *chain_warning =
750 _("The exponentiation operator (`**') is left-associative, "
751 "even though right-associative semantics are more useful. "
752 "That is, `a**b**c' equals `(a**b)**c', not as `a**(b**c)'. "
753 "To disable this warning, insert parentheses.");
755 union any_node *lhs, *node;
756 bool negative = false;
758 if (lex_token (lexer) == T_NEG_NUM)
760 lhs = expr_allocate_number (e, -lex_tokval (lexer));
765 lhs = parse_primary (lexer, e);
767 node = parse_binary_operators (lexer, e, lhs, &op, 1,
768 parse_primary, chain_warning);
769 return negative ? expr_allocate_unary (e, OP_NEG, node) : node;
772 /* Parses system variables. */
773 static union any_node *
774 parse_sysvar (struct lexer *lexer, struct expression *e)
776 if (lex_match_id (lexer, "$CASENUM"))
777 return expr_allocate_nullary (e, OP_CASENUM);
778 else if (lex_match_id (lexer, "$DATE"))
780 static const char *months[12] =
782 "JAN", "FEB", "MAR", "APR", "MAY", "JUN",
783 "JUL", "AUG", "SEP", "OCT", "NOV", "DEC",
786 time_t last_proc_time = time_of_last_procedure (e->ds);
791 time = localtime (&last_proc_time);
792 sprintf (temp_buf, "%02d %s %02d", abs (time->tm_mday) % 100,
793 months[abs (time->tm_mon) % 12], abs (time->tm_year) % 100);
795 ss_alloc_substring (&s, ss_cstr (temp_buf));
796 return expr_allocate_string (e, s);
798 else if (lex_match_id (lexer, "$TRUE"))
799 return expr_allocate_boolean (e, 1.0);
800 else if (lex_match_id (lexer, "$FALSE"))
801 return expr_allocate_boolean (e, 0.0);
802 else if (lex_match_id (lexer, "$SYSMIS"))
803 return expr_allocate_number (e, SYSMIS);
804 else if (lex_match_id (lexer, "$JDATE"))
806 time_t time = time_of_last_procedure (e->ds);
807 struct tm *tm = localtime (&time);
808 return expr_allocate_number (e, expr_ymd_to_ofs (tm->tm_year + 1900,
812 else if (lex_match_id (lexer, "$TIME"))
814 time_t time = time_of_last_procedure (e->ds);
815 struct tm *tm = localtime (&time);
816 return expr_allocate_number (e,
817 expr_ymd_to_date (tm->tm_year + 1900,
820 + tm->tm_hour * 60 * 60.
824 else if (lex_match_id (lexer, "$LENGTH"))
825 return expr_allocate_number (e, settings_get_viewlength ());
826 else if (lex_match_id (lexer, "$WIDTH"))
827 return expr_allocate_number (e, settings_get_viewwidth ());
830 msg (SE, _("Unknown system variable %s."), lex_tokcstr (lexer));
835 /* Parses numbers, varnames, etc. */
836 static union any_node *
837 parse_primary (struct lexer *lexer, struct expression *e)
839 switch (lex_token (lexer))
842 if (lex_next_token (lexer, 1) == T_LPAREN)
844 /* An identifier followed by a left parenthesis may be
845 a vector element reference. If not, it's a function
847 if (e->ds != NULL && dict_lookup_vector (dataset_dict (e->ds), lex_tokcstr (lexer)) != NULL)
848 return parse_vector_element (lexer, e);
850 return parse_function (lexer, e);
852 else if (lex_tokcstr (lexer)[0] == '$')
854 /* $ at the beginning indicates a system variable. */
855 return parse_sysvar (lexer, e);
857 else if (e->ds != NULL && dict_lookup_var (dataset_dict (e->ds), lex_tokcstr (lexer)))
859 /* It looks like a user variable.
860 (It could be a format specifier, but we'll assume
861 it's a variable unless proven otherwise. */
862 return allocate_unary_variable (e, parse_variable (lexer, dataset_dict (e->ds)));
866 /* Try to parse it as a format specifier. */
871 ok = parse_format_specifier (lexer, &fmt);
875 return expr_allocate_format (e, &fmt);
877 /* All attempts failed. */
878 msg (SE, _("Unknown identifier %s."), lex_tokcstr (lexer));
886 union any_node *node = expr_allocate_number (e, lex_tokval (lexer) );
893 const char *dict_encoding;
894 union any_node *node;
897 dict_encoding = (e->ds != NULL
898 ? dict_get_encoding (dataset_dict (e->ds))
900 s = recode_string (dict_encoding, "UTF-8", lex_tokcstr (lexer),
901 ss_length (lex_tokss (lexer)));
902 node = expr_allocate_string (e, ss_cstr (s));
910 union any_node *node;
912 node = parse_or (lexer, e);
913 if (node != NULL && !lex_force_match (lexer, T_RPAREN))
919 lex_error (lexer, NULL);
924 static union any_node *
925 parse_vector_element (struct lexer *lexer, struct expression *e)
927 const struct vector *vector;
928 union any_node *element;
930 /* Find vector, skip token.
931 The caller must already have verified that the current token
932 is the name of a vector. */
933 vector = dict_lookup_vector (dataset_dict (e->ds), lex_tokcstr (lexer));
934 assert (vector != NULL);
937 /* Skip left parenthesis token.
938 The caller must have verified that the lookahead is a left
940 assert (lex_token (lexer) == T_LPAREN);
943 element = parse_or (lexer, e);
944 if (!type_coercion (e, OP_number, &element, "vector indexing")
945 || !lex_match (lexer, T_RPAREN))
948 return expr_allocate_binary (e, (vector_get_type (vector) == VAL_NUMERIC
949 ? OP_VEC_ELEM_NUM : OP_VEC_ELEM_STR),
950 element, expr_allocate_vector (e, vector));
953 /* Individual function parsing. */
955 const struct operation operations[OP_first + OP_cnt] = {
960 word_matches (const char **test, const char **name)
962 size_t test_len = strcspn (*test, ".");
963 size_t name_len = strcspn (*name, ".");
964 if (test_len == name_len)
966 if (buf_compare_case (*test, *name, test_len))
969 else if (test_len < 3 || test_len > name_len)
973 if (buf_compare_case (*test, *name, test_len))
979 if (**test != **name)
991 compare_names (const char *test, const char *name, bool abbrev_ok)
998 if (!word_matches (&test, &name))
1000 if (*name == '\0' && *test == '\0')
1006 compare_strings (const char *test, const char *name, bool abbrev_ok UNUSED)
1008 return strcasecmp (test, name);
1012 lookup_function_helper (const char *name,
1013 int (*compare) (const char *test, const char *name,
1015 const struct operation **first,
1016 const struct operation **last)
1018 const struct operation *f;
1020 for (f = operations + OP_function_first;
1021 f <= operations + OP_function_last; f++)
1022 if (!compare (name, f->name, !(f->flags & OPF_NO_ABBREV)))
1026 while (f <= operations + OP_function_last
1027 && !compare (name, f->name, !(f->flags & OPF_NO_ABBREV)))
1038 lookup_function (const char *name,
1039 const struct operation **first,
1040 const struct operation **last)
1042 *first = *last = NULL;
1043 return (lookup_function_helper (name, compare_strings, first, last)
1044 || lookup_function_helper (name, compare_names, first, last));
1048 extract_min_valid (const char *s)
1050 char *p = strrchr (s, '.');
1052 || p[1] < '0' || p[1] > '9'
1053 || strspn (p + 1, "0123456789") != strlen (p + 1))
1056 return atoi (p + 1);
1060 function_arg_type (const struct operation *f, size_t arg_idx)
1062 assert (arg_idx < f->arg_cnt || (f->flags & OPF_ARRAY_OPERAND));
1064 return f->args[arg_idx < f->arg_cnt ? arg_idx : f->arg_cnt - 1];
1068 match_function (union any_node **args, int arg_cnt, const struct operation *f)
1072 if (arg_cnt < f->arg_cnt
1073 || (arg_cnt > f->arg_cnt && (f->flags & OPF_ARRAY_OPERAND) == 0)
1074 || arg_cnt - (f->arg_cnt - 1) < f->array_min_elems)
1077 for (i = 0; i < arg_cnt; i++)
1078 if (!is_coercible (function_arg_type (f, i), &args[i]))
1085 coerce_function_args (struct expression *e, const struct operation *f,
1086 union any_node **args, size_t arg_cnt)
1090 for (i = 0; i < arg_cnt; i++)
1091 type_coercion_assert (e, function_arg_type (f, i), &args[i]);
1095 validate_function_args (const struct operation *f, int arg_cnt, int min_valid)
1097 int array_arg_cnt = arg_cnt - (f->arg_cnt - 1);
1098 if (array_arg_cnt < f->array_min_elems)
1100 msg (SE, _("%s must have at least %d arguments in list."),
1101 f->prototype, f->array_min_elems);
1105 if ((f->flags & OPF_ARRAY_OPERAND)
1106 && array_arg_cnt % f->array_granularity != 0)
1108 if (f->array_granularity == 2)
1109 msg (SE, _("%s must have an even number of arguments in list."),
1112 msg (SE, _("%s must have multiple of %d arguments in list."),
1113 f->prototype, f->array_granularity);
1117 if (min_valid != -1)
1119 if (f->array_min_elems == 0)
1121 assert ((f->flags & OPF_MIN_VALID) == 0);
1122 msg (SE, _("%s function does not accept a minimum valid "
1123 "argument count."), f->prototype);
1128 assert (f->flags & OPF_MIN_VALID);
1129 if (array_arg_cnt < f->array_min_elems)
1131 msg (SE, _("%s requires at least %d valid arguments in list."),
1132 f->prototype, f->array_min_elems);
1135 else if (min_valid > array_arg_cnt)
1137 msg (SE, _("With %s, "
1138 "using minimum valid argument count of %d "
1139 "does not make sense when passing only %d "
1140 "arguments in list."),
1141 f->prototype, min_valid, array_arg_cnt);
1151 add_arg (union any_node ***args, int *arg_cnt, int *arg_cap,
1152 union any_node *arg)
1154 if (*arg_cnt >= *arg_cap)
1157 *args = xrealloc (*args, sizeof **args * *arg_cap);
1160 (*args)[(*arg_cnt)++] = arg;
1164 put_invocation (struct string *s,
1165 const char *func_name, union any_node **args, size_t arg_cnt)
1169 ds_put_format (s, "%s(", func_name);
1170 for (i = 0; i < arg_cnt; i++)
1173 ds_put_cstr (s, ", ");
1174 ds_put_cstr (s, operations[expr_node_returns (args[i])].prototype);
1176 ds_put_byte (s, ')');
1180 no_match (const char *func_name,
1181 union any_node **args, size_t arg_cnt,
1182 const struct operation *first, const struct operation *last)
1185 const struct operation *f;
1189 if (last - first == 1)
1191 ds_put_format (&s, _("Type mismatch invoking %s as "), first->prototype);
1192 put_invocation (&s, func_name, args, arg_cnt);
1196 ds_put_cstr (&s, _("Function invocation "));
1197 put_invocation (&s, func_name, args, arg_cnt);
1198 ds_put_cstr (&s, _(" does not match any known function. Candidates are:"));
1200 for (f = first; f < last; f++)
1201 ds_put_format (&s, "\n%s", f->prototype);
1203 ds_put_byte (&s, '.');
1205 msg (SE, "%s", ds_cstr (&s));
1210 static union any_node *
1211 parse_function (struct lexer *lexer, struct expression *e)
1214 const struct operation *f, *first, *last;
1216 union any_node **args = NULL;
1220 struct string func_name;
1224 ds_init_substring (&func_name, lex_tokss (lexer));
1225 min_valid = extract_min_valid (lex_tokcstr (lexer));
1226 if (!lookup_function (lex_tokcstr (lexer), &first, &last))
1228 msg (SE, _("No function or vector named %s."), lex_tokcstr (lexer));
1229 ds_destroy (&func_name);
1234 if (!lex_force_match (lexer, T_LPAREN))
1236 ds_destroy (&func_name);
1241 arg_cnt = arg_cap = 0;
1242 if (lex_token (lexer) != T_RPAREN)
1245 if (lex_token (lexer) == T_ID
1246 && lex_next_token (lexer, 1) == T_TO)
1248 const struct variable **vars;
1252 if (!parse_variables_const (lexer, dataset_dict (e->ds), &vars, &var_cnt, PV_SINGLE))
1254 for (i = 0; i < var_cnt; i++)
1255 add_arg (&args, &arg_cnt, &arg_cap,
1256 allocate_unary_variable (e, vars[i]));
1261 union any_node *arg = parse_or (lexer, e);
1265 add_arg (&args, &arg_cnt, &arg_cap, arg);
1267 if (lex_match (lexer, T_RPAREN))
1269 else if (!lex_match (lexer, T_COMMA))
1271 lex_error (lexer, _("expecting `,' or `)' invoking %s function"),
1277 for (f = first; f < last; f++)
1278 if (match_function (args, arg_cnt, f))
1282 no_match (ds_cstr (&func_name), args, arg_cnt, first, last);
1286 coerce_function_args (e, f, args, arg_cnt);
1287 if (!validate_function_args (f, arg_cnt, min_valid))
1290 if ((f->flags & OPF_EXTENSION) && settings_get_syntax () == COMPATIBLE)
1291 msg (SW, _("%s is a PSPP extension."), f->prototype);
1292 if (f->flags & OPF_UNIMPLEMENTED)
1294 msg (SE, _("%s is not yet implemented."), f->prototype);
1297 if ((f->flags & OPF_PERM_ONLY) &&
1298 proc_in_temporary_transformations (e->ds))
1300 msg (SE, _("%s may not appear after TEMPORARY."), f->prototype);
1304 n = expr_allocate_composite (e, f - operations, args, arg_cnt);
1305 n->composite.min_valid = min_valid != -1 ? min_valid : f->array_min_elems;
1307 if (n->type == OP_LAG_Vn || n->type == OP_LAG_Vs)
1308 dataset_need_lag (e->ds, 1);
1309 else if (n->type == OP_LAG_Vnn || n->type == OP_LAG_Vsn)
1312 assert (n->composite.arg_cnt == 2);
1313 assert (n->composite.args[1]->type == OP_pos_int);
1314 n_before = n->composite.args[1]->integer.i;
1315 dataset_need_lag (e->ds, n_before);
1319 ds_destroy (&func_name);
1324 ds_destroy (&func_name);
1328 /* Utility functions. */
1330 static struct expression *
1331 expr_create (struct dataset *ds)
1333 struct pool *pool = pool_create ();
1334 struct expression *e = pool_alloc (pool, sizeof *e);
1335 e->expr_pool = pool;
1337 e->eval_pool = pool_create_subpool (e->expr_pool);
1340 e->op_cnt = e->op_cap = 0;
1345 expr_node_returns (const union any_node *n)
1348 assert (is_operation (n->type));
1349 if (is_atom (n->type))
1351 else if (is_composite (n->type))
1352 return operations[n->type].returns;
1358 atom_type_name (atom_type type)
1360 assert (is_atom (type));
1361 return operations[type].name;
1365 expr_allocate_nullary (struct expression *e, operation_type op)
1367 return expr_allocate_composite (e, op, NULL, 0);
1371 expr_allocate_unary (struct expression *e, operation_type op,
1372 union any_node *arg0)
1374 return expr_allocate_composite (e, op, &arg0, 1);
1378 expr_allocate_binary (struct expression *e, operation_type op,
1379 union any_node *arg0, union any_node *arg1)
1381 union any_node *args[2];
1384 return expr_allocate_composite (e, op, args, 2);
1388 is_valid_node (union any_node *n)
1390 const struct operation *op;
1394 assert (is_operation (n->type));
1395 op = &operations[n->type];
1397 if (!is_atom (n->type))
1399 struct composite_node *c = &n->composite;
1401 assert (is_composite (n->type));
1402 assert (c->arg_cnt >= op->arg_cnt);
1403 for (i = 0; i < op->arg_cnt; i++)
1404 assert (is_compatible (op->args[i], expr_node_returns (c->args[i])));
1405 if (c->arg_cnt > op->arg_cnt && !is_operator (n->type))
1407 assert (op->flags & OPF_ARRAY_OPERAND);
1408 for (i = 0; i < c->arg_cnt; i++)
1409 assert (is_compatible (op->args[op->arg_cnt - 1],
1410 expr_node_returns (c->args[i])));
1418 expr_allocate_composite (struct expression *e, operation_type op,
1419 union any_node **args, size_t arg_cnt)
1424 n = pool_alloc (e->expr_pool, sizeof n->composite);
1426 n->composite.arg_cnt = arg_cnt;
1427 n->composite.args = pool_alloc (e->expr_pool,
1428 sizeof *n->composite.args * arg_cnt);
1429 for (i = 0; i < arg_cnt; i++)
1431 if (args[i] == NULL)
1433 n->composite.args[i] = args[i];
1435 memcpy (n->composite.args, args, sizeof *n->composite.args * arg_cnt);
1436 n->composite.min_valid = 0;
1437 assert (is_valid_node (n));
1442 expr_allocate_number (struct expression *e, double d)
1444 union any_node *n = pool_alloc (e->expr_pool, sizeof n->number);
1445 n->type = OP_number;
1451 expr_allocate_boolean (struct expression *e, double b)
1453 union any_node *n = pool_alloc (e->expr_pool, sizeof n->number);
1454 assert (b == 0.0 || b == 1.0 || b == SYSMIS);
1455 n->type = OP_boolean;
1461 expr_allocate_integer (struct expression *e, int i)
1463 union any_node *n = pool_alloc (e->expr_pool, sizeof n->integer);
1464 n->type = OP_integer;
1470 expr_allocate_pos_int (struct expression *e, int i)
1472 union any_node *n = pool_alloc (e->expr_pool, sizeof n->integer);
1474 n->type = OP_pos_int;
1480 expr_allocate_vector (struct expression *e, const struct vector *vector)
1482 union any_node *n = pool_alloc (e->expr_pool, sizeof n->vector);
1483 n->type = OP_vector;
1484 n->vector.v = vector;
1489 expr_allocate_string (struct expression *e, struct substring s)
1491 union any_node *n = pool_alloc (e->expr_pool, sizeof n->string);
1492 n->type = OP_string;
1498 expr_allocate_variable (struct expression *e, const struct variable *v)
1500 union any_node *n = pool_alloc (e->expr_pool, sizeof n->variable);
1501 n->type = var_is_numeric (v) ? OP_num_var : OP_str_var;
1507 expr_allocate_format (struct expression *e, const struct fmt_spec *format)
1509 union any_node *n = pool_alloc (e->expr_pool, sizeof n->format);
1510 n->type = OP_format;
1511 n->format.f = *format;
1515 /* Allocates a unary composite node that represents the value of
1516 variable V in expression E. */
1517 static union any_node *
1518 allocate_unary_variable (struct expression *e, const struct variable *v)
1521 return expr_allocate_unary (e, var_is_numeric (v) ? OP_NUM_VAR : OP_STR_VAR,
1522 expr_allocate_variable (e, v));
1525 /* Export function details to other modules. */
1527 /* Returns the operation structure for the function with the
1529 const struct operation *
1530 expr_get_function (size_t idx)
1532 assert (idx < OP_function_cnt);
1533 return &operations[OP_function_first + idx];
1536 /* Returns the number of expression functions. */
1538 expr_get_function_cnt (void)
1540 return OP_function_cnt;
1543 /* Returns the name of operation OP. */
1545 expr_operation_get_name (const struct operation *op)
1550 /* Returns the human-readable prototype for operation OP. */
1552 expr_operation_get_prototype (const struct operation *op)
1554 return op->prototype;
1557 /* Returns the number of arguments for operation OP. */
1559 expr_operation_get_arg_cnt (const struct operation *op)