1 /* PSPP - computes sample statistics.
2 Copyright (C) 1997-9, 2000, 2006 Free Software Foundation, Inc.
4 This program is free software; you can redistribute it and/or
5 modify it under the terms of the GNU General Public License as
6 published by the Free Software Foundation; either version 2 of the
7 License, or (at your option) any later version.
9 This program is distributed in the hope that it will be useful, but
10 WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 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, write to the Free Software
16 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
29 #include <data/case.h>
30 #include <data/dictionary.h>
31 #include <data/settings.h>
32 #include <data/variable.h>
33 #include <language/lexer/format-parser.h>
34 #include <language/lexer/lexer.h>
35 #include <language/lexer/variable-parser.h>
36 #include <libpspp/alloc.h>
37 #include <libpspp/array.h>
38 #include <libpspp/assertion.h>
39 #include <libpspp/message.h>
40 #include <libpspp/misc.h>
41 #include <libpspp/pool.h>
42 #include <libpspp/str.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 *,
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. */
348 *node = expr_allocate_unary (e, OP_NUM_TO_BOOLEAN, *node);
358 if ((*node)->type == OP_format
359 && fmt_check_input (&(*node)->format.f)
360 && fmt_check_type_compat (&(*node)->format.f, VAR_NUMERIC))
364 (*node)->type = OP_ni_format;
372 if ((*node)->type == OP_format
373 && fmt_check_output (&(*node)->format.f)
374 && fmt_check_type_compat (&(*node)->format.f, VAR_NUMERIC))
378 (*node)->type = OP_no_format;
385 if ((*node)->type == OP_NUM_VAR)
388 *node = (*node)->composite.args[0];
394 if ((*node)->type == OP_STR_VAR)
397 *node = (*node)->composite.args[0];
403 if ((*node)->type == OP_NUM_VAR || (*node)->type == OP_STR_VAR)
406 *node = (*node)->composite.args[0];
412 if ((*node)->type == OP_number
413 && floor ((*node)->number.n) == (*node)->number.n
414 && (*node)->number.n > 0 && (*node)->number.n < INT_MAX)
417 *node = expr_allocate_pos_int (e, (*node)->number.n);
428 msg (SE, _("Type mismatch while applying %s operator: "
429 "cannot convert %s to %s."),
431 atom_type_name (actual_type), atom_type_name (required_type));
437 /* Coerces *NODE to type REQUIRED_TYPE, and returns success. If
438 *NODE cannot be coerced to the desired type then we issue an
439 error message about operator OPERATOR_NAME and free *NODE. */
441 type_coercion (struct expression *e,
442 atom_type required_type, union any_node **node,
443 const char *operator_name)
445 return type_coercion_core (e, required_type, node, operator_name, true);
448 /* Coerces *NODE to type REQUIRED_TYPE.
449 Assert-fails if the coercion is disallowed. */
451 type_coercion_assert (struct expression *e,
452 atom_type required_type, union any_node **node)
454 int success = type_coercion_core (e, required_type, node, NULL, true);
458 /* Returns true if *NODE may be coerced to type REQUIRED_TYPE,
461 is_coercible (atom_type required_type, union any_node *const *node)
463 return type_coercion_core (NULL, required_type,
464 (union any_node **) node, NULL, false);
467 /* Returns true if ACTUAL_TYPE is a kind of REQUIRED_TYPE, false
470 is_compatible (atom_type required_type, atom_type actual_type)
472 return (required_type == actual_type
473 || (required_type == OP_var
474 && (actual_type == OP_num_var || actual_type == OP_str_var)));
477 /* How to parse an operator. */
480 int token; /* Token representing operator. */
481 operation_type type; /* Operation type representing operation. */
482 const char *name; /* Name of operator. */
485 /* Attempts to match the current token against the tokens for the
486 OP_CNT operators in OPS[]. If successful, returns true
487 and, if OPERATOR is non-null, sets *OPERATOR to the operator.
488 On failure, returns false and, if OPERATOR is non-null, sets
489 *OPERATOR to a null pointer. */
491 match_operator (struct lexer *lexer, const struct operator ops[], size_t op_cnt,
492 const struct operator **operator)
494 const struct operator *op;
496 for (op = ops; op < ops + op_cnt; op++)
498 if (op->token == '-')
499 lex_negative_to_dash (lexer);
500 if (lex_match (lexer, op->token))
502 if (operator != NULL)
507 if (operator != NULL)
513 check_operator (const struct operator *op, int arg_cnt, atom_type arg_type)
515 const struct operation *o;
519 o = &operations[op->type];
520 assert (o->arg_cnt == arg_cnt);
521 assert ((o->flags & OPF_ARRAY_OPERAND) == 0);
522 for (i = 0; i < arg_cnt; i++)
523 assert (is_compatible (arg_type, o->args[i]));
528 check_binary_operators (const struct operator ops[], size_t op_cnt,
533 for (i = 0; i < op_cnt; i++)
534 check_operator (&ops[i], 2, arg_type);
539 get_operand_type (const struct operator *op)
541 return operations[op->type].args[0];
544 /* Parses a chain of left-associative operator/operand pairs.
545 There are OP_CNT operators, specified in OPS[]. The
546 operators' operands must all be the same type. The next
547 higher level is parsed by PARSE_NEXT_LEVEL. If CHAIN_WARNING
548 is non-null, then it will be issued as a warning if more than
549 one operator/operand pair is parsed. */
550 static union any_node *
551 parse_binary_operators (struct lexer *lexer, struct expression *e, union any_node *node,
552 const struct operator ops[], size_t op_cnt,
553 parse_recursively_func *parse_next_level,
554 const char *chain_warning)
556 atom_type operand_type = get_operand_type (&ops[0]);
558 const struct operator *operator;
560 assert (check_binary_operators (ops, op_cnt, operand_type));
564 for (op_count = 0; match_operator (lexer, ops, op_cnt, &operator); op_count++)
568 /* Convert the left-hand side to type OPERAND_TYPE. */
569 if (!type_coercion (e, operand_type, &node, operator->name))
572 /* Parse the right-hand side and coerce to type
574 rhs = parse_next_level (lexer, e);
575 if (!type_coercion (e, operand_type, &rhs, operator->name))
577 node = expr_allocate_binary (e, operator->type, node, rhs);
580 if (op_count > 1 && chain_warning != NULL)
581 msg (SW, chain_warning);
586 static union any_node *
587 parse_inverting_unary_operator (struct lexer *lexer, struct expression *e,
588 const struct operator *op,
589 parse_recursively_func *parse_next_level)
591 union any_node *node;
594 check_operator (op, 1, get_operand_type (op));
597 while (match_operator (lexer, op, 1, NULL))
600 node = parse_next_level (lexer, e);
602 && type_coercion (e, get_operand_type (op), &node, op->name)
603 && op_count % 2 != 0)
604 return expr_allocate_unary (e, op->type, node);
609 /* Parses the OR level. */
610 static union any_node *
611 parse_or (struct lexer *lexer, struct expression *e)
613 static const struct operator op =
614 { T_OR, OP_OR, "logical disjunction (\"OR\")" };
616 return parse_binary_operators (lexer, e, parse_and (lexer, e), &op, 1, parse_and, NULL);
619 /* Parses the AND level. */
620 static union any_node *
621 parse_and (struct lexer *lexer, struct expression *e)
623 static const struct operator op =
624 { T_AND, OP_AND, "logical conjunction (\"AND\")" };
626 return parse_binary_operators (lexer, e, parse_not (lexer, e),
627 &op, 1, parse_not, NULL);
630 /* Parses the NOT level. */
631 static union any_node *
632 parse_not (struct lexer *lexer, struct expression *e)
634 static const struct operator op
635 = { T_NOT, OP_NOT, "logical negation (\"NOT\")" };
636 return parse_inverting_unary_operator (lexer, e, &op, parse_rel);
639 /* Parse relational operators. */
640 static union any_node *
641 parse_rel (struct lexer *lexer, struct expression *e)
643 const char *chain_warning =
644 _("Chaining relational operators (e.g. \"a < b < c\") will "
645 "not produce the mathematically expected result. "
646 "Use the AND logical operator to fix the problem "
647 "(e.g. \"a < b AND b < c\"). "
648 "If chaining is really intended, parentheses will disable "
649 "this warning (e.g. \"(a < b) < c\".)");
651 union any_node *node = parse_add (lexer, e);
656 switch (expr_node_returns (node))
661 static const struct operator ops[] =
663 { '=', OP_EQ, "numeric equality (\"=\")" },
664 { T_EQ, OP_EQ, "numeric equality (\"EQ\")" },
665 { T_GE, OP_GE, "numeric greater-than-or-equal-to (\">=\")" },
666 { T_GT, OP_GT, "numeric greater than (\">\")" },
667 { T_LE, OP_LE, "numeric less-than-or-equal-to (\"<=\")" },
668 { T_LT, OP_LT, "numeric less than (\"<\")" },
669 { T_NE, OP_NE, "numeric inequality (\"<>\")" },
672 return parse_binary_operators (lexer, e, node, ops,
673 sizeof ops / sizeof *ops,
674 parse_add, chain_warning);
679 static const struct operator ops[] =
681 { '=', OP_EQ_STRING, "string equality (\"=\")" },
682 { T_EQ, OP_EQ_STRING, "string equality (\"EQ\")" },
683 { T_GE, OP_GE_STRING, "string greater-than-or-equal-to (\">=\")" },
684 { T_GT, OP_GT_STRING, "string greater than (\">\")" },
685 { T_LE, OP_LE_STRING, "string less-than-or-equal-to (\"<=\")" },
686 { T_LT, OP_LT_STRING, "string less than (\"<\")" },
687 { T_NE, OP_NE_STRING, "string inequality (\"<>\")" },
690 return parse_binary_operators (lexer, e, node, ops,
691 sizeof ops / sizeof *ops,
692 parse_add, chain_warning);
700 /* Parses the addition and subtraction level. */
701 static union any_node *
702 parse_add (struct lexer *lexer, struct expression *e)
704 static const struct operator ops[] =
706 { '+', OP_ADD, "addition (\"+\")" },
707 { '-', OP_SUB, "subtraction (\"-\")" },
710 return parse_binary_operators (lexer, e, parse_mul (lexer, e),
711 ops, sizeof ops / sizeof *ops,
715 /* Parses the multiplication and division level. */
716 static union any_node *
717 parse_mul (struct lexer *lexer, struct expression *e)
719 static const struct operator ops[] =
721 { '*', OP_MUL, "multiplication (\"*\")" },
722 { '/', OP_DIV, "division (\"/\")" },
725 return parse_binary_operators (lexer, e, parse_neg (lexer, e),
726 ops, sizeof ops / sizeof *ops,
730 /* Parses the unary minus level. */
731 static union any_node *
732 parse_neg (struct lexer *lexer, struct expression *e)
734 static const struct operator op = { '-', OP_NEG, "negation (\"-\")" };
735 return parse_inverting_unary_operator (lexer, e, &op, parse_exp);
738 static union any_node *
739 parse_exp (struct lexer *lexer, struct expression *e)
741 static const struct operator op =
742 { T_EXP, OP_POW, "exponentiation (\"**\")" };
744 const char *chain_warning =
745 _("The exponentiation operator (\"**\") is left-associative, "
746 "even though right-associative semantics are more useful. "
747 "That is, \"a**b**c\" equals \"(a**b)**c\", not as \"a**(b**c)\". "
748 "To disable this warning, insert parentheses.");
750 return parse_binary_operators (lexer, e, parse_primary (lexer, e), &op, 1,
751 parse_primary, chain_warning);
754 /* Parses system variables. */
755 static union any_node *
756 parse_sysvar (struct lexer *lexer, struct expression *e)
758 if (lex_match_id (lexer, "$CASENUM"))
759 return expr_allocate_nullary (e, OP_CASENUM);
760 else if (lex_match_id (lexer, "$DATE"))
762 static const char *months[12] =
764 "JAN", "FEB", "MAR", "APR", "MAY", "JUN",
765 "JUL", "AUG", "SEP", "OCT", "NOV", "DEC",
768 time_t last_proc_time = time_of_last_procedure (e->ds);
772 time = localtime (&last_proc_time);
773 sprintf (temp_buf, "%02d %s %02d", abs (time->tm_mday) % 100,
774 months[abs (time->tm_mon) % 12], abs (time->tm_year) % 100);
776 return expr_allocate_string_buffer (e, temp_buf, strlen (temp_buf));
778 else if (lex_match_id (lexer, "$TRUE"))
779 return expr_allocate_boolean (e, 1.0);
780 else if (lex_match_id (lexer, "$FALSE"))
781 return expr_allocate_boolean (e, 0.0);
782 else if (lex_match_id (lexer, "$SYSMIS"))
783 return expr_allocate_number (e, SYSMIS);
784 else if (lex_match_id (lexer, "$JDATE"))
786 time_t time = time_of_last_procedure (e->ds);
787 struct tm *tm = localtime (&time);
788 return expr_allocate_number (e, expr_ymd_to_ofs (tm->tm_year + 1900,
792 else if (lex_match_id (lexer, "$TIME"))
794 time_t time = time_of_last_procedure (e->ds);
795 struct tm *tm = localtime (&time);
796 return expr_allocate_number (e,
797 expr_ymd_to_date (tm->tm_year + 1900,
800 + tm->tm_hour * 60 * 60.
804 else if (lex_match_id (lexer, "$LENGTH"))
805 return expr_allocate_number (e, get_viewlength ());
806 else if (lex_match_id (lexer, "$WIDTH"))
807 return expr_allocate_number (e, get_viewwidth ());
810 msg (SE, _("Unknown system variable %s."), lex_tokid (lexer));
815 /* Parses numbers, varnames, etc. */
816 static union any_node *
817 parse_primary (struct lexer *lexer, struct expression *e)
819 switch (lex_token (lexer))
822 if (lex_look_ahead (lexer) == '(')
824 /* An identifier followed by a left parenthesis may be
825 a vector element reference. If not, it's a function
827 if (e->ds != NULL && dict_lookup_vector (dataset_dict (e->ds), lex_tokid (lexer)) != NULL)
828 return parse_vector_element (lexer, e);
830 return parse_function (lexer, e);
832 else if (lex_tokid (lexer)[0] == '$')
834 /* $ at the beginning indicates a system variable. */
835 return parse_sysvar (lexer, e);
837 else if (e->ds != NULL && dict_lookup_var (dataset_dict (e->ds), lex_tokid (lexer)))
839 /* It looks like a user variable.
840 (It could be a format specifier, but we'll assume
841 it's a variable unless proven otherwise. */
842 return allocate_unary_variable (e, parse_variable (lexer, dataset_dict (e->ds)));
846 /* Try to parse it as a format specifier. */
851 ok = parse_format_specifier (lexer, &fmt);
855 return expr_allocate_format (e, &fmt);
857 /* All attempts failed. */
858 msg (SE, _("Unknown identifier %s."), lex_tokid (lexer));
866 union any_node *node = expr_allocate_number (e, lex_tokval (lexer) );
873 union any_node *node = expr_allocate_string_buffer (
874 e, ds_cstr (lex_tokstr (lexer) ), ds_length (lex_tokstr (lexer) ));
881 union any_node *node;
883 node = parse_or (lexer, e);
884 if (node != NULL && !lex_match (lexer, ')'))
886 lex_error (lexer, _("expecting `)'"));
893 lex_error (lexer, _("in expression"));
898 static union any_node *
899 parse_vector_element (struct lexer *lexer, struct expression *e)
901 const struct vector *vector;
902 union any_node *element;
904 /* Find vector, skip token.
905 The caller must already have verified that the current token
906 is the name of a vector. */
907 vector = dict_lookup_vector (dataset_dict (e->ds), lex_tokid (lexer));
908 assert (vector != NULL);
911 /* Skip left parenthesis token.
912 The caller must have verified that the lookahead is a left
914 assert (lex_token (lexer) == '(');
917 element = parse_or (lexer, e);
918 if (!type_coercion (e, OP_number, &element, "vector indexing")
919 || !lex_match (lexer, ')'))
922 return expr_allocate_binary (e, (vector_get_type (vector) == VAR_NUMERIC
923 ? OP_VEC_ELEM_NUM : OP_VEC_ELEM_STR),
924 element, expr_allocate_vector (e, vector));
927 /* Individual function parsing. */
929 const struct operation operations[OP_first + OP_cnt] = {
934 word_matches (const char **test, const char **name)
936 size_t test_len = strcspn (*test, ".");
937 size_t name_len = strcspn (*name, ".");
938 if (test_len == name_len)
940 if (buf_compare_case (*test, *name, test_len))
943 else if (test_len < 3 || test_len > name_len)
947 if (buf_compare_case (*test, *name, test_len))
953 if (**test != **name)
965 compare_names (const char *test, const char *name, bool abbrev_ok)
972 if (!word_matches (&test, &name))
974 if (*name == '\0' && *test == '\0')
980 compare_strings (const char *test, const char *name, bool abbrev_ok UNUSED)
982 return strcasecmp (test, name);
986 lookup_function_helper (const char *name,
987 int (*compare) (const char *test, const char *name,
989 const struct operation **first,
990 const struct operation **last)
992 const struct operation *f;
994 for (f = operations + OP_function_first;
995 f <= operations + OP_function_last; f++)
996 if (!compare (name, f->name, !(f->flags & OPF_NO_ABBREV)))
1000 while (f <= operations + OP_function_last
1001 && !compare (name, f->name, !(f->flags & OPF_NO_ABBREV)))
1012 lookup_function (const char *name,
1013 const struct operation **first,
1014 const struct operation **last)
1016 *first = *last = NULL;
1017 return (lookup_function_helper (name, compare_strings, first, last)
1018 || lookup_function_helper (name, compare_names, first, last));
1022 extract_min_valid (char *s)
1024 char *p = strrchr (s, '.');
1026 || p[1] < '0' || p[1] > '9'
1027 || strspn (p + 1, "0123456789") != strlen (p + 1))
1030 return atoi (p + 1);
1034 function_arg_type (const struct operation *f, size_t arg_idx)
1036 assert (arg_idx < f->arg_cnt || (f->flags & OPF_ARRAY_OPERAND));
1038 return f->args[arg_idx < f->arg_cnt ? arg_idx : f->arg_cnt - 1];
1042 match_function (union any_node **args, int arg_cnt, const struct operation *f)
1046 if (arg_cnt < f->arg_cnt
1047 || (arg_cnt > f->arg_cnt && (f->flags & OPF_ARRAY_OPERAND) == 0)
1048 || arg_cnt - (f->arg_cnt - 1) < f->array_min_elems)
1051 for (i = 0; i < arg_cnt; i++)
1052 if (!is_coercible (function_arg_type (f, i), &args[i]))
1059 coerce_function_args (struct expression *e, const struct operation *f,
1060 union any_node **args, size_t arg_cnt)
1064 for (i = 0; i < arg_cnt; i++)
1065 type_coercion_assert (e, function_arg_type (f, i), &args[i]);
1069 validate_function_args (const struct operation *f, int arg_cnt, int min_valid)
1071 int array_arg_cnt = arg_cnt - (f->arg_cnt - 1);
1072 if (array_arg_cnt < f->array_min_elems)
1074 msg (SE, _("%s must have at least %d arguments in list."),
1075 f->prototype, f->array_min_elems);
1079 if ((f->flags & OPF_ARRAY_OPERAND)
1080 && array_arg_cnt % f->array_granularity != 0)
1082 if (f->array_granularity == 2)
1083 msg (SE, _("%s must have even number of arguments in list."),
1086 msg (SE, _("%s must have multiple of %d arguments in list."),
1087 f->prototype, f->array_granularity);
1091 if (min_valid != -1)
1093 if (f->array_min_elems == 0)
1095 assert ((f->flags & OPF_MIN_VALID) == 0);
1096 msg (SE, _("%s function does not accept a minimum valid "
1097 "argument count."), f->prototype);
1102 assert (f->flags & OPF_MIN_VALID);
1103 if (array_arg_cnt < f->array_min_elems)
1105 msg (SE, _("%s requires at least %d valid arguments in list."),
1106 f->prototype, f->array_min_elems);
1109 else if (min_valid > array_arg_cnt)
1111 msg (SE, _("With %s, "
1112 "using minimum valid argument count of %d "
1113 "does not make sense when passing only %d "
1114 "arguments in list."),
1115 f->prototype, min_valid, array_arg_cnt);
1125 add_arg (union any_node ***args, int *arg_cnt, int *arg_cap,
1126 union any_node *arg)
1128 if (*arg_cnt >= *arg_cap)
1131 *args = xrealloc (*args, sizeof **args * *arg_cap);
1134 (*args)[(*arg_cnt)++] = arg;
1138 put_invocation (struct string *s,
1139 const char *func_name, union any_node **args, size_t arg_cnt)
1143 ds_put_format (s, "%s(", func_name);
1144 for (i = 0; i < arg_cnt; i++)
1147 ds_put_cstr (s, ", ");
1148 ds_put_cstr (s, operations[expr_node_returns (args[i])].prototype);
1150 ds_put_char (s, ')');
1154 no_match (const char *func_name,
1155 union any_node **args, size_t arg_cnt,
1156 const struct operation *first, const struct operation *last)
1159 const struct operation *f;
1163 if (last - first == 1)
1165 ds_put_format (&s, _("Type mismatch invoking %s as "), first->prototype);
1166 put_invocation (&s, func_name, args, arg_cnt);
1170 ds_put_cstr (&s, _("Function invocation "));
1171 put_invocation (&s, func_name, args, arg_cnt);
1172 ds_put_cstr (&s, _(" does not match any known function. Candidates are:"));
1174 for (f = first; f < last; f++)
1175 ds_put_format (&s, "\n%s", f->prototype);
1177 ds_put_char (&s, '.');
1179 msg (SE, "%s", ds_cstr (&s));
1184 static union any_node *
1185 parse_function (struct lexer *lexer, struct expression *e)
1188 const struct operation *f, *first, *last;
1190 union any_node **args = NULL;
1194 struct string func_name;
1198 ds_init_string (&func_name, lex_tokstr (lexer));
1199 min_valid = extract_min_valid (ds_cstr (lex_tokstr (lexer)));
1200 if (!lookup_function (ds_cstr (lex_tokstr (lexer)), &first, &last))
1202 msg (SE, _("No function or vector named %s."), ds_cstr (lex_tokstr (lexer)));
1203 ds_destroy (&func_name);
1208 if (!lex_force_match (lexer, '('))
1210 ds_destroy (&func_name);
1215 arg_cnt = arg_cap = 0;
1216 if (lex_token (lexer) != ')')
1219 if (lex_token (lexer) == T_ID
1220 && toupper (lex_look_ahead (lexer)) == 'T')
1222 struct variable **vars;
1226 if (!parse_variables (lexer, dataset_dict (e->ds), &vars, &var_cnt, PV_SINGLE))
1228 for (i = 0; i < var_cnt; i++)
1229 add_arg (&args, &arg_cnt, &arg_cap,
1230 allocate_unary_variable (e, vars[i]));
1235 union any_node *arg = parse_or (lexer, e);
1239 add_arg (&args, &arg_cnt, &arg_cap, arg);
1241 if (lex_match (lexer, ')'))
1243 else if (!lex_match (lexer, ','))
1245 lex_error (lexer, _("expecting `,' or `)' invoking %s function"),
1251 for (f = first; f < last; f++)
1252 if (match_function (args, arg_cnt, f))
1256 no_match (ds_cstr (&func_name), args, arg_cnt, first, last);
1260 coerce_function_args (e, f, args, arg_cnt);
1261 if (!validate_function_args (f, arg_cnt, min_valid))
1264 if ((f->flags & OPF_EXTENSION) && get_syntax () == COMPATIBLE)
1265 msg (SW, _("%s is a PSPP extension."), f->prototype);
1266 if (f->flags & OPF_UNIMPLEMENTED)
1268 msg (SE, _("%s is not yet implemented."), f->prototype);
1271 if ((f->flags & OPF_PERM_ONLY) &&
1272 proc_in_temporary_transformations (e->ds))
1274 msg (SE, _("%s may not appear after TEMPORARY."), f->prototype);
1278 n = expr_allocate_composite (e, f - operations, args, arg_cnt);
1279 n->composite.min_valid = min_valid != -1 ? min_valid : f->array_min_elems;
1281 if (n->type == OP_LAG_Vn || n->type == OP_LAG_Vs)
1282 dataset_need_lag (e->ds, 1);
1283 else if (n->type == OP_LAG_Vnn || n->type == OP_LAG_Vsn)
1286 assert (n->composite.arg_cnt == 2);
1287 assert (n->composite.args[1]->type == OP_pos_int);
1288 n_before = n->composite.args[1]->integer.i;
1289 dataset_need_lag (e->ds, n_before);
1293 ds_destroy (&func_name);
1298 ds_destroy (&func_name);
1302 /* Utility functions. */
1304 static struct expression *
1305 expr_create (struct dataset *ds)
1307 struct pool *pool = pool_create ();
1308 struct expression *e = pool_alloc (pool, sizeof *e);
1309 e->expr_pool = pool;
1311 e->eval_pool = pool_create_subpool (e->expr_pool);
1314 e->op_cnt = e->op_cap = 0;
1319 expr_node_returns (const union any_node *n)
1322 assert (is_operation (n->type));
1323 if (is_atom (n->type))
1325 else if (is_composite (n->type))
1326 return operations[n->type].returns;
1332 atom_type_name (atom_type type)
1334 assert (is_atom (type));
1335 return operations[type].name;
1339 expr_allocate_nullary (struct expression *e, operation_type op)
1341 return expr_allocate_composite (e, op, NULL, 0);
1345 expr_allocate_unary (struct expression *e, operation_type op,
1346 union any_node *arg0)
1348 return expr_allocate_composite (e, op, &arg0, 1);
1352 expr_allocate_binary (struct expression *e, operation_type op,
1353 union any_node *arg0, union any_node *arg1)
1355 union any_node *args[2];
1358 return expr_allocate_composite (e, op, args, 2);
1362 is_valid_node (union any_node *n)
1364 const struct operation *op;
1368 assert (is_operation (n->type));
1369 op = &operations[n->type];
1371 if (!is_atom (n->type))
1373 struct composite_node *c = &n->composite;
1375 assert (is_composite (n->type));
1376 assert (c->arg_cnt >= op->arg_cnt);
1377 for (i = 0; i < op->arg_cnt; i++)
1378 assert (is_compatible (op->args[i], expr_node_returns (c->args[i])));
1379 if (c->arg_cnt > op->arg_cnt && !is_operator (n->type))
1381 assert (op->flags & OPF_ARRAY_OPERAND);
1382 for (i = 0; i < c->arg_cnt; i++)
1383 assert (is_compatible (op->args[op->arg_cnt - 1],
1384 expr_node_returns (c->args[i])));
1392 expr_allocate_composite (struct expression *e, operation_type op,
1393 union any_node **args, size_t arg_cnt)
1398 n = pool_alloc (e->expr_pool, sizeof n->composite);
1400 n->composite.arg_cnt = arg_cnt;
1401 n->composite.args = pool_alloc (e->expr_pool,
1402 sizeof *n->composite.args * arg_cnt);
1403 for (i = 0; i < arg_cnt; i++)
1405 if (args[i] == NULL)
1407 n->composite.args[i] = args[i];
1409 memcpy (n->composite.args, args, sizeof *n->composite.args * arg_cnt);
1410 n->composite.min_valid = 0;
1411 assert (is_valid_node (n));
1416 expr_allocate_number (struct expression *e, double d)
1418 union any_node *n = pool_alloc (e->expr_pool, sizeof n->number);
1419 n->type = OP_number;
1425 expr_allocate_boolean (struct expression *e, double b)
1427 union any_node *n = pool_alloc (e->expr_pool, sizeof n->number);
1428 assert (b == 0.0 || b == 1.0 || b == SYSMIS);
1429 n->type = OP_boolean;
1435 expr_allocate_integer (struct expression *e, int i)
1437 union any_node *n = pool_alloc (e->expr_pool, sizeof n->integer);
1438 n->type = OP_integer;
1444 expr_allocate_pos_int (struct expression *e, int i)
1446 union any_node *n = pool_alloc (e->expr_pool, sizeof n->integer);
1448 n->type = OP_pos_int;
1454 expr_allocate_vector (struct expression *e, const struct vector *vector)
1456 union any_node *n = pool_alloc (e->expr_pool, sizeof n->vector);
1457 n->type = OP_vector;
1458 n->vector.v = vector;
1463 expr_allocate_string_buffer (struct expression *e,
1464 const char *string, size_t length)
1466 union any_node *n = pool_alloc (e->expr_pool, sizeof n->string);
1467 n->type = OP_string;
1468 if (length > MAX_STRING)
1469 length = MAX_STRING;
1470 n->string.s = copy_string (e, string, length);
1475 expr_allocate_string (struct expression *e, struct substring s)
1477 union any_node *n = pool_alloc (e->expr_pool, sizeof n->string);
1478 n->type = OP_string;
1484 expr_allocate_variable (struct expression *e, struct variable *v)
1486 union any_node *n = pool_alloc (e->expr_pool, sizeof n->variable);
1487 n->type = var_is_numeric (v) ? OP_num_var : OP_str_var;
1493 expr_allocate_format (struct expression *e, const struct fmt_spec *format)
1495 union any_node *n = pool_alloc (e->expr_pool, sizeof n->format);
1496 n->type = OP_format;
1497 n->format.f = *format;
1501 /* Allocates a unary composite node that represents the value of
1502 variable V in expression E. */
1503 static union any_node *
1504 allocate_unary_variable (struct expression *e, struct variable *v)
1507 return expr_allocate_unary (e, var_is_numeric (v) ? OP_NUM_VAR : OP_STR_VAR,
1508 expr_allocate_variable (e, v));