Fix assertion for proper Huffman merge pattern: 0 == 1 modulo 1.
[pspp] / src / expr-prs.c
1 /* PSPP - computes sample statistics.
2    Copyright (C) 1997-9, 2000 Free Software Foundation, Inc.
3    Written by Ben Pfaff <blp@gnu.org>.
4
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.
9
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.
14
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
18    02111-1307, USA. */
19
20 #include <config.h>
21 #include "dictionary.h"
22 #include "expr.h"
23 #include "exprP.h"
24 #include "error.h"
25 #include <ctype.h>
26 #include <float.h>
27 #include <stdlib.h>
28 #include "algorithm.h"
29 #include "alloc.h"
30 #include "error.h"
31 #include "lexer.h"
32 #include "misc.h"
33 #include "settings.h"
34 #include "str.h"
35 #include "var.h"
36 #include "vfm.h"
37 #include "pool.h"
38 \f
39 /* Declarations. */
40
41 /* Recursive descent parser in order of increasing precedence. */
42 typedef enum expr_type parse_recursively_func (union any_node **);
43 static parse_recursively_func parse_or, parse_and, parse_not;
44 static parse_recursively_func parse_rel, parse_add, parse_mul;
45 static parse_recursively_func parse_neg, parse_exp;
46 static parse_recursively_func parse_primary, parse_function;
47
48 /* Utility functions. */
49 static const char *expr_type_name (enum expr_type type);
50 static const char *var_type_name (int var_type);
51 static void make_bool (union any_node **n);
52 static union any_node *allocate_nonterminal (int op, union any_node *n);
53 static union any_node *allocate_binary_nonterminal (int op, union any_node *,
54                                                     union any_node *);
55 static union any_node *allocate_num_con (double value);
56 static union any_node *allocate_str_con (const char *string, size_t length);
57 static union any_node *allocate_var_node (int type, struct variable *);
58 static int type_check (union any_node **n,
59                        enum expr_type actual_type,
60                        enum expr_type expected_type);
61
62 static algo_compare_func compare_functions;
63 static void init_func_tab (void);
64 \f
65 /* Public functions. */
66
67 void
68 expr_free (struct expression *e)
69 {
70   if (e == NULL)
71     return;
72
73   free (e->op);
74   free (e->var);
75   free (e->num);
76   free (e->str);
77   free (e->stack);
78   pool_destroy (e->pool);
79   free (e);
80 }
81
82 struct expression *
83 expr_parse (enum expr_type expected_type)
84 {
85   struct expression *e;
86   union any_node *n;
87   enum expr_type actual_type;
88   int optimize = (expected_type & EXPR_NO_OPTIMIZE) == 0;
89
90   expected_type &= ~EXPR_NO_OPTIMIZE;
91
92   /* Make sure the table of functions is initialized. */
93   init_func_tab ();
94
95   /* Parse the expression. */
96   actual_type = parse_or (&n);
97   if (actual_type == EXPR_ERROR)
98     return NULL;
99
100   /* Enforce type rules. */
101   if (!type_check (&n, actual_type, expected_type))
102     {
103       free_node (n);
104       return NULL;
105     }
106
107   /* Optimize the expression as best we can. */
108   if (optimize)
109     optimize_expression (&n);
110
111   /* Dump the tree-based expression to a postfix representation for
112      best evaluation speed, and destroy the tree. */
113   e = xmalloc (sizeof *e);
114   e->type = actual_type;
115   dump_expression (n, e);
116   free_node (n);
117
118   return e;
119 }
120
121 /* Returns the type of EXPR. */
122 enum expr_type
123 expr_get_type (const struct expression *expr) 
124 {
125   assert (expr != NULL);
126   return expr->type;
127 }
128
129 static int
130 type_check (union any_node **n, enum expr_type actual_type, enum expr_type expected_type)
131 {
132   switch (expected_type) 
133     {
134     case EXPR_BOOLEAN:
135     case EXPR_NUMERIC:
136       if (actual_type == EXPR_STRING)
137         {
138           msg (SE, _("Type mismatch: expression has string type, "
139                      "but a numeric value is required here."));
140           return 0;
141         }
142       if (actual_type == EXPR_NUMERIC && expected_type == EXPR_BOOLEAN)
143         *n = allocate_nonterminal (OP_NUM_TO_BOOL, *n);
144       break;
145       
146     case EXPR_STRING:
147       if (actual_type != EXPR_STRING)
148         {
149           msg (SE, _("Type mismatch: expression has numeric type, "
150                      "but a string value is required here."));
151           return 0;
152         }
153       break;
154
155     case EXPR_ANY:
156       break;
157
158     default:
159       assert (0); 
160     }
161   
162   return 1;
163 }
164 \f
165 /* Recursive-descent expression parser. */
166
167 /* Coerces *NODE, of type ACTUAL_TYPE, to type REQUIRED_TYPE, and
168    returns success.  If ACTUAL_TYPE cannot be coerced to the
169    desired type then we issue an error message about operator
170    OPERATOR_NAME and free *NODE. */
171 static int
172 type_coercion (enum expr_type actual_type, enum expr_type required_type,
173                union any_node **node,
174                const char *operator_name) 
175 {
176   assert (required_type == EXPR_NUMERIC
177           || required_type == EXPR_BOOLEAN
178           || required_type == EXPR_STRING);
179
180   if (actual_type == required_type) 
181     {
182       /* Type match. */
183       return 1; 
184     }
185   else if (actual_type == EXPR_ERROR)
186     {
187       /* Error already reported. */
188       *node = NULL;
189       return 0;
190     }
191   else if (actual_type == EXPR_BOOLEAN && required_type == EXPR_NUMERIC) 
192     {
193       /* Boolean -> numeric: nothing to do. */
194       return 1;
195     }
196   else if (actual_type == EXPR_NUMERIC && required_type == EXPR_BOOLEAN) 
197     {
198       /* Numeric -> Boolean: insert conversion. */
199       make_bool (node);
200       return 1;
201     }
202   else
203     {
204       /* We want a string and got a number/Boolean, or vice versa. */
205       assert ((actual_type == EXPR_STRING) != (required_type == EXPR_STRING));
206
207       if (required_type == EXPR_STRING)
208         msg (SE, _("Type mismatch: operands of %s operator must be strings."),
209              operator_name);
210       else
211         msg (SE, _("Type mismatch: operands of %s operator must be numeric."),
212              operator_name);
213       free_node (*node);
214       *node = NULL;
215       return 0;
216     }
217 }
218
219 /* An operator. */
220 struct operator 
221   {
222     int token;          /* Operator token. */
223     int type;           /* Operator node type. */
224     const char *name;   /* Operator name. */
225   };
226
227 /* Attempts to match the current token against the tokens for the
228    OP_CNT operators in OPS[].  If successful, returns nonzero
229    and, if OPERATOR is non-null, sets *OPERATOR to the operator.
230    On failure, returns zero and, if OPERATOR is non-null, sets
231    *OPERATOR to a null pointer. */
232 static int
233 match_operator (const struct operator ops[], size_t op_cnt,
234                 const struct operator **operator) 
235 {
236   const struct operator *op;
237
238   for (op = ops; op < ops + op_cnt; op++)
239     {
240       if (op->token == '-')
241         lex_negative_to_dash ();
242       if (lex_match (op->token)) 
243         {
244           if (operator != NULL)
245             *operator = op;
246           return 1;
247         }
248     }
249   if (operator != NULL)
250     *operator = NULL;
251   return 0;
252 }
253
254 /* Parses a chain of left-associative operator/operand pairs.
255    The operators' operands uniformly must be type REQUIRED_TYPE.
256    There are OP_CNT operators, specified in OPS[].  The next
257    higher level is parsed by PARSE_NEXT_LEVEL.  If CHAIN_WARNING
258    is non-null, then it will be issued as a warning if more than
259    one operator/operand pair is parsed. */
260 static enum expr_type
261 parse_binary_operators (union any_node **node,
262                         enum expr_type actual_type,
263                         enum expr_type required_type,
264                         enum expr_type result_type,
265                         const struct operator ops[], size_t op_cnt,
266                         parse_recursively_func *parse_next_level,
267                         const char *chain_warning)
268 {
269   int op_count;
270   const struct operator *operator;
271
272   if (actual_type == EXPR_ERROR)
273     return EXPR_ERROR;
274
275   for (op_count = 0; match_operator (ops, op_cnt, &operator); op_count++)
276     {
277       union any_node *rhs;
278
279       /* Convert the left-hand side to type REQUIRED_TYPE. */
280       if (!type_coercion (actual_type, required_type, node, operator->name))
281         return EXPR_ERROR;
282
283       /* Parse the right-hand side and coerce to type
284          REQUIRED_TYPE. */
285       if (!type_coercion (parse_next_level (&rhs), required_type,
286                           &rhs, operator->name))
287         {
288           free_node (*node);
289           *node = NULL;
290           return EXPR_ERROR;
291         }
292       *node = allocate_binary_nonterminal (operator->type, *node, rhs);
293
294       /* The result is of type RESULT_TYPE. */
295       actual_type = result_type;
296     }
297
298   if (op_count > 1 && chain_warning != NULL)
299     msg (SW, chain_warning);
300
301   return actual_type;
302 }
303
304 static enum expr_type
305 parse_inverting_unary_operator (union any_node **node,
306                                 enum expr_type required_type,
307                                 const struct operator *operator,
308                                 parse_recursively_func *parse_next_level) 
309 {
310   unsigned op_count;
311
312   op_count = 0;
313   while (match_operator (operator, 1, NULL))
314     op_count++;
315   if (op_count == 0)
316     return parse_next_level (node);
317
318   if (!type_coercion (parse_next_level (node), required_type,
319                       node, operator->name))
320     return EXPR_ERROR;
321   if (op_count % 2 != 0)
322     *node = allocate_nonterminal (operator->type, *node);
323   return required_type;
324 }
325
326 /* Parses the OR level. */
327 static enum expr_type
328 parse_or (union any_node **n)
329 {
330   static const struct operator ops[] = 
331     {
332       { T_OR, OP_OR, "logical disjunction (\"OR\")" },
333     };
334   
335   return parse_binary_operators (n, parse_and (n), EXPR_BOOLEAN, EXPR_BOOLEAN,
336                                  ops, sizeof ops / sizeof *ops,
337                                  parse_and, NULL);
338 }
339
340 /* Parses the AND level. */
341 static enum expr_type
342 parse_and (union any_node ** n)
343 {
344   static const struct operator ops[] = 
345     {
346       { T_AND, OP_AND, "logical conjunction (\"AND\")" },
347     };
348   
349   return parse_binary_operators (n, parse_not (n), EXPR_BOOLEAN, EXPR_BOOLEAN,
350                                  ops, sizeof ops / sizeof *ops,
351                                  parse_not, NULL);
352 }
353
354 /* Parses the NOT level. */
355 static enum expr_type
356 parse_not (union any_node ** n)
357 {
358   static const struct operator op
359     = { T_NOT, OP_NOT, "logical negation (\"NOT-\")" };
360   return parse_inverting_unary_operator (n, EXPR_BOOLEAN, &op, parse_rel);
361 }
362
363 /* Parse relational operators. */
364 static enum expr_type
365 parse_rel (union any_node **n) 
366 {
367   static const struct operator numeric_ops[] = 
368     {
369       { '=', OP_EQ, "numeric equality (\"=\")" },
370       { T_EQ, OP_EQ, "numeric equality (\"EQ\")" },
371       { T_GE, OP_GE, "numeric greater-than-or-equal-to (\">=\")" },
372       { T_GT, OP_GT, "numeric greater than (\">\")" },
373       { T_LE, OP_LE, "numeric less-than-or-equal-to (\"<=\")" },
374       { T_LT, OP_LT, "numeric less than (\"<\")" },
375       { T_NE, OP_NE, "numeric inequality (\"<>\")" },
376     };
377
378   static const struct operator string_ops[] = 
379     {
380       { '=', OP_EQ_STRING, "string equality (\"=\")" },
381       { T_EQ, OP_EQ_STRING, "string equality (\"EQ\")" },
382       { T_GE, OP_GE_STRING, "string greater-than-or-equal-to (\">=\")" },
383       { T_GT, OP_GT_STRING, "string greater than (\">\")" },
384       { T_LE, OP_LE_STRING, "string less-than-or-equal-to (\"<=\")" },
385       { T_LT, OP_LT_STRING, "string less than (\"<\")" },
386       { T_NE, OP_NE_STRING, "string inequality (\"<>\")" },
387     };
388
389   int type = parse_add (n);
390
391   const char *chain_warning = 
392     _("Chaining relational operators (e.g. \"a < b < c\") will "
393       "not produce the mathematically expected result.  "
394       "Use the AND logical operator to fix the problem "
395       "(e.g. \"a < b AND b < c\").  "
396       "If chaining is really intended, parentheses will disable "
397       "this warning (e.g. \"(a < b) < c\".)");
398
399   switch (type) 
400     {
401     case EXPR_ERROR:
402       return EXPR_ERROR;
403
404     case EXPR_NUMERIC:
405     case EXPR_BOOLEAN:
406       return parse_binary_operators (n,
407                                      type, EXPR_NUMERIC, EXPR_BOOLEAN,
408                                      numeric_ops,
409                                      sizeof numeric_ops / sizeof *numeric_ops,
410                                      parse_add, chain_warning);
411
412     case EXPR_STRING:
413       return parse_binary_operators (n,
414                                      type, EXPR_STRING, EXPR_BOOLEAN,
415                                      string_ops,
416                                      sizeof string_ops / sizeof *string_ops,
417                                      parse_add, chain_warning);
418
419     default:
420       assert (0);
421       abort ();
422     }
423 }
424
425 /* Parses the addition and subtraction level. */
426 static enum expr_type
427 parse_add (union any_node **n)
428 {
429   static const struct operator ops[] = 
430     {
431       { '+', OP_ADD, "addition (\"+\")" },
432       { '-', OP_SUB, "subtraction (\"-\")-" },
433     };
434   
435   return parse_binary_operators (n, parse_mul (n), EXPR_NUMERIC, EXPR_NUMERIC,
436                                  ops, sizeof ops / sizeof *ops,
437                                  parse_mul, NULL);
438 }
439
440 /* Parses the multiplication and division level. */
441 static enum expr_type
442 parse_mul (union any_node ** n)
443 {
444   static const struct operator ops[] = 
445     {
446       { '*', OP_MUL, "multiplication (\"*\")" },
447       { '/', OP_DIV, "division (\"/\")" },
448     };
449   
450   return parse_binary_operators (n, parse_neg (n), EXPR_NUMERIC, EXPR_NUMERIC,
451                                  ops, sizeof ops / sizeof *ops,
452                                  parse_neg, NULL);
453 }
454
455 /* Parses the unary minus level. */
456 static enum expr_type
457 parse_neg (union any_node **n)
458 {
459   static const struct operator op = { '-', OP_NEG, "negation (\"-\")" };
460   return parse_inverting_unary_operator (n, EXPR_NUMERIC, &op, parse_exp);
461 }
462
463 static enum expr_type
464 parse_exp (union any_node **n)
465 {
466   static const struct operator ops[] = 
467     {
468       { T_EXP, OP_POW, "exponentiation (\"**\")" },
469     };
470   
471   const char *chain_warning = 
472     _("The exponentiation operator (\"**\") is left-associative, "
473       "even though right-associative semantics are more useful.  "
474       "That is, \"a**b**c\" equals \"(a**b)**c\", not as \"a**(b**c)\".  "
475       "To disable this warning, insert parentheses.");
476
477   return parse_binary_operators (n,
478                                  parse_primary (n), EXPR_NUMERIC, EXPR_NUMERIC,
479                                  ops, sizeof ops / sizeof *ops,
480                                  parse_primary, chain_warning);
481 }
482
483 /* Parses system variables. */
484 static enum expr_type
485 parse_sysvar (union any_node **n)
486 {
487   if (!strcmp (tokid, "$CASENUM"))
488     {
489       *n = xmalloc (sizeof (struct casenum_node));
490       (*n)->casenum.type = OP_CASENUM;
491       return EXPR_NUMERIC;
492     }
493   else if (!strcmp (tokid, "$DATE"))
494     {
495       static const char *months[12] =
496         {
497           "JAN", "FEB", "MAR", "APR", "MAY", "JUN",
498           "JUL", "AUG", "SEP", "OCT", "NOV", "DEC",
499         };
500
501       struct tm *time;
502       char temp_buf[10];
503
504       time = localtime (&last_vfm_invocation);
505       sprintf (temp_buf, "%02d %s %02d", abs (time->tm_mday) % 100,
506                months[abs (time->tm_mon) % 12], abs (time->tm_year) % 100);
507
508       *n = xmalloc (sizeof (struct str_con_node) + 8);
509       (*n)->str_con.type = OP_STR_CON;
510       (*n)->str_con.len = 9;
511       memcpy ((*n)->str_con.s, temp_buf, 9);
512       return EXPR_STRING;
513     }
514   else
515     {
516       enum expr_type type;
517       double d;
518
519       type = EXPR_NUMERIC;
520       if (!strcmp (tokid, "$TRUE")) 
521         {
522           d = 1.0;
523           type = EXPR_BOOLEAN; 
524         }
525       else if (!strcmp (tokid, "$FALSE")) 
526         {
527           d = 0.0;
528           type = EXPR_BOOLEAN; 
529         }
530       else if (!strcmp (tokid, "$SYSMIS"))
531         d = SYSMIS;
532       else if (!strcmp (tokid, "$JDATE"))
533         {
534           struct tm *time = localtime (&last_vfm_invocation);
535           d = yrmoda (time->tm_year + 1900, time->tm_mon + 1, time->tm_mday);
536         }
537       else if (!strcmp (tokid, "$TIME"))
538         {
539           struct tm *time;
540           time = localtime (&last_vfm_invocation);
541           d = (yrmoda (time->tm_year + 1900, time->tm_mon + 1,
542                        time->tm_mday) * 60. * 60. * 24.
543                + time->tm_hour * 60 * 60.
544                + time->tm_min * 60.
545                + time->tm_sec);
546         }
547       else if (!strcmp (tokid, "$LENGTH"))
548         d = get_viewlength ();
549       else if (!strcmp (tokid, "$WIDTH"))
550         d = get_viewwidth ();
551       else
552         {
553           msg (SE, _("Unknown system variable %s."), tokid);
554           return EXPR_ERROR;
555         }
556
557       *n = xmalloc (sizeof (struct num_con_node));
558       (*n)->num_con.type = OP_NUM_CON;
559       (*n)->num_con.value = d;
560       return type;
561     }
562 }
563
564 /* Parses numbers, varnames, etc. */
565 static enum expr_type
566 parse_primary (union any_node **n)
567 {
568   switch (token)
569     {
570     case T_ID:
571       {
572         struct variable *v;
573
574         /* An identifier followed by a left parenthesis is a function
575            call. */
576         if (lex_look_ahead () == '(')
577           return parse_function (n);
578
579         /* $ at the beginning indicates a system variable. */
580         if (tokid[0] == '$')
581           {
582             enum expr_type type = parse_sysvar (n);
583             lex_get ();
584             return type;
585           }
586
587         /* Otherwise, it must be a user variable. */
588         v = dict_lookup_var (default_dict, tokid);
589         lex_get ();
590         if (v == NULL)
591           {
592             lex_error (_("expecting variable name"));
593             return EXPR_ERROR;
594           }
595
596         if (v->type == NUMERIC) 
597           {
598             *n = allocate_var_node (OP_NUM_VAR, v);
599             return EXPR_NUMERIC;
600           }
601         else 
602           {
603             *n = allocate_var_node (OP_STR_VAR, v);
604             return EXPR_STRING; 
605           }
606       }
607
608     case T_NUM:
609       *n = allocate_num_con (tokval);
610       lex_get ();
611       return EXPR_NUMERIC;
612
613     case T_STRING:
614       {
615         *n = allocate_str_con (ds_c_str (&tokstr), ds_length (&tokstr));
616         lex_get ();
617         return EXPR_STRING;
618       }
619
620     case '(':
621       {
622         int t;
623         lex_get ();
624         t = parse_or (n);
625         if (!lex_match (')'))
626           {
627             lex_error (_("expecting `)'"));
628             free_node (*n);
629             return EXPR_ERROR;
630           }
631         return t;
632       }
633
634     default:
635       lex_error (_("in expression"));
636       return EXPR_ERROR;
637     }
638 }
639 \f
640 /* Individual function parsing. */
641
642 struct function
643   {
644     const char *s;
645     int t;
646     enum expr_type (*func) (const struct function *, int, union any_node **);
647   };
648
649 static struct function func_tab[];
650 static int func_count;
651
652 static int get_num_args (const struct function *, int, union any_node **);
653
654 static enum expr_type
655 unary_func (const struct function *f, int x UNUSED, union any_node ** n)
656 {
657   if (!get_num_args (f, 1, n))
658     return EXPR_ERROR;
659   return EXPR_NUMERIC;
660 }
661
662 static enum expr_type
663 binary_func (const struct function *f, int x UNUSED, union any_node ** n)
664 {
665   if (!get_num_args (f, 2, n))
666     return EXPR_ERROR;
667   return EXPR_NUMERIC;
668 }
669
670 static enum expr_type
671 ternary_func (const struct function *f, int x UNUSED, union any_node **n)
672 {
673   if (!get_num_args (f, 3, n))
674     return EXPR_ERROR;
675   return EXPR_NUMERIC;
676 }
677
678 static enum expr_type
679 MISSING_func (const struct function *f, int x UNUSED, union any_node **n)
680 {
681   if (!get_num_args (f, 1, n))
682     return EXPR_ERROR;
683   return EXPR_BOOLEAN;
684 }
685
686 static enum expr_type
687 SYSMIS_func (const struct function *f, int x UNUSED, union any_node **n)
688 {
689   if (!get_num_args (f, 1, n))
690     return EXPR_ERROR;
691   if ((*n)->nonterm.arg[0]->type == OP_NUM_VAR) 
692     {
693       struct variable *v = (*n)->nonterm.arg[0]->var.v;
694       free_node (*n);
695       *n = allocate_var_node (OP_NUM_SYS, v);
696     }
697   return EXPR_BOOLEAN;
698 }
699
700 static enum expr_type
701 VALUE_func (const struct function *f UNUSED, int x UNUSED, union any_node **n)
702 {
703   struct variable *v = parse_variable ();
704
705   if (!v)
706     return EXPR_ERROR;
707   if (v->type == NUMERIC)
708     {
709       *n = allocate_var_node (OP_NUM_VAL, v);
710       return EXPR_NUMERIC;
711     }
712   else
713     {
714       *n = allocate_var_node (OP_STR_VAR, v);
715       return EXPR_STRING;
716     }
717 }
718
719 static enum expr_type
720 LAG_func (const struct function *f UNUSED, int x UNUSED, union any_node **n)
721 {
722   struct variable *v = parse_variable ();
723   int nlag = 1;
724
725   if (!v)
726     return EXPR_ERROR;
727   if (lex_match (','))
728     {
729       if (!lex_integer_p () || lex_integer () <= 0 || lex_integer () > 1000)
730         {
731           msg (SE, _("Argument 2 to LAG must be a small positive "
732                      "integer constant."));
733           return EXPR_ERROR;
734         }
735       
736       nlag = lex_integer ();
737       lex_get ();
738     }
739   n_lag = max (nlag, n_lag);
740   *n = xmalloc (sizeof (struct lag_node));
741   (*n)->lag.type = (v->type == NUMERIC ? OP_NUM_LAG : OP_STR_LAG);
742   (*n)->lag.v = v;
743   (*n)->lag.lag = nlag;
744   return (v->type == NUMERIC ? EXPR_NUMERIC : EXPR_STRING);
745 }
746
747 /* This screwball function parses n-ary operators:
748
749    1. NMISS, NVALID, SUM, MEAN: any number of numeric
750       arguments.
751
752    2. SD, VARIANCE, CFVAR: at least two numeric arguments.
753
754    3. RANGE: An odd number of arguments, but at least three, and
755       all of the same type.
756
757    4. ANY: At least two arguments, all of the same type.
758
759    5. MIN, MAX: Any number of arguments, all of the same type.
760  */
761 static enum expr_type
762 nary_num_func (const struct function *f, int min_args, union any_node **n)
763 {
764   /* Argument number of current argument (used for error messages). */
765   int arg_idx = 1;
766
767   /* Number of arguments. */
768   int nargs;
769
770   /* Number of arguments allocated. */
771   int m = 16;
772
773   /* Type of arguments. */
774   int type = (f->t == OP_ANY || f->t == OP_RANGE
775               || f->t == OP_MIN || f->t == OP_MAX) ? -1 : NUMERIC;
776
777   *n = xmalloc (sizeof (struct nonterm_node) + sizeof (union any_node *[15]));
778   (*n)->nonterm.type = f->t;
779   (*n)->nonterm.n = 0;
780   for (;;)
781     {
782       /* Special case: vara TO varb. */
783
784       /* FIXME: Is this condition failsafe?  Can we _ever_ have two
785          juxtaposed identifiers otherwise?  */
786       if (token == T_ID && dict_lookup_var (default_dict, tokid) != NULL
787           && toupper (lex_look_ahead ()) == 'T')
788         {
789           struct variable **v;
790           int nv;
791           int j;
792           int opts = PV_SINGLE;
793
794           if (type == NUMERIC)
795             opts |= PV_NUMERIC;
796           else if (type == ALPHA)
797             opts |= PV_STRING;
798           if (!parse_variables (default_dict, &v, &nv, opts))
799             goto fail;
800           if (nv + (*n)->nonterm.n >= m)
801             {
802               m += nv + 16;
803               *n = xrealloc (*n, (sizeof (struct nonterm_node)
804                                   + (m - 1) * sizeof (union any_node *)));
805             }
806           if (type == -1)
807             {
808               type = v[0]->type;
809               for (j = 1; j < nv; j++)
810                 if (type != v[j]->type)
811                   {
812                     msg (SE, _("Type mismatch in argument %d of %s, which was "
813                                "expected to be of %s type.  It was actually "
814                                "of %s type. "),
815                          arg_idx, f->s, var_type_name (type), var_type_name (v[j]->type));
816                     free (v);
817                     goto fail;
818                   }
819             }
820           for (j = 0; j < nv; j++)
821             {
822               union any_node **c = &(*n)->nonterm.arg[(*n)->nonterm.n++];
823               *c = allocate_var_node ((type == NUMERIC
824                                        ? OP_NUM_VAR : OP_STR_VAR),
825                                       v[j]);
826             }
827         }
828       else
829         {
830           union any_node *c;
831           int t = parse_or (&c);
832
833           if (t == EXPR_ERROR)
834             goto fail;
835           if (t == EXPR_BOOLEAN)
836             {
837               free_node (c);
838               msg (SE, _("%s cannot take Boolean operands."), f->s);
839               goto fail;
840             }
841           if (type == -1)
842             {
843               if (t == EXPR_NUMERIC)
844                 type = NUMERIC;
845               else if (t == EXPR_STRING)
846                 type = ALPHA;
847             }
848           else if ((t == EXPR_NUMERIC) ^ (type == NUMERIC))
849             {
850               free_node (c);
851               msg (SE, _("Type mismatch in argument %d of %s, which was "
852                          "expected to be of %s type.  It was actually "
853                          "of %s type. "),
854                    arg_idx, f->s, var_type_name (type), expr_type_name (t));
855               goto fail;
856             }
857           if ((*n)->nonterm.n + 1 >= m)
858             {
859               m += 16;
860               *n = xrealloc (*n, (sizeof (struct nonterm_node)
861                                   + (m - 1) * sizeof (union any_node *)));
862             }
863           (*n)->nonterm.arg[(*n)->nonterm.n++] = c;
864         }
865
866       if (token == ')')
867         break;
868       if (!lex_match (','))
869         {
870           lex_error (_("in function call"));
871           goto fail;
872         }
873
874       arg_idx++;
875     }
876   *n = xrealloc (*n, (sizeof (struct nonterm_node)
877                       + ((*n)->nonterm.n) * sizeof (union any_node *)));
878
879   nargs = (*n)->nonterm.n;
880   if (f->t == OP_RANGE)
881     {
882       if (nargs < 3 || (nargs & 1) == 0)
883         {
884           msg (SE, _("RANGE requires an odd number of arguments, but "
885                      "at least three."));
886           goto fail;
887         }
888     }
889   else if (f->t == OP_SD || f->t == OP_VARIANCE
890            || f->t == OP_CFVAR || f->t == OP_ANY)
891     {
892       if (nargs < 2)
893         {
894           msg (SE, _("%s requires at least two arguments."), f->s);
895           goto fail;
896         }
897     }
898
899   if (f->t == OP_CFVAR || f->t == OP_SD || f->t == OP_VARIANCE)
900     min_args = max (min_args, 2);
901   else
902     min_args = max (min_args, 1);
903
904   /* Yes, this is admittedly a terrible crock, but it works. */
905   (*n)->nonterm.arg[(*n)->nonterm.n] = (union any_node *) min_args;
906
907   if (min_args > nargs)
908     {
909       msg (SE, _("%s.%d requires at least %d arguments."),
910            f->s, min_args, min_args);
911       goto fail;
912     }
913
914   if (f->t == OP_MIN || f->t == OP_MAX) 
915     {
916       if (type == ALPHA) 
917         {
918           if (f->t == OP_MIN)
919             (*n)->type = OP_MIN_STRING;
920           else if (f->t == OP_MAX)
921             (*n)->type = OP_MAX_STRING;
922           else
923             assert (0);
924           return EXPR_STRING;
925         }
926       else
927         return EXPR_NUMERIC;
928     }
929   else if (f->t == OP_ANY || f->t == OP_RANGE)
930     {
931       if (type == ALPHA) 
932         {
933           if (f->t == OP_ANY)
934             (*n)->type = OP_ANY_STRING;
935           else if (f->t == OP_RANGE)
936             (*n)->type = OP_RANGE_STRING;
937           else
938             assert (0);
939         }
940       return EXPR_BOOLEAN;
941     }
942   else
943     return EXPR_NUMERIC;
944
945 fail:
946   free_node (*n);
947   return EXPR_ERROR;
948 }
949
950 static enum expr_type
951 CONCAT_func (const struct function *f UNUSED, int x UNUSED, union any_node **n)
952 {
953   int m = 0;
954
955   int type;
956
957   *n = xmalloc (sizeof (struct nonterm_node) + sizeof (union any_node *[15]));
958   (*n)->nonterm.type = OP_CONCAT;
959   (*n)->nonterm.n = 0;
960   for (;;)
961     {
962       if ((*n)->nonterm.n >= m)
963         {
964           m += 16;
965           *n = xrealloc (*n, (sizeof (struct nonterm_node)
966                               + (m - 1) * sizeof (union any_node *)));
967         }
968       type = parse_or (&(*n)->nonterm.arg[(*n)->nonterm.n]);
969       if (type == EXPR_ERROR)
970         goto fail;
971       (*n)->nonterm.n++;
972       if (type != EXPR_STRING)
973         {
974           msg (SE, _("Argument %d to CONCAT is type %s.  All arguments "
975                      "to CONCAT must be strings."),
976                (*n)->nonterm.n + 1, expr_type_name (type));
977           goto fail;
978         }
979
980       if (!lex_match (','))
981         break;
982     }
983   *n = xrealloc (*n, (sizeof (struct nonterm_node)
984                       + ((*n)->nonterm.n - 1) * sizeof (union any_node *)));
985   return EXPR_STRING;
986
987 fail:
988   free_node (*n);
989   return EXPR_ERROR;
990 }
991
992 /* Parses a string function according to f->desc.  f->desc[0] is the
993    return type of the function.  Succeeding characters represent
994    successive args.  Optional args are separated from the required
995    args by a slash (`/').  Codes are `n', numeric arg; `s', string
996    arg; and `f', format spec (this must be the last arg).  If the
997    optional args are included, the type becomes f->t+1. */
998 static enum expr_type
999 generic_str_func (const struct function *f, int x UNUSED, union any_node **n)
1000 {
1001   struct string_function 
1002     {
1003       int t1, t2;
1004       enum expr_type return_type;
1005       const char *arg_types;
1006     };
1007
1008   static const struct string_function string_func_tab[] = 
1009     {
1010       {OP_INDEX_2, OP_INDEX_3, EXPR_NUMERIC, "ssN"},
1011       {OP_RINDEX_2, OP_RINDEX_3, EXPR_NUMERIC, "ssN"},
1012       {OP_LENGTH, 0, EXPR_NUMERIC, "s"},
1013       {OP_LOWER, 0, EXPR_STRING, "s"},
1014       {OP_UPPER, 0, EXPR_STRING, "s"},
1015       {OP_LPAD, 0, EXPR_STRING, "snS"},
1016       {OP_RPAD, 0, EXPR_STRING, "snS"},
1017       {OP_LTRIM, 0, EXPR_STRING, "sS"},
1018       {OP_RTRIM, 0, EXPR_STRING, "sS"},
1019       {OP_NUMBER, 0, EXPR_NUMERIC, "sf"},
1020       {OP_STRING, 0, EXPR_STRING, "nf"},
1021       {OP_SUBSTR_2, OP_SUBSTR_3, EXPR_STRING, "snN"},
1022     };
1023
1024   const int string_func_cnt = sizeof string_func_tab / sizeof *string_func_tab;
1025
1026   const struct string_function *sf;
1027   int arg_cnt;
1028   const char *cp;
1029   struct nonterm_node *nonterm;
1030
1031   /* Find string_function that corresponds to f. */
1032   for (sf = string_func_tab; sf < string_func_tab + string_func_cnt; sf++)
1033     if (f->t == sf->t1)
1034       break;
1035   assert (sf < string_func_tab + string_func_cnt);
1036
1037   /* Count max number of arguments. */
1038   arg_cnt = 0;
1039   for (cp = sf->arg_types; *cp != '\0'; cp++)
1040     {
1041       if (*cp != 'f')
1042         arg_cnt++;
1043       else
1044         arg_cnt += 3;
1045     }
1046
1047   /* Allocate node. */
1048   *n = xmalloc (sizeof (struct nonterm_node)
1049                 + (arg_cnt - 1) * sizeof (union any_node *));
1050   nonterm = &(*n)->nonterm;
1051   nonterm->type = sf->t1;
1052   nonterm->n = 0;
1053
1054   /* Parse arguments. */
1055   cp = sf->arg_types;
1056   for (;;)
1057     {
1058       if (*cp == 'n' || *cp == 's' || *cp == 'N' || *cp == 'S')
1059         {
1060           enum expr_type wanted_type
1061             = *cp == 'n' || *cp == 'N' ? EXPR_NUMERIC : EXPR_STRING;
1062           enum expr_type actual_type = parse_or (&nonterm->arg[nonterm->n]);
1063
1064           if (actual_type == EXPR_ERROR)
1065             goto fail;
1066           else if (actual_type == EXPR_BOOLEAN)
1067             actual_type = EXPR_NUMERIC;
1068           nonterm->n++;
1069           if (actual_type != wanted_type)
1070             {
1071               msg (SE, _("Argument %d to %s was expected to be of %s type.  "
1072                          "It was actually of type %s."),
1073                    nonterm->n + 1, f->s,
1074                    expr_type_name (actual_type), expr_type_name (wanted_type));
1075               goto fail;
1076             }
1077         }
1078       else if (*cp == 'f')
1079         {
1080           /* This is always the very last argument.  Also, this code
1081              is a crock.  However, it works. */
1082           struct fmt_spec fmt;
1083
1084           if (!parse_format_specifier (&fmt, 0))
1085             goto fail;
1086           if (formats[fmt.type].cat & FCAT_STRING)
1087             {
1088               msg (SE, _("%s is not a numeric format."), fmt_to_string (&fmt));
1089               goto fail;
1090             }
1091           nonterm->arg[nonterm->n + 0] = (union any_node *) fmt.type;
1092           nonterm->arg[nonterm->n + 1] = (union any_node *) fmt.w;
1093           nonterm->arg[nonterm->n + 2] = (union any_node *) fmt.d;
1094           break;
1095         }
1096       else
1097         assert (0);
1098
1099       /* We're done if no args are left. */
1100       cp++;
1101       if (*cp == 0)
1102         break;
1103
1104       /* Optional arguments are named with capital letters. */
1105       if (isupper ((unsigned char) *cp))
1106         {
1107           if (!lex_match (',')) 
1108             {
1109               if (sf->t2 == 0)
1110                 {
1111                   if (*cp == 'N') 
1112                     nonterm->arg[nonterm->n++] = allocate_num_con (SYSMIS);
1113                   else if (*cp == 'S')
1114                     nonterm->arg[nonterm->n++] = allocate_str_con (" ", 1);
1115                   else
1116                     assert (0);
1117                 }
1118               break; 
1119             }
1120
1121           if (sf->t2 != 0)
1122             nonterm->type = sf->t2;
1123         }
1124       else if (!lex_match (','))
1125         {
1126           msg (SE, _("Too few arguments to function %s."), f->s);
1127           goto fail;
1128         }
1129     }
1130
1131   return sf->return_type;
1132
1133 fail:
1134   free_node (*n);
1135   return EXPR_ERROR;
1136 }
1137 \f
1138 /* General function parsing. */
1139
1140 static int
1141 get_num_args (const struct function *f, int num_args, union any_node **n)
1142 {
1143   int t;
1144   int i;
1145
1146   *n = xmalloc (sizeof (struct nonterm_node)
1147                 + (num_args - 1) * sizeof (union any_node *));
1148   (*n)->nonterm.type = f->t;
1149   (*n)->nonterm.n = 0;
1150   for (i = 0;;)
1151     {
1152       t = parse_or (&(*n)->nonterm.arg[i]);
1153       if (t == EXPR_ERROR)
1154         goto fail;
1155       (*n)->nonterm.n++;
1156
1157       if (t == EXPR_STRING)
1158         {
1159           msg (SE, _("Type mismatch in argument %d of %s.  A string "
1160                      "expression was supplied where only a numeric expression "
1161                      "is allowed."),
1162                i + 1, f->s);
1163           goto fail;
1164         }
1165       if (++i >= num_args)
1166         return 1;
1167       if (!lex_match (','))
1168         {
1169           msg (SE, _("Missing comma following argument %d of %s."), i + 1, f->s);
1170           goto fail;
1171         }
1172     }
1173
1174 fail:
1175   free_node (*n);
1176   return 0;
1177 }
1178
1179 static enum expr_type
1180 parse_function (union any_node ** n)
1181 {
1182   const struct function *fp;
1183   char fname[32], *cp;
1184   int t;
1185   int min_args;
1186   const struct vector *v;
1187
1188   /* Check for a vector with this name. */
1189   v = dict_lookup_vector (default_dict, tokid);
1190   if (v)
1191     {
1192       lex_get ();
1193       assert (token == '(');
1194       lex_get ();
1195
1196       *n = xmalloc (sizeof (struct nonterm_node)
1197                     + sizeof (union any_node *[2]));
1198       (*n)->nonterm.type = (v->var[0]->type == NUMERIC
1199                         ? OP_VEC_ELEM_NUM : OP_VEC_ELEM_STR);
1200       (*n)->nonterm.n = 0;
1201
1202       t = parse_or (&(*n)->nonterm.arg[0]);
1203       if (t == EXPR_ERROR)
1204         goto fail;
1205       if (t != EXPR_NUMERIC)
1206         {
1207           msg (SE, _("The index value after a vector name must be numeric."));
1208           goto fail;
1209         }
1210       (*n)->nonterm.n++;
1211
1212       if (!lex_match (')'))
1213         {
1214           msg (SE, _("`)' expected after a vector index value."));
1215           goto fail;
1216         }
1217       ((*n)->nonterm.arg[1]) = (union any_node *) v->idx;
1218
1219       return v->var[0]->type == NUMERIC ? EXPR_NUMERIC : EXPR_STRING;
1220     }
1221
1222   ds_truncate (&tokstr, 31);
1223   strcpy (fname, ds_c_str (&tokstr));
1224   cp = strrchr (fname, '.');
1225   if (cp && isdigit ((unsigned char) cp[1]))
1226     {
1227       min_args = atoi (&cp[1]);
1228       *cp = 0;
1229     }
1230   else
1231     min_args = 0;
1232
1233   lex_get ();
1234   if (!lex_force_match ('('))
1235     return EXPR_ERROR;
1236   
1237   {
1238     struct function f;
1239     f.s = fname;
1240     
1241     fp = binary_search (func_tab, func_count, sizeof *func_tab, &f,
1242                         compare_functions, NULL);
1243   }
1244   
1245   if (!fp)
1246     {
1247       msg (SE, _("There is no function named %s."), fname);
1248       return EXPR_ERROR;
1249     }
1250   if (min_args && fp->func != nary_num_func)
1251     {
1252       msg (SE, _("Function %s may not be given a minimum number of "
1253                  "arguments."), fname);
1254       return EXPR_ERROR;
1255     }
1256   t = fp->func (fp, min_args, n);
1257   if (t == EXPR_ERROR)
1258     return EXPR_ERROR;
1259   if (!lex_match (')'))
1260     {
1261       lex_error (_("expecting `)' after %s function"), fname);
1262       goto fail;
1263     }
1264
1265   return t;
1266
1267 fail:
1268   free_node (*n);
1269   return EXPR_ERROR;
1270 }
1271 \f
1272 /* Utility functions. */
1273
1274 static const char *
1275 expr_type_name (enum expr_type type)
1276 {
1277   switch (type)
1278     {
1279     case EXPR_ERROR:
1280       return _("error");
1281
1282     case EXPR_BOOLEAN:
1283       return _("Boolean");
1284
1285     case EXPR_NUMERIC:
1286       return _("numeric");
1287
1288     case EXPR_STRING:
1289       return _("string");
1290
1291     default:
1292       assert (0);
1293       return 0;
1294     }
1295 }
1296
1297 static const char *
1298 var_type_name (int type)
1299 {
1300   switch (type)
1301     {
1302     case NUMERIC:
1303       return _("numeric");
1304     case ALPHA:
1305       return _("string");
1306     default:
1307       assert (0);
1308       return 0;
1309     }
1310 }
1311
1312 static void
1313 make_bool (union any_node **n)
1314 {
1315   union any_node *c;
1316
1317   c = xmalloc (sizeof (struct nonterm_node));
1318   c->nonterm.type = OP_NUM_TO_BOOL;
1319   c->nonterm.n = 1;
1320   c->nonterm.arg[0] = *n;
1321   *n = c;
1322 }
1323
1324 void
1325 free_node (union any_node *n)
1326 {
1327   if (n != NULL) 
1328     {
1329       if (IS_NONTERMINAL (n->type))
1330         {
1331           int i;
1332
1333           for (i = 0; i < n->nonterm.n; i++)
1334             free_node (n->nonterm.arg[i]);
1335         }
1336       free (n); 
1337     }
1338 }
1339
1340 static union any_node *
1341 allocate_num_con (double value) 
1342 {
1343   union any_node *c;
1344
1345   c = xmalloc (sizeof (struct num_con_node));
1346   c->num_con.type = OP_NUM_CON;
1347   c->num_con.value = value;
1348
1349   return c;
1350 }
1351
1352 static union any_node *
1353 allocate_str_con (const char *string, size_t length) 
1354 {
1355   union any_node *c;
1356
1357   c = xmalloc (sizeof (struct str_con_node) + length - 1);
1358   c->str_con.type = OP_STR_CON;
1359   c->str_con.len = length;
1360   memcpy (c->str_con.s, string, length);
1361
1362   return c;
1363 }
1364
1365 static union any_node *
1366 allocate_var_node (int type, struct variable *variable) 
1367 {
1368   union any_node *c;
1369
1370   c = xmalloc (sizeof (struct var_node));
1371   c->var.type = type;
1372   c->var.v = variable;
1373
1374   return c;
1375 }
1376
1377 union any_node *
1378 allocate_nonterminal (int op, union any_node *n)
1379 {
1380   union any_node *c;
1381
1382   c = xmalloc (sizeof c->nonterm);
1383   c->nonterm.type = op;
1384   c->nonterm.n = 1;
1385   c->nonterm.arg[0] = n;
1386
1387   return c;
1388 }
1389
1390 static union any_node *
1391 allocate_binary_nonterminal (int op, union any_node *lhs, union any_node *rhs) 
1392 {
1393   union any_node *node;
1394
1395   node = xmalloc (sizeof node->nonterm + sizeof *node->nonterm.arg);
1396   node->nonterm.type = op;
1397   node->nonterm.n = 2;
1398   node->nonterm.arg[0] = lhs;
1399   node->nonterm.arg[1] = rhs;
1400
1401   return node;
1402 }
1403 \f
1404 static struct function func_tab[] =
1405 {
1406   {"ABS", OP_ABS, unary_func},
1407   {"ACOS", OP_ARCOS, unary_func},
1408   {"ARCOS", OP_ARCOS, unary_func},
1409   {"ARSIN", OP_ARSIN, unary_func},
1410   {"ARTAN", OP_ARTAN, unary_func},
1411   {"ASIN", OP_ARSIN, unary_func},
1412   {"ATAN", OP_ARTAN, unary_func},
1413   {"COS", OP_COS, unary_func},
1414   {"EXP", OP_EXP, unary_func},
1415   {"LG10", OP_LG10, unary_func},
1416   {"LN", OP_LN, unary_func},
1417   {"MOD10", OP_MOD10, unary_func},
1418   {"NORMAL", OP_NORMAL, unary_func},
1419   {"RND", OP_RND, unary_func},
1420   {"SIN", OP_SIN, unary_func},
1421   {"SQRT", OP_SQRT, unary_func},
1422   {"TAN", OP_TAN, unary_func},
1423   {"TRUNC", OP_TRUNC, unary_func},
1424   {"UNIFORM", OP_UNIFORM, unary_func},
1425
1426   {"TIME.DAYS", OP_TIME_DAYS, unary_func},
1427   {"TIME.HMS", OP_TIME_HMS, ternary_func},
1428
1429   {"CTIME.DAYS", OP_CTIME_DAYS, unary_func},
1430   {"CTIME.HOURS", OP_CTIME_HOURS, unary_func},
1431   {"CTIME.MINUTES", OP_CTIME_MINUTES, unary_func},
1432   {"CTIME.SECONDS", OP_CTIME_SECONDS, unary_func},
1433
1434   {"DATE.DMY", OP_DATE_DMY, ternary_func},
1435   {"DATE.MDY", OP_DATE_MDY, ternary_func},
1436   {"DATE.MOYR", OP_DATE_MOYR, binary_func},
1437   {"DATE.QYR", OP_DATE_QYR, binary_func},
1438   {"DATE.WKYR", OP_DATE_WKYR, binary_func},
1439   {"DATE.YRDAY", OP_DATE_YRDAY, binary_func},
1440
1441   {"XDATE.DATE", OP_XDATE_DATE, unary_func},
1442   {"XDATE.HOUR", OP_XDATE_HOUR, unary_func},
1443   {"XDATE.JDAY", OP_XDATE_JDAY, unary_func},
1444   {"XDATE.MDAY", OP_XDATE_MDAY, unary_func},
1445   {"XDATE.MINUTE", OP_XDATE_MINUTE, unary_func},
1446   {"XDATE.MONTH", OP_XDATE_MONTH, unary_func},
1447   {"XDATE.QUARTER", OP_XDATE_QUARTER, unary_func},
1448   {"XDATE.SECOND", OP_XDATE_SECOND, unary_func},
1449   {"XDATE.TDAY", OP_XDATE_TDAY, unary_func},
1450   {"XDATE.TIME", OP_XDATE_TIME, unary_func},
1451   {"XDATE.WEEK", OP_XDATE_WEEK, unary_func},
1452   {"XDATE.WKDAY", OP_XDATE_WKDAY, unary_func},
1453   {"XDATE.YEAR", OP_XDATE_YEAR, unary_func},
1454
1455   {"MISSING", OP_SYSMIS, MISSING_func},
1456   {"MOD", OP_MOD, binary_func},
1457   {"SYSMIS", OP_SYSMIS, SYSMIS_func},
1458   {"VALUE", OP_NUM_VAL, VALUE_func},
1459   {"LAG", OP_NUM_LAG, LAG_func},
1460   {"YRMODA", OP_YRMODA, ternary_func},
1461
1462   {"ANY", OP_ANY, nary_num_func},
1463   {"CFVAR", OP_CFVAR, nary_num_func},
1464   {"MAX", OP_MAX, nary_num_func},
1465   {"MEAN", OP_MEAN, nary_num_func},
1466   {"MIN", OP_MIN, nary_num_func},
1467   {"NMISS", OP_NMISS, nary_num_func},
1468   {"NVALID", OP_NVALID, nary_num_func},
1469   {"RANGE", OP_RANGE, nary_num_func},
1470   {"SD", OP_SD, nary_num_func},
1471   {"SUM", OP_SUM, nary_num_func},
1472   {"VAR", OP_VARIANCE, nary_num_func},
1473   {"VARIANCE", OP_VARIANCE, nary_num_func},
1474
1475   {"CONCAT", OP_CONCAT, CONCAT_func},
1476
1477   {"INDEX", OP_INDEX_2, generic_str_func},
1478   {"RINDEX", OP_RINDEX_2, generic_str_func},
1479   {"LENGTH", OP_LENGTH, generic_str_func},
1480   {"LOWER", OP_LOWER, generic_str_func},
1481   {"UPCASE", OP_UPPER, generic_str_func},
1482   {"LPAD", OP_LPAD, generic_str_func},
1483   {"RPAD", OP_RPAD, generic_str_func},
1484   {"LTRIM", OP_LTRIM, generic_str_func},
1485   {"RTRIM", OP_RTRIM, generic_str_func},
1486   {"NUMBER", OP_NUMBER, generic_str_func},
1487   {"STRING", OP_STRING, generic_str_func},
1488   {"SUBSTR", OP_SUBSTR_2, generic_str_func},
1489 };
1490
1491 /* An algo_compare_func that compares functions A and B based on
1492    their names. */
1493 static int
1494 compare_functions (const void *a_, const void *b_, void *aux UNUSED)
1495 {
1496   const struct function *a = a_;
1497   const struct function *b = b_;
1498
1499   return strcmp (a->s, b->s);
1500 }
1501
1502 static void
1503 init_func_tab (void)
1504 {
1505   {
1506     static int inited;
1507
1508     if (inited)
1509       return;
1510     inited = 1;
1511   }
1512
1513   func_count = sizeof func_tab / sizeof *func_tab;
1514   sort (func_tab, func_count, sizeof *func_tab, compare_functions, NULL);
1515 }
1516 \f
1517 /* Debug output. */
1518
1519 void
1520 expr_debug_print_postfix (const struct expression *e)
1521 {
1522   const unsigned char *o;
1523   const double *num = e->num;
1524   const unsigned char *str = e->str;
1525   struct variable *const *v = e->var;
1526   int t;
1527
1528   printf ("postfix:");
1529   for (o = e->op; *o != OP_SENTINEL;)
1530     {
1531       t = *o++;
1532       if (IS_NONTERMINAL (t))
1533         {
1534           printf (" %s", ops[t].name);
1535
1536           if (ops[t].flags & OP_VAR_ARGS)
1537             {
1538               printf ("(%d)", *o);
1539               o++;
1540             }
1541           if (ops[t].flags & OP_MIN_ARGS)
1542             {
1543               printf (".%d", *o);
1544               o++;
1545             }
1546           if (ops[t].flags & OP_FMT_SPEC)
1547             {
1548               struct fmt_spec f;
1549               f.type = (int) *o++;
1550               f.w = (int) *o++;
1551               f.d = (int) *o++;
1552               printf ("(%s)", fmt_to_string (&f));
1553             }
1554         }
1555       else if (t == OP_NUM_CON)
1556         {
1557           if (*num == SYSMIS)
1558             printf (" SYSMIS");
1559           else
1560             printf (" %f", *num);
1561           num++;
1562         }
1563       else if (t == OP_STR_CON)
1564         {
1565           printf (" \"%.*s\"", *str, &str[1]);
1566           str += str[0] + 1;
1567         }
1568       else if (t == OP_NUM_VAR || t == OP_STR_VAR)
1569         {
1570           printf (" %s", (*v)->name);
1571           v++;
1572         }
1573       else if (t == OP_NUM_SYS)
1574         {
1575           printf (" SYSMIS(#%d)", *o);
1576           o++;
1577         }
1578       else if (t == OP_NUM_VAL)
1579         {
1580           printf (" VALUE(#%d)", *o);
1581           o++;
1582         }
1583       else if (t == OP_NUM_LAG || t == OP_STR_LAG)
1584         {
1585           printf (" LAG(%s,%d)", (*v)->name, *o);
1586           o++;
1587           v++;
1588         }
1589       else
1590         {
1591           printf ("%d unknown\n", t);
1592           assert (0);
1593         }
1594     }
1595   putchar ('\n');
1596 }
1597 \f
1598 #define DEFINE_OPERATOR(NAME, STACK_DELTA, FLAGS, ARGS) \
1599         {#NAME, STACK_DELTA, FLAGS, ARGS},
1600 struct op_desc ops[OP_SENTINEL] =
1601   {
1602 #include "expr.def"
1603   };
1604 \f
1605 #include "command.h"
1606
1607 int
1608 cmd_debug_evaluate (void)
1609 {
1610   struct expression *expr;
1611   union value value;
1612   enum expr_type expr_flags;
1613   int dump_postfix = 0;
1614
1615   discard_variables ();
1616
1617   expr_flags = 0;
1618   if (lex_match_id ("NOOPTIMIZE"))
1619     expr_flags |= EXPR_NO_OPTIMIZE;
1620   if (lex_match_id ("POSTFIX"))
1621     dump_postfix = 1;
1622   if (token != '/') 
1623     {
1624       lex_force_match ('/');
1625       return CMD_FAILURE;
1626     }
1627   fprintf (stderr, "%s => ", lex_rest_of_line (NULL));
1628   lex_get ();
1629
1630   expr = expr_parse (EXPR_ANY | expr_flags);
1631   if (!expr || token != '.') 
1632     {
1633       if (expr != NULL)
1634         expr_free (expr);
1635       fprintf (stderr, "error\n");
1636       return CMD_FAILURE; 
1637     }
1638
1639   if (dump_postfix) 
1640     expr_debug_print_postfix (expr);
1641   else 
1642     {
1643       expr_evaluate (expr, NULL, 0, &value);
1644       switch (expr_get_type (expr)) 
1645         {
1646         case EXPR_NUMERIC:
1647           if (value.f == SYSMIS)
1648             fprintf (stderr, "sysmis\n");
1649           else
1650             fprintf (stderr, "%.2f\n", value.f);
1651           break;
1652       
1653         case EXPR_BOOLEAN:
1654           if (value.f == SYSMIS)
1655             fprintf (stderr, "sysmis\n");
1656           else if (value.f == 0.0)
1657             fprintf (stderr, "false\n");
1658           else
1659             fprintf (stderr, "true\n");
1660           break;
1661
1662         case EXPR_STRING:
1663           fputc ('"', stderr);
1664           fwrite (value.c + 1, value.c[0], 1, stderr);
1665           fputs ("\"\n", stderr);
1666           break;
1667
1668         default:
1669           assert (0);
1670         }
1671     }
1672   
1673   expr_free (expr);
1674   return CMD_SUCCESS;
1675 }