1 /* PSPP - computes sample statistics.
2 Copyright (C) 1997-9, 2000 Free Software Foundation, Inc.
3 Written by Ben Pfaff <blp@gnu.org>.
5 This program is free software; you can redistribute it and/or
6 modify it under the terms of the GNU General Public License as
7 published by the Free Software Foundation; either version 2 of the
8 License, or (at your option) any later version.
10 This program is distributed in the hope that it will be useful, but
11 WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 General Public License for more details.
15 You should have received a copy of the GNU General Public License
16 along with this program; if not, write to the Free Software
17 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
27 #include "algorithm.h"
40 /* Recursive descent parser in order of increasing precedence. */
41 typedef enum expr_type parse_recursively_func (union any_node **);
42 static parse_recursively_func parse_or, parse_and, parse_not;
43 static parse_recursively_func parse_rel, parse_add, parse_mul;
44 static parse_recursively_func parse_neg, parse_exp;
45 static parse_recursively_func parse_primary, parse_function;
47 /* Utility functions. */
48 static const char *expr_type_name (enum expr_type type);
49 static const char *var_type_name (int var_type);
50 static void make_bool (union any_node **n);
51 static union any_node *allocate_nonterminal (int op, union any_node *n);
52 static union any_node *allocate_binary_nonterminal (int op, union any_node *,
54 static union any_node *allocate_num_con (double value);
55 static union any_node *allocate_str_con (const char *string, size_t length);
56 static union any_node *allocate_var_node (int type, struct variable *);
57 static int type_check (union any_node **n,
58 enum expr_type actual_type,
59 enum expr_type expected_type);
61 static algo_compare_func compare_functions;
62 static void init_func_tab (void);
64 /* Public functions. */
67 expr_free (struct expression *e)
77 pool_destroy (e->pool);
82 expr_parse (enum expr_type expected_type)
86 enum expr_type actual_type;
87 int optimize = (expected_type & EXPR_NO_OPTIMIZE) == 0;
89 expected_type &= ~EXPR_NO_OPTIMIZE;
91 /* Make sure the table of functions is initialized. */
94 /* Parse the expression. */
95 actual_type = parse_or (&n);
96 if (actual_type == EXPR_ERROR)
99 /* Enforce type rules. */
100 if (!type_check (&n, actual_type, expected_type))
106 /* Optimize the expression as best we can. */
108 optimize_expression (&n);
110 /* Dump the tree-based expression to a postfix representation for
111 best evaluation speed, and destroy the tree. */
112 e = xmalloc (sizeof *e);
113 e->type = actual_type;
114 dump_expression (n, e);
120 /* Returns the type of EXPR. */
122 expr_get_type (const struct expression *expr)
124 assert (expr != NULL);
129 type_check (union any_node **n, enum expr_type actual_type, enum expr_type expected_type)
131 switch (expected_type)
135 if (actual_type == EXPR_STRING)
137 msg (SE, _("Type mismatch: expression has string type, "
138 "but a numeric value is required here."));
141 if (actual_type == EXPR_NUMERIC && expected_type == EXPR_BOOLEAN)
142 *n = allocate_nonterminal (OP_NUM_TO_BOOL, *n);
146 if (actual_type != EXPR_STRING)
148 msg (SE, _("Type mismatch: expression has numeric type, "
149 "but a string value is required here."));
164 /* Recursive-descent expression parser. */
166 /* Coerces *NODE, of type ACTUAL_TYPE, to type REQUIRED_TYPE, and
167 returns success. If ACTUAL_TYPE cannot be coerced to the
168 desired type then we issue an error message about operator
169 OPERATOR_NAME and free *NODE. */
171 type_coercion (enum expr_type actual_type, enum expr_type required_type,
172 union any_node **node,
173 const char *operator_name)
175 assert (required_type == EXPR_NUMERIC
176 || required_type == EXPR_BOOLEAN
177 || required_type == EXPR_STRING);
179 if (actual_type == required_type)
184 else if (actual_type == EXPR_ERROR)
186 /* Error already reported. */
190 else if (actual_type == EXPR_BOOLEAN && required_type == EXPR_NUMERIC)
192 /* Boolean -> numeric: nothing to do. */
195 else if (actual_type == EXPR_NUMERIC && required_type == EXPR_BOOLEAN)
197 /* Numeric -> Boolean: insert conversion. */
203 /* We want a string and got a number/Boolean, or vice versa. */
204 assert ((actual_type == EXPR_STRING) != (required_type == EXPR_STRING));
206 if (required_type == EXPR_STRING)
207 msg (SE, _("Type mismatch: operands of %s operator must be strings."),
210 msg (SE, _("Type mismatch: operands of %s operator must be numeric."),
221 int token; /* Operator token. */
222 int type; /* Operator node type. */
223 const char *name; /* Operator name. */
226 /* Attempts to match the current token against the tokens for the
227 OP_CNT operators in OPS[]. If successful, returns nonzero
228 and, if OPERATOR is non-null, sets *OPERATOR to the operator.
229 On failure, returns zero and, if OPERATOR is non-null, sets
230 *OPERATOR to a null pointer. */
232 match_operator (const struct operator ops[], size_t op_cnt,
233 const struct operator **operator)
235 const struct operator *op;
237 for (op = ops; op < ops + op_cnt; op++)
239 if (op->token == '-')
240 lex_negative_to_dash ();
241 if (lex_match (op->token))
243 if (operator != NULL)
248 if (operator != NULL)
253 /* Parses a chain of left-associative operator/operand pairs.
254 The operators' operands uniformly must be type REQUIRED_TYPE.
255 There are OP_CNT operators, specified in OPS[]. The next
256 higher level is parsed by PARSE_NEXT_LEVEL. If CHAIN_WARNING
257 is non-null, then it will be issued as a warning if more than
258 one operator/operand pair is parsed. */
259 static enum expr_type
260 parse_binary_operators (union any_node **node,
261 enum expr_type actual_type,
262 enum expr_type required_type,
263 enum expr_type result_type,
264 const struct operator ops[], size_t op_cnt,
265 parse_recursively_func *parse_next_level,
266 const char *chain_warning)
269 const struct operator *operator;
271 if (actual_type == EXPR_ERROR)
274 for (op_count = 0; match_operator (ops, op_cnt, &operator); op_count++)
278 /* Convert the left-hand side to type REQUIRED_TYPE. */
279 if (!type_coercion (actual_type, required_type, node, operator->name))
282 /* Parse the right-hand side and coerce to type
284 if (!type_coercion (parse_next_level (&rhs), required_type,
285 &rhs, operator->name))
291 *node = allocate_binary_nonterminal (operator->type, *node, rhs);
293 /* The result is of type RESULT_TYPE. */
294 actual_type = result_type;
297 if (op_count > 1 && chain_warning != NULL)
298 msg (SW, chain_warning);
303 static enum expr_type
304 parse_inverting_unary_operator (union any_node **node,
305 enum expr_type required_type,
306 const struct operator *operator,
307 parse_recursively_func *parse_next_level)
312 while (match_operator (operator, 1, NULL))
315 return parse_next_level (node);
317 if (!type_coercion (parse_next_level (node), required_type,
318 node, operator->name))
320 if (op_count % 2 != 0)
321 *node = allocate_nonterminal (operator->type, *node);
322 return required_type;
325 /* Parses the OR level. */
326 static enum expr_type
327 parse_or (union any_node **n)
329 static const struct operator ops[] =
331 { T_OR, OP_OR, "logical disjunction (\"OR\")" },
334 return parse_binary_operators (n, parse_and (n), EXPR_BOOLEAN, EXPR_BOOLEAN,
335 ops, sizeof ops / sizeof *ops,
339 /* Parses the AND level. */
340 static enum expr_type
341 parse_and (union any_node ** n)
343 static const struct operator ops[] =
345 { T_AND, OP_AND, "logical conjunction (\"AND\")" },
348 return parse_binary_operators (n, parse_not (n), EXPR_BOOLEAN, EXPR_BOOLEAN,
349 ops, sizeof ops / sizeof *ops,
353 /* Parses the NOT level. */
354 static enum expr_type
355 parse_not (union any_node ** n)
357 static const struct operator op
358 = { T_NOT, OP_NOT, "logical negation (\"NOT-\")" };
359 return parse_inverting_unary_operator (n, EXPR_BOOLEAN, &op, parse_rel);
362 /* Parse relational operators. */
363 static enum expr_type
364 parse_rel (union any_node **n)
366 static const struct operator numeric_ops[] =
368 { '=', OP_EQ, "numeric equality (\"=\")" },
369 { T_EQ, OP_EQ, "numeric equality (\"EQ\")" },
370 { T_GE, OP_GE, "numeric greater-than-or-equal-to (\">=\")" },
371 { T_GT, OP_GT, "numeric greater than (\">\")" },
372 { T_LE, OP_LE, "numeric less-than-or-equal-to (\"<=\")" },
373 { T_LT, OP_LT, "numeric less than (\"<\")" },
374 { T_NE, OP_NE, "numeric inequality (\"<>\")" },
377 static const struct operator string_ops[] =
379 { '=', OP_EQ_STRING, "string equality (\"=\")" },
380 { T_EQ, OP_EQ_STRING, "string equality (\"EQ\")" },
381 { T_GE, OP_GE_STRING, "string greater-than-or-equal-to (\">=\")" },
382 { T_GT, OP_GT_STRING, "string greater than (\">\")" },
383 { T_LE, OP_LE_STRING, "string less-than-or-equal-to (\"<=\")" },
384 { T_LT, OP_LT_STRING, "string less than (\"<\")" },
385 { T_NE, OP_NE_STRING, "string inequality (\"<>\")" },
388 int type = parse_add (n);
390 const char *chain_warning =
391 _("Chaining relational operators (e.g. \"a < b < c\") will "
392 "not produce the mathematically expected result. "
393 "Use the AND logical operator to fix the problem "
394 "(e.g. \"a < b AND b < c\"). "
395 "If chaining is really intended, parentheses will disable "
396 "this warning (e.g. \"(a < b) < c\".)");
405 return parse_binary_operators (n,
406 type, EXPR_NUMERIC, EXPR_BOOLEAN,
408 sizeof numeric_ops / sizeof *numeric_ops,
409 parse_add, chain_warning);
412 return parse_binary_operators (n,
413 type, EXPR_STRING, EXPR_BOOLEAN,
415 sizeof string_ops / sizeof *string_ops,
416 parse_add, chain_warning);
424 /* Parses the addition and subtraction level. */
425 static enum expr_type
426 parse_add (union any_node **n)
428 static const struct operator ops[] =
430 { '+', OP_ADD, "addition (\"+\")" },
431 { '-', OP_SUB, "subtraction (\"-\")-" },
434 return parse_binary_operators (n, parse_mul (n), EXPR_NUMERIC, EXPR_NUMERIC,
435 ops, sizeof ops / sizeof *ops,
439 /* Parses the multiplication and division level. */
440 static enum expr_type
441 parse_mul (union any_node ** n)
443 static const struct operator ops[] =
445 { '*', OP_MUL, "multiplication (\"*\")" },
446 { '/', OP_DIV, "division (\"/\")" },
449 return parse_binary_operators (n, parse_neg (n), EXPR_NUMERIC, EXPR_NUMERIC,
450 ops, sizeof ops / sizeof *ops,
454 /* Parses the unary minus level. */
455 static enum expr_type
456 parse_neg (union any_node **n)
458 static const struct operator op = { '-', OP_NEG, "negation (\"-\")" };
459 return parse_inverting_unary_operator (n, EXPR_NUMERIC, &op, parse_exp);
462 static enum expr_type
463 parse_exp (union any_node **n)
465 static const struct operator ops[] =
467 { T_EXP, OP_POW, "exponentiation (\"**\")" },
470 const char *chain_warning =
471 _("The exponentiation operator (\"**\") is left-associative, "
472 "even though right-associative semantics are more useful. "
473 "That is, \"a**b**c\" equals \"(a**b)**c\", not as \"a**(b**c)\". "
474 "To disable this warning, insert parentheses.");
476 return parse_binary_operators (n,
477 parse_primary (n), EXPR_NUMERIC, EXPR_NUMERIC,
478 ops, sizeof ops / sizeof *ops,
479 parse_primary, chain_warning);
482 /* Parses system variables. */
483 static enum expr_type
484 parse_sysvar (union any_node **n)
486 if (!strcmp (tokid, "$CASENUM"))
488 *n = xmalloc (sizeof (struct casenum_node));
489 (*n)->casenum.type = OP_CASENUM;
492 else if (!strcmp (tokid, "$DATE"))
494 static const char *months[12] =
496 "JAN", "FEB", "MAR", "APR", "MAY", "JUN",
497 "JUL", "AUG", "SEP", "OCT", "NOV", "DEC",
503 time = localtime (&last_vfm_invocation);
504 sprintf (temp_buf, "%02d %s %02d", abs (time->tm_mday) % 100,
505 months[abs (time->tm_mon) % 12], abs (time->tm_year) % 100);
507 *n = xmalloc (sizeof (struct str_con_node) + 8);
508 (*n)->str_con.type = OP_STR_CON;
509 (*n)->str_con.len = 9;
510 memcpy ((*n)->str_con.s, temp_buf, 9);
519 if (!strcmp (tokid, "$TRUE"))
524 else if (!strcmp (tokid, "$FALSE"))
529 else if (!strcmp (tokid, "$SYSMIS"))
531 else if (!strcmp (tokid, "$JDATE"))
533 struct tm *time = localtime (&last_vfm_invocation);
534 d = yrmoda (time->tm_year + 1900, time->tm_mon + 1, time->tm_mday);
536 else if (!strcmp (tokid, "$TIME"))
539 time = localtime (&last_vfm_invocation);
540 d = (yrmoda (time->tm_year + 1900, time->tm_mon + 1,
541 time->tm_mday) * 60. * 60. * 24.
542 + time->tm_hour * 60 * 60.
546 else if (!strcmp (tokid, "$LENGTH"))
547 d = get_viewlength ();
548 else if (!strcmp (tokid, "$WIDTH"))
549 d = get_viewwidth ();
552 msg (SE, _("Unknown system variable %s."), tokid);
556 *n = xmalloc (sizeof (struct num_con_node));
557 (*n)->num_con.type = OP_NUM_CON;
558 (*n)->num_con.value = d;
563 /* Parses numbers, varnames, etc. */
564 static enum expr_type
565 parse_primary (union any_node **n)
573 /* An identifier followed by a left parenthesis is a function
575 if (lex_look_ahead () == '(')
576 return parse_function (n);
578 /* $ at the beginning indicates a system variable. */
581 enum expr_type type = parse_sysvar (n);
586 /* Otherwise, it must be a user variable. */
587 v = dict_lookup_var (default_dict, tokid);
591 lex_error (_("expecting variable name"));
595 if (v->type == NUMERIC)
597 *n = allocate_var_node (OP_NUM_VAR, v);
602 *n = allocate_var_node (OP_STR_VAR, v);
608 *n = allocate_num_con (tokval);
614 *n = allocate_str_con (ds_c_str (&tokstr), ds_length (&tokstr));
624 if (!lex_match (')'))
626 lex_error (_("expecting `)'"));
634 lex_error (_("in expression"));
639 /* Individual function parsing. */
645 enum expr_type (*func) (const struct function *, int, union any_node **);
648 static struct function func_tab[];
649 static int func_count;
651 static int get_num_args (const struct function *, int, union any_node **);
653 static enum expr_type
654 unary_func (const struct function *f, int x UNUSED, union any_node ** n)
656 if (!get_num_args (f, 1, n))
661 static enum expr_type
662 binary_func (const struct function *f, int x UNUSED, union any_node ** n)
664 if (!get_num_args (f, 2, n))
669 static enum expr_type
670 ternary_func (const struct function *f, int x UNUSED, union any_node **n)
672 if (!get_num_args (f, 3, n))
677 static enum expr_type
678 MISSING_func (const struct function *f, int x UNUSED, union any_node **n)
680 if (!get_num_args (f, 1, n))
685 static enum expr_type
686 SYSMIS_func (const struct function *f, int x UNUSED, union any_node **n)
688 if (!get_num_args (f, 1, n))
690 if ((*n)->nonterm.arg[0]->type == OP_NUM_VAR)
692 struct variable *v = (*n)->nonterm.arg[0]->var.v;
694 *n = allocate_var_node (OP_NUM_SYS, v);
699 static enum expr_type
700 VALUE_func (const struct function *f UNUSED, int x UNUSED, union any_node **n)
702 struct variable *v = parse_variable ();
706 if (v->type == NUMERIC)
708 *n = allocate_var_node (OP_NUM_VAL, v);
713 *n = allocate_var_node (OP_STR_VAR, v);
718 static enum expr_type
719 LAG_func (const struct function *f UNUSED, int x UNUSED, union any_node **n)
721 struct variable *v = parse_variable ();
728 if (!lex_integer_p () || lex_integer () <= 0 || lex_integer () > 1000)
730 msg (SE, _("Argument 2 to LAG must be a small positive "
731 "integer constant."));
735 nlag = lex_integer ();
738 n_lag = max (nlag, n_lag);
739 *n = xmalloc (sizeof (struct lag_node));
740 (*n)->lag.type = (v->type == NUMERIC ? OP_NUM_LAG : OP_STR_LAG);
742 (*n)->lag.lag = nlag;
743 return (v->type == NUMERIC ? EXPR_NUMERIC : EXPR_STRING);
746 /* This screwball function parses n-ary operators:
748 1. NMISS, NVALID, SUM, MEAN: any number of numeric
751 2. SD, VARIANCE, CFVAR: at least two numeric arguments.
753 3. RANGE: An odd number of arguments, but at least three, and
754 all of the same type.
756 4. ANY: At least two arguments, all of the same type.
758 5. MIN, MAX: Any number of arguments, all of the same type.
760 static enum expr_type
761 nary_num_func (const struct function *f, int min_args, union any_node **n)
763 /* Argument number of current argument (used for error messages). */
766 /* Number of arguments. */
769 /* Number of arguments allocated. */
772 /* Type of arguments. */
773 int type = (f->t == OP_ANY || f->t == OP_RANGE
774 || f->t == OP_MIN || f->t == OP_MAX) ? -1 : NUMERIC;
776 *n = xmalloc (sizeof (struct nonterm_node) + sizeof (union any_node *[15]));
777 (*n)->nonterm.type = f->t;
781 /* Special case: vara TO varb. */
783 /* FIXME: Is this condition failsafe? Can we _ever_ have two
784 juxtaposed identifiers otherwise? */
785 if (token == T_ID && dict_lookup_var (default_dict, tokid) != NULL
786 && toupper (lex_look_ahead ()) == 'T')
791 int opts = PV_SINGLE;
795 else if (type == ALPHA)
797 if (!parse_variables (default_dict, &v, &nv, opts))
799 if (nv + (*n)->nonterm.n >= m)
802 *n = xrealloc (*n, (sizeof (struct nonterm_node)
803 + (m - 1) * sizeof (union any_node *)));
808 for (j = 1; j < nv; j++)
809 if (type != v[j]->type)
811 msg (SE, _("Type mismatch in argument %d of %s, which was "
812 "expected to be of %s type. It was actually "
814 arg_idx, f->s, var_type_name (type), var_type_name (v[j]->type));
819 for (j = 0; j < nv; j++)
821 union any_node **c = &(*n)->nonterm.arg[(*n)->nonterm.n++];
822 *c = allocate_var_node ((type == NUMERIC
823 ? OP_NUM_VAR : OP_STR_VAR),
830 int t = parse_or (&c);
834 if (t == EXPR_BOOLEAN)
837 msg (SE, _("%s cannot take Boolean operands."), f->s);
842 if (t == EXPR_NUMERIC)
844 else if (t == EXPR_STRING)
847 else if ((t == EXPR_NUMERIC) ^ (type == NUMERIC))
850 msg (SE, _("Type mismatch in argument %d of %s, which was "
851 "expected to be of %s type. It was actually "
853 arg_idx, f->s, var_type_name (type), expr_type_name (t));
856 if ((*n)->nonterm.n + 1 >= m)
859 *n = xrealloc (*n, (sizeof (struct nonterm_node)
860 + (m - 1) * sizeof (union any_node *)));
862 (*n)->nonterm.arg[(*n)->nonterm.n++] = c;
867 if (!lex_match (','))
869 lex_error (_("in function call"));
875 *n = xrealloc (*n, (sizeof (struct nonterm_node)
876 + ((*n)->nonterm.n) * sizeof (union any_node *)));
878 nargs = (*n)->nonterm.n;
879 if (f->t == OP_RANGE)
881 if (nargs < 3 || (nargs & 1) == 0)
883 msg (SE, _("RANGE requires an odd number of arguments, but "
888 else if (f->t == OP_SD || f->t == OP_VARIANCE
889 || f->t == OP_CFVAR || f->t == OP_ANY)
893 msg (SE, _("%s requires at least two arguments."), f->s);
898 if (f->t == OP_CFVAR || f->t == OP_SD || f->t == OP_VARIANCE)
899 min_args = max (min_args, 2);
901 min_args = max (min_args, 1);
903 /* Yes, this is admittedly a terrible crock, but it works. */
904 (*n)->nonterm.arg[(*n)->nonterm.n] = (union any_node *) min_args;
906 if (min_args > nargs)
908 msg (SE, _("%s.%d requires at least %d arguments."),
909 f->s, min_args, min_args);
913 if (f->t == OP_MIN || f->t == OP_MAX)
918 (*n)->type = OP_MIN_STRING;
919 else if (f->t == OP_MAX)
920 (*n)->type = OP_MAX_STRING;
928 else if (f->t == OP_ANY || f->t == OP_RANGE)
933 (*n)->type = OP_ANY_STRING;
934 else if (f->t == OP_RANGE)
935 (*n)->type = OP_RANGE_STRING;
949 static enum expr_type
950 CONCAT_func (const struct function *f UNUSED, int x UNUSED, union any_node **n)
956 *n = xmalloc (sizeof (struct nonterm_node) + sizeof (union any_node *[15]));
957 (*n)->nonterm.type = OP_CONCAT;
961 if ((*n)->nonterm.n >= m)
964 *n = xrealloc (*n, (sizeof (struct nonterm_node)
965 + (m - 1) * sizeof (union any_node *)));
967 type = parse_or (&(*n)->nonterm.arg[(*n)->nonterm.n]);
968 if (type == EXPR_ERROR)
971 if (type != EXPR_STRING)
973 msg (SE, _("Argument %d to CONCAT is type %s. All arguments "
974 "to CONCAT must be strings."),
975 (*n)->nonterm.n + 1, expr_type_name (type));
979 if (!lex_match (','))
982 *n = xrealloc (*n, (sizeof (struct nonterm_node)
983 + ((*n)->nonterm.n - 1) * sizeof (union any_node *)));
991 /* Parses a string function according to f->desc. f->desc[0] is the
992 return type of the function. Succeeding characters represent
993 successive args. Optional args are separated from the required
994 args by a slash (`/'). Codes are `n', numeric arg; `s', string
995 arg; and `f', format spec (this must be the last arg). If the
996 optional args are included, the type becomes f->t+1. */
997 static enum expr_type
998 generic_str_func (const struct function *f, int x UNUSED, union any_node **n)
1000 struct string_function
1003 enum expr_type return_type;
1004 const char *arg_types;
1007 static const struct string_function string_func_tab[] =
1009 {OP_INDEX_2, OP_INDEX_3, EXPR_NUMERIC, "ssN"},
1010 {OP_RINDEX_2, OP_RINDEX_3, EXPR_NUMERIC, "ssN"},
1011 {OP_LENGTH, 0, EXPR_NUMERIC, "s"},
1012 {OP_LOWER, 0, EXPR_STRING, "s"},
1013 {OP_UPPER, 0, EXPR_STRING, "s"},
1014 {OP_LPAD, 0, EXPR_STRING, "snS"},
1015 {OP_RPAD, 0, EXPR_STRING, "snS"},
1016 {OP_LTRIM, 0, EXPR_STRING, "sS"},
1017 {OP_RTRIM, 0, EXPR_STRING, "sS"},
1018 {OP_NUMBER, 0, EXPR_NUMERIC, "sf"},
1019 {OP_STRING, 0, EXPR_STRING, "nf"},
1020 {OP_SUBSTR_2, OP_SUBSTR_3, EXPR_STRING, "snN"},
1023 const int string_func_cnt = sizeof string_func_tab / sizeof *string_func_tab;
1025 const struct string_function *sf;
1028 struct nonterm_node *nonterm;
1030 /* Find string_function that corresponds to f. */
1031 for (sf = string_func_tab; sf < string_func_tab + string_func_cnt; sf++)
1034 assert (sf < string_func_tab + string_func_cnt);
1036 /* Count max number of arguments. */
1038 for (cp = sf->arg_types; *cp != '\0'; cp++)
1046 /* Allocate node. */
1047 *n = xmalloc (sizeof (struct nonterm_node)
1048 + (arg_cnt - 1) * sizeof (union any_node *));
1049 nonterm = &(*n)->nonterm;
1050 nonterm->type = sf->t1;
1053 /* Parse arguments. */
1057 if (*cp == 'n' || *cp == 's' || *cp == 'N' || *cp == 'S')
1059 enum expr_type wanted_type
1060 = *cp == 'n' || *cp == 'N' ? EXPR_NUMERIC : EXPR_STRING;
1061 enum expr_type actual_type = parse_or (&nonterm->arg[nonterm->n]);
1063 if (actual_type == EXPR_ERROR)
1065 else if (actual_type == EXPR_BOOLEAN)
1066 actual_type = EXPR_NUMERIC;
1068 if (actual_type != wanted_type)
1070 msg (SE, _("Argument %d to %s was expected to be of %s type. "
1071 "It was actually of type %s."),
1072 nonterm->n + 1, f->s,
1073 expr_type_name (actual_type), expr_type_name (wanted_type));
1077 else if (*cp == 'f')
1079 /* This is always the very last argument. Also, this code
1080 is a crock. However, it works. */
1081 struct fmt_spec fmt;
1083 if (!parse_format_specifier (&fmt, 0))
1085 if (formats[fmt.type].cat & FCAT_STRING)
1087 msg (SE, _("%s is not a numeric format."), fmt_to_string (&fmt));
1090 nonterm->arg[nonterm->n + 0] = (union any_node *) fmt.type;
1091 nonterm->arg[nonterm->n + 1] = (union any_node *) fmt.w;
1092 nonterm->arg[nonterm->n + 2] = (union any_node *) fmt.d;
1098 /* We're done if no args are left. */
1103 /* Optional arguments are named with capital letters. */
1104 if (isupper ((unsigned char) *cp))
1106 if (!lex_match (','))
1111 nonterm->arg[nonterm->n++] = allocate_num_con (SYSMIS);
1112 else if (*cp == 'S')
1113 nonterm->arg[nonterm->n++] = allocate_str_con (" ", 1);
1121 nonterm->type = sf->t2;
1123 else if (!lex_match (','))
1125 msg (SE, _("Too few arguments to function %s."), f->s);
1130 return sf->return_type;
1137 /* General function parsing. */
1140 get_num_args (const struct function *f, int num_args, union any_node **n)
1145 *n = xmalloc (sizeof (struct nonterm_node)
1146 + (num_args - 1) * sizeof (union any_node *));
1147 (*n)->nonterm.type = f->t;
1148 (*n)->nonterm.n = 0;
1151 t = parse_or (&(*n)->nonterm.arg[i]);
1152 if (t == EXPR_ERROR)
1156 if (t == EXPR_STRING)
1158 msg (SE, _("Type mismatch in argument %d of %s. A string "
1159 "expression was supplied where only a numeric expression "
1164 if (++i >= num_args)
1166 if (!lex_match (','))
1168 msg (SE, _("Missing comma following argument %d of %s."), i + 1, f->s);
1178 static enum expr_type
1179 parse_function (union any_node ** n)
1181 const struct function *fp;
1182 char fname[32], *cp;
1185 const struct vector *v;
1187 /* Check for a vector with this name. */
1188 v = dict_lookup_vector (default_dict, tokid);
1192 assert (token == '(');
1195 *n = xmalloc (sizeof (struct nonterm_node)
1196 + sizeof (union any_node *[2]));
1197 (*n)->nonterm.type = (v->var[0]->type == NUMERIC
1198 ? OP_VEC_ELEM_NUM : OP_VEC_ELEM_STR);
1199 (*n)->nonterm.n = 0;
1201 t = parse_or (&(*n)->nonterm.arg[0]);
1202 if (t == EXPR_ERROR)
1204 if (t != EXPR_NUMERIC)
1206 msg (SE, _("The index value after a vector name must be numeric."));
1211 if (!lex_match (')'))
1213 msg (SE, _("`)' expected after a vector index value."));
1216 ((*n)->nonterm.arg[1]) = (union any_node *) v->idx;
1218 return v->var[0]->type == NUMERIC ? EXPR_NUMERIC : EXPR_STRING;
1221 ds_truncate (&tokstr, 31);
1222 strcpy (fname, ds_c_str (&tokstr));
1223 cp = strrchr (fname, '.');
1224 if (cp && isdigit ((unsigned char) cp[1]))
1226 min_args = atoi (&cp[1]);
1233 if (!lex_force_match ('('))
1240 fp = binary_search (func_tab, func_count, sizeof *func_tab, &f,
1241 compare_functions, NULL);
1246 msg (SE, _("There is no function named %s."), fname);
1249 if (min_args && fp->func != nary_num_func)
1251 msg (SE, _("Function %s may not be given a minimum number of "
1252 "arguments."), fname);
1255 t = fp->func (fp, min_args, n);
1256 if (t == EXPR_ERROR)
1258 if (!lex_match (')'))
1260 lex_error (_("expecting `)' after %s function"), fname);
1271 /* Utility functions. */
1274 expr_type_name (enum expr_type type)
1282 return _("Boolean");
1285 return _("numeric");
1297 var_type_name (int type)
1302 return _("numeric");
1312 make_bool (union any_node **n)
1316 c = xmalloc (sizeof (struct nonterm_node));
1317 c->nonterm.type = OP_NUM_TO_BOOL;
1319 c->nonterm.arg[0] = *n;
1324 free_node (union any_node *n)
1328 if (IS_NONTERMINAL (n->type))
1332 for (i = 0; i < n->nonterm.n; i++)
1333 free_node (n->nonterm.arg[i]);
1339 static union any_node *
1340 allocate_num_con (double value)
1344 c = xmalloc (sizeof (struct num_con_node));
1345 c->num_con.type = OP_NUM_CON;
1346 c->num_con.value = value;
1351 static union any_node *
1352 allocate_str_con (const char *string, size_t length)
1356 c = xmalloc (sizeof (struct str_con_node) + length - 1);
1357 c->str_con.type = OP_STR_CON;
1358 c->str_con.len = length;
1359 memcpy (c->str_con.s, string, length);
1364 static union any_node *
1365 allocate_var_node (int type, struct variable *variable)
1369 c = xmalloc (sizeof (struct var_node));
1371 c->var.v = variable;
1377 allocate_nonterminal (int op, union any_node *n)
1381 c = xmalloc (sizeof c->nonterm);
1382 c->nonterm.type = op;
1384 c->nonterm.arg[0] = n;
1389 static union any_node *
1390 allocate_binary_nonterminal (int op, union any_node *lhs, union any_node *rhs)
1392 union any_node *node;
1394 node = xmalloc (sizeof node->nonterm + sizeof *node->nonterm.arg);
1395 node->nonterm.type = op;
1396 node->nonterm.n = 2;
1397 node->nonterm.arg[0] = lhs;
1398 node->nonterm.arg[1] = rhs;
1403 static struct function func_tab[] =
1405 {"ABS", OP_ABS, unary_func},
1406 {"ACOS", OP_ARCOS, unary_func},
1407 {"ARCOS", OP_ARCOS, unary_func},
1408 {"ARSIN", OP_ARSIN, unary_func},
1409 {"ARTAN", OP_ARTAN, unary_func},
1410 {"ASIN", OP_ARSIN, unary_func},
1411 {"ATAN", OP_ARTAN, unary_func},
1412 {"COS", OP_COS, unary_func},
1413 {"EXP", OP_EXP, unary_func},
1414 {"LG10", OP_LG10, unary_func},
1415 {"LN", OP_LN, unary_func},
1416 {"MOD10", OP_MOD10, unary_func},
1417 {"NORMAL", OP_NORMAL, unary_func},
1418 {"RND", OP_RND, unary_func},
1419 {"SIN", OP_SIN, unary_func},
1420 {"SQRT", OP_SQRT, unary_func},
1421 {"TAN", OP_TAN, unary_func},
1422 {"TRUNC", OP_TRUNC, unary_func},
1423 {"UNIFORM", OP_UNIFORM, unary_func},
1425 {"TIME.DAYS", OP_TIME_DAYS, unary_func},
1426 {"TIME.HMS", OP_TIME_HMS, ternary_func},
1428 {"CTIME.DAYS", OP_CTIME_DAYS, unary_func},
1429 {"CTIME.HOURS", OP_CTIME_HOURS, unary_func},
1430 {"CTIME.MINUTES", OP_CTIME_MINUTES, unary_func},
1431 {"CTIME.SECONDS", OP_CTIME_SECONDS, unary_func},
1433 {"DATE.DMY", OP_DATE_DMY, ternary_func},
1434 {"DATE.MDY", OP_DATE_MDY, ternary_func},
1435 {"DATE.MOYR", OP_DATE_MOYR, binary_func},
1436 {"DATE.QYR", OP_DATE_QYR, binary_func},
1437 {"DATE.WKYR", OP_DATE_WKYR, binary_func},
1438 {"DATE.YRDAY", OP_DATE_YRDAY, binary_func},
1440 {"XDATE.DATE", OP_XDATE_DATE, unary_func},
1441 {"XDATE.HOUR", OP_XDATE_HOUR, unary_func},
1442 {"XDATE.JDAY", OP_XDATE_JDAY, unary_func},
1443 {"XDATE.MDAY", OP_XDATE_MDAY, unary_func},
1444 {"XDATE.MINUTE", OP_XDATE_MINUTE, unary_func},
1445 {"XDATE.MONTH", OP_XDATE_MONTH, unary_func},
1446 {"XDATE.QUARTER", OP_XDATE_QUARTER, unary_func},
1447 {"XDATE.SECOND", OP_XDATE_SECOND, unary_func},
1448 {"XDATE.TDAY", OP_XDATE_TDAY, unary_func},
1449 {"XDATE.TIME", OP_XDATE_TIME, unary_func},
1450 {"XDATE.WEEK", OP_XDATE_WEEK, unary_func},
1451 {"XDATE.WKDAY", OP_XDATE_WKDAY, unary_func},
1452 {"XDATE.YEAR", OP_XDATE_YEAR, unary_func},
1454 {"MISSING", OP_SYSMIS, MISSING_func},
1455 {"MOD", OP_MOD, binary_func},
1456 {"SYSMIS", OP_SYSMIS, SYSMIS_func},
1457 {"VALUE", OP_NUM_VAL, VALUE_func},
1458 {"LAG", OP_NUM_LAG, LAG_func},
1459 {"YRMODA", OP_YRMODA, ternary_func},
1461 {"ANY", OP_ANY, nary_num_func},
1462 {"CFVAR", OP_CFVAR, nary_num_func},
1463 {"MAX", OP_MAX, nary_num_func},
1464 {"MEAN", OP_MEAN, nary_num_func},
1465 {"MIN", OP_MIN, nary_num_func},
1466 {"NMISS", OP_NMISS, nary_num_func},
1467 {"NVALID", OP_NVALID, nary_num_func},
1468 {"RANGE", OP_RANGE, nary_num_func},
1469 {"SD", OP_SD, nary_num_func},
1470 {"SUM", OP_SUM, nary_num_func},
1471 {"VAR", OP_VARIANCE, nary_num_func},
1472 {"VARIANCE", OP_VARIANCE, nary_num_func},
1474 {"CONCAT", OP_CONCAT, CONCAT_func},
1476 {"INDEX", OP_INDEX_2, generic_str_func},
1477 {"RINDEX", OP_RINDEX_2, generic_str_func},
1478 {"LENGTH", OP_LENGTH, generic_str_func},
1479 {"LOWER", OP_LOWER, generic_str_func},
1480 {"UPCASE", OP_UPPER, generic_str_func},
1481 {"LPAD", OP_LPAD, generic_str_func},
1482 {"RPAD", OP_RPAD, generic_str_func},
1483 {"LTRIM", OP_LTRIM, generic_str_func},
1484 {"RTRIM", OP_RTRIM, generic_str_func},
1485 {"NUMBER", OP_NUMBER, generic_str_func},
1486 {"STRING", OP_STRING, generic_str_func},
1487 {"SUBSTR", OP_SUBSTR_2, generic_str_func},
1490 /* An algo_compare_func that compares functions A and B based on
1493 compare_functions (const void *a_, const void *b_, void *aux UNUSED)
1495 const struct function *a = a_;
1496 const struct function *b = b_;
1498 return strcmp (a->s, b->s);
1502 init_func_tab (void)
1512 func_count = sizeof func_tab / sizeof *func_tab;
1513 sort (func_tab, func_count, sizeof *func_tab, compare_functions, NULL);
1519 expr_debug_print_postfix (const struct expression *e)
1521 const unsigned char *o;
1522 const double *num = e->num;
1523 const unsigned char *str = e->str;
1524 struct variable *const *v = e->var;
1527 printf ("postfix:");
1528 for (o = e->op; *o != OP_SENTINEL;)
1531 if (IS_NONTERMINAL (t))
1533 printf (" %s", ops[t].name);
1535 if (ops[t].flags & OP_VAR_ARGS)
1537 printf ("(%d)", *o);
1540 if (ops[t].flags & OP_MIN_ARGS)
1545 if (ops[t].flags & OP_FMT_SPEC)
1548 f.type = (int) *o++;
1551 printf ("(%s)", fmt_to_string (&f));
1554 else if (t == OP_NUM_CON)
1559 printf (" %f", *num);
1562 else if (t == OP_STR_CON)
1564 printf (" \"%.*s\"", *str, &str[1]);
1567 else if (t == OP_NUM_VAR || t == OP_STR_VAR)
1569 printf (" %s", (*v)->name);
1572 else if (t == OP_NUM_SYS)
1574 printf (" SYSMIS(#%d)", *o);
1577 else if (t == OP_NUM_VAL)
1579 printf (" VALUE(#%d)", *o);
1582 else if (t == OP_NUM_LAG || t == OP_STR_LAG)
1584 printf (" LAG(%s,%d)", (*v)->name, *o);
1590 printf ("%d unknown\n", t);
1597 #define DEFINE_OPERATOR(NAME, STACK_DELTA, FLAGS, ARGS) \
1598 {#NAME, STACK_DELTA, FLAGS, ARGS},
1599 struct op_desc ops[OP_SENTINEL] =
1604 #include "command.h"
1607 cmd_debug_evaluate (void)
1609 struct expression *expr;
1611 enum expr_type expr_flags;
1612 int dump_postfix = 0;
1614 discard_variables ();
1617 if (lex_match_id ("NOOPTIMIZE"))
1618 expr_flags |= EXPR_NO_OPTIMIZE;
1619 if (lex_match_id ("POSTFIX"))
1623 lex_force_match ('/');
1626 fprintf (stderr, "%s => ", lex_rest_of_line (NULL));
1629 expr = expr_parse (EXPR_ANY | expr_flags);
1630 if (!expr || token != '.')
1634 fprintf (stderr, "error\n");
1639 expr_debug_print_postfix (expr);
1642 expr_evaluate (expr, NULL, 0, &value);
1643 switch (expr_get_type (expr))
1646 if (value.f == SYSMIS)
1647 fprintf (stderr, "sysmis\n");
1649 fprintf (stderr, "%.2f\n", value.f);
1653 if (value.f == SYSMIS)
1654 fprintf (stderr, "sysmis\n");
1655 else if (value.f == 0.0)
1656 fprintf (stderr, "false\n");
1658 fprintf (stderr, "true\n");
1662 fputc ('"', stderr);
1663 fwrite (value.c + 1, value.c[0], 1, stderr);
1664 fputs ("\"\n", stderr);