bc639cd8882b3bf07502029c3f1bf195789b32b8
[pspp] / src / expressions / parse.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., 51 Franklin Street, Fifth Floor, Boston, MA
18    02110-1301, USA. */
19
20 #include <config.h>
21 #include "private.h"
22 #include <ctype.h>
23 #include <float.h>
24 #include <limits.h>
25 #include <stdlib.h>
26 #include "algorithm.h"
27 #include "alloc.h"
28 #include "case.h"
29 #include "dictionary.h"
30 #include "error.h"
31 #include "helpers.h"
32 #include "lexer.h"
33 #include "misc.h"
34 #include "pool.h"
35 #include "settings.h"
36 #include "str.h"
37 #include "var.h"
38 #include "vfm.h"
39 \f
40 /* Declarations. */
41
42 /* Recursive descent parser in order of increasing precedence. */
43 typedef union any_node *parse_recursively_func (struct expression *);
44 static parse_recursively_func parse_or, parse_and, parse_not;
45 static parse_recursively_func parse_rel, parse_add, parse_mul;
46 static parse_recursively_func parse_neg, parse_exp;
47 static parse_recursively_func parse_primary;
48 static parse_recursively_func parse_vector_element, parse_function;
49
50 /* Utility functions. */
51 static struct expression *expr_create (struct dictionary *);
52 atom_type expr_node_returns (const union any_node *);
53
54 static const char *atom_type_name (atom_type);
55 static struct expression *finish_expression (union any_node *,
56                                              struct expression *);
57 static bool type_check (struct expression *, union any_node **,
58                         enum expr_type expected_type);
59 static union any_node *allocate_unary_variable (struct expression *,
60                                                 struct variable *); 
61 \f
62 /* Public functions. */
63
64 /* Parses an expression of the given TYPE.
65    If DICT is nonnull then variables and vectors within it may be
66    referenced within the expression; otherwise, the expression
67    must not reference any variables or vectors.
68    Returns the new expression if successful or a null pointer
69    otherwise. */
70 struct expression *
71 expr_parse (struct dictionary *dict, enum expr_type type) 
72 {
73   union any_node *n;
74   struct expression *e;
75
76   assert (type == EXPR_NUMBER || type == EXPR_STRING || type == EXPR_BOOLEAN);
77
78   e = expr_create (dict);
79   n = parse_or (e);
80   if (n != NULL && type_check (e, &n, type))
81     return finish_expression (expr_optimize (n, e), e);
82   else
83     {
84       expr_free (e);
85       return NULL; 
86     }
87 }
88
89 /* Free expression E. */
90 void
91 expr_free (struct expression *e)
92 {
93   if (e != NULL)
94     pool_destroy (e->expr_pool);
95 }
96
97 struct expression *
98 expr_parse_any (struct dictionary *dict, bool optimize)
99 {
100   union any_node *n;
101   struct expression *e;
102
103   e = expr_create (dict);
104   n = parse_or (e);
105   if (n == NULL)
106     {
107       expr_free (e);
108       return NULL;
109     }
110   
111   if (optimize)
112     n = expr_optimize (n, e);
113   return finish_expression (n, e);
114 }
115 \f
116 /* Finishing up expression building. */
117
118 /* Height of an expression's stacks. */
119 struct stack_heights 
120   {
121     int number_height;  /* Height of number stack. */
122     int string_height;  /* Height of string stack. */
123   };
124
125 /* Stack heights used by different kinds of arguments. */
126 static const struct stack_heights on_number_stack = {1, 0};
127 static const struct stack_heights on_string_stack = {0, 1};
128 static const struct stack_heights not_on_stack = {0, 0};
129
130 /* Returns the stack heights used by an atom of the given
131    TYPE. */
132 static const struct stack_heights *
133 atom_type_stack (atom_type type)
134 {
135   assert (is_atom (type));
136   
137   switch (type) 
138     {
139     case OP_number:
140     case OP_boolean:
141       return &on_number_stack;
142
143     case OP_string:
144       return &on_string_stack;
145
146     case OP_format:
147     case OP_ni_format:
148     case OP_no_format:
149     case OP_num_var:
150     case OP_str_var:
151     case OP_integer:
152     case OP_pos_int:
153     case OP_vector:
154       return &not_on_stack;
155           
156     default:
157       abort ();
158     }
159 }
160
161 /* Measures the stack height needed for node N, supposing that
162    the stack height is initially *HEIGHT and updating *HEIGHT to
163    the final stack height.  Updates *MAX, if necessary, to
164    reflect the maximum intermediate or final height. */
165 static void
166 measure_stack (const union any_node *n,
167                struct stack_heights *height, struct stack_heights *max)
168 {
169   const struct stack_heights *return_height;
170
171   if (is_composite (n->type)) 
172     {
173       struct stack_heights args;
174       int i;
175
176       args = *height;
177       for (i = 0; i < n->composite.arg_cnt; i++)
178         measure_stack (n->composite.args[i], &args, max);
179
180       return_height = atom_type_stack (operations[n->type].returns);
181     }
182   else
183     return_height = atom_type_stack (n->type);
184
185   height->number_height += return_height->number_height;
186   height->string_height += return_height->string_height;
187
188   if (height->number_height > max->number_height)
189     max->number_height = height->number_height;
190   if (height->string_height > max->string_height)
191     max->string_height = height->string_height;
192 }
193
194 /* Allocates stacks within E sufficient for evaluating node N. */
195 static void
196 allocate_stacks (union any_node *n, struct expression *e) 
197 {
198   struct stack_heights initial = {0, 0};
199   struct stack_heights max = {0, 0};
200
201   measure_stack (n, &initial, &max);
202   e->number_stack = pool_alloc (e->expr_pool,
203                                 sizeof *e->number_stack * max.number_height);
204   e->string_stack = pool_alloc (e->expr_pool,
205                                 sizeof *e->string_stack * max.string_height);
206 }
207
208 /* Finalizes expression E for evaluating node N. */
209 static struct expression *
210 finish_expression (union any_node *n, struct expression *e)
211 {
212   /* Allocate stacks. */
213   allocate_stacks (n, e);
214
215   /* Output postfix representation. */
216   expr_flatten (n, e);
217
218   /* The eval_pool might have been used for allocating strings
219      during optimization.  We need to keep those strings around
220      for all subsequent evaluations, so start a new eval_pool. */
221   e->eval_pool = pool_create_subpool (e->expr_pool);
222
223   return e;
224 }
225
226 /* Verifies that expression E, whose root node is *N, can be
227    converted to type EXPECTED_TYPE, inserting a conversion at *N
228    if necessary.  Returns true if successful, false on failure. */
229 static bool
230 type_check (struct expression *e,
231             union any_node **n, enum expr_type expected_type)
232 {
233   atom_type actual_type = expr_node_returns (*n);
234
235   switch (expected_type) 
236     {
237     case EXPR_BOOLEAN:
238     case EXPR_NUMBER:
239       if (actual_type != OP_number && actual_type != OP_boolean)
240         {
241           msg (SE, _("Type mismatch: expression has %s type, "
242                      "but a numeric value is required here."),
243                atom_type_name (actual_type));
244           return false;
245         }
246       if (actual_type == OP_number && expected_type == OP_boolean)
247         *n = expr_allocate_unary (e, OP_NUM_TO_BOOLEAN, *n);
248       break;
249       
250     case EXPR_STRING:
251       if (actual_type != OP_string)
252         {
253           msg (SE, _("Type mismatch: expression has %s type, "
254                      "but a string value is required here."),
255                atom_type_name (actual_type));
256           return false;
257         }
258       break;
259
260     default:
261       abort ();
262     }
263   
264   return true;
265 }
266 \f
267 /* Recursive-descent expression parser. */
268
269 /* Considers whether *NODE may be coerced to type REQUIRED_TYPE.
270    Returns true if possible, false if disallowed.
271
272    If DO_COERCION is false, then *NODE is not modified and there
273    are no side effects.
274
275    If DO_COERCION is true, we perform the coercion if possible,
276    modifying *NODE if necessary.  If the coercion is not possible
277    then we free *NODE and set *NODE to a null pointer.
278
279    This function's interface is somewhat awkward.  Use one of the
280    wrapper functions type_coercion(), type_coercion_assert(), or
281    is_coercible() instead. */
282 static bool
283 type_coercion_core (struct expression *e,
284                     atom_type required_type,
285                     union any_node **node,
286                     const char *operator_name,
287                     bool do_coercion) 
288 {
289   atom_type actual_type;
290
291   assert (!!do_coercion == (e != NULL));
292   if (*node == NULL) 
293     {
294       /* Propagate error.  Whatever caused the original error
295          already emitted an error message. */
296       return false;
297     }
298
299   actual_type = expr_node_returns (*node);
300   if (actual_type == required_type) 
301     {
302       /* Type match. */
303       return true; 
304     }
305
306   switch (required_type) 
307     {
308     case OP_number:
309       if (actual_type == OP_boolean) 
310         {
311           /* To enforce strict typing rules, insert Boolean to
312              numeric "conversion".  This conversion is a no-op,
313              so it will be removed later. */
314           if (do_coercion)
315             *node = expr_allocate_unary (e, OP_BOOLEAN_TO_NUM, *node);
316           return true; 
317         }
318       break;
319
320     case OP_string:
321       /* No coercion to string. */
322       break;
323
324     case OP_boolean:
325       if (actual_type == OP_number)
326         {
327           /* Convert numeric to boolean. */
328           if (do_coercion)
329             *node = expr_allocate_unary (e, OP_NUM_TO_BOOLEAN, *node);
330           return true;
331         }
332       break;
333
334     case OP_format:
335       abort ();
336
337     case OP_ni_format:
338       if ((*node)->type == OP_format
339           && check_input_specifier (&(*node)->format.f, false)
340           && check_specifier_type (&(*node)->format.f, NUMERIC, false))
341         {
342           if (do_coercion)
343             (*node)->type = OP_ni_format;
344           return true;
345         }
346       break;
347
348     case OP_no_format:
349       if ((*node)->type == OP_format
350           && check_output_specifier (&(*node)->format.f, false)
351           && check_specifier_type (&(*node)->format.f, NUMERIC, false))
352         {
353           if (do_coercion)
354             (*node)->type = OP_no_format;
355           return true;
356         }
357       break;
358
359     case OP_num_var:
360       if ((*node)->type == OP_NUM_VAR)
361         {
362           if (do_coercion)
363             *node = (*node)->composite.args[0];
364           return true;
365         }
366       break;
367
368     case OP_str_var:
369       if ((*node)->type == OP_STR_VAR)
370         {
371           if (do_coercion)
372             *node = (*node)->composite.args[0];
373           return true;
374         }
375       break;
376
377     case OP_pos_int:
378       if ((*node)->type == OP_number
379           && floor ((*node)->number.n) == (*node)->number.n
380           && (*node)->number.n > 0 && (*node)->number.n < INT_MAX) 
381         {
382           if (do_coercion)
383             *node = expr_allocate_pos_int (e, (*node)->number.n);
384           return true;
385         }
386       break;
387
388     default:
389       abort ();
390     }
391
392   if (do_coercion) 
393     {
394       msg (SE, _("Type mismatch while applying %s operator: "
395                  "cannot convert %s to %s."),
396            operator_name,
397            atom_type_name (actual_type), atom_type_name (required_type));
398       *node = NULL;
399     }
400   return false;
401 }
402
403 /* Coerces *NODE to type REQUIRED_TYPE, and returns success.  If
404    *NODE cannot be coerced to the desired type then we issue an
405    error message about operator OPERATOR_NAME and free *NODE. */
406 static bool
407 type_coercion (struct expression *e,
408                atom_type required_type, union any_node **node,
409                const char *operator_name)
410 {
411   return type_coercion_core (e, required_type, node, operator_name, true);
412 }
413
414 /* Coerces *NODE to type REQUIRED_TYPE.
415    Assert-fails if the coercion is disallowed. */
416 static void
417 type_coercion_assert (struct expression *e,
418                       atom_type required_type, union any_node **node)
419 {
420   int success = type_coercion_core (e, required_type, node, NULL, true);
421   assert (success);
422 }
423
424 /* Returns true if *NODE may be coerced to type REQUIRED_TYPE,
425    false otherwise. */
426 static bool
427 is_coercible (atom_type required_type, union any_node *const *node)
428 {
429   return type_coercion_core (NULL, required_type,
430                              (union any_node **) node, NULL, false);
431 }
432
433 /* How to parse an operator. */
434 struct operator
435   {
436     int token;                  /* Token representing operator. */
437     operation_type type;        /* Operation type representing operation. */
438     const char *name;           /* Name of operator. */
439   };
440
441 /* Attempts to match the current token against the tokens for the
442    OP_CNT operators in OPS[].  If successful, returns true
443    and, if OPERATOR is non-null, sets *OPERATOR to the operator.
444    On failure, returns false and, if OPERATOR is non-null, sets
445    *OPERATOR to a null pointer. */
446 static bool
447 match_operator (const struct operator ops[], size_t op_cnt,
448                 const struct operator **operator) 
449 {
450   const struct operator *op;
451
452   for (op = ops; op < ops + op_cnt; op++)
453     {
454       if (op->token == '-')
455         lex_negative_to_dash ();
456       if (lex_match (op->token)) 
457         {
458           if (operator != NULL)
459             *operator = op;
460           return true;
461         }
462     }
463   if (operator != NULL)
464     *operator = NULL;
465   return false;
466 }
467
468 static bool
469 check_operator (const struct operator *op, int arg_cnt, atom_type arg_type) 
470 {
471   const struct operation *o;
472   size_t i;
473
474   assert (op != NULL);
475   o = &operations[op->type];
476   assert (o->arg_cnt == arg_cnt);
477   assert ((o->flags & OPF_ARRAY_OPERAND) == 0);
478   for (i = 0; i < arg_cnt; i++) 
479     assert (o->args[i] == arg_type);
480   return true;
481 }
482
483 static bool
484 check_binary_operators (const struct operator ops[], size_t op_cnt,
485                         atom_type arg_type)
486 {
487   size_t i;
488
489   for (i = 0; i < op_cnt; i++)
490     check_operator (&ops[i], 2, arg_type);
491   return true;
492 }
493
494 static atom_type
495 get_operand_type (const struct operator *op) 
496 {
497   return operations[op->type].args[0];
498 }
499
500 /* Parses a chain of left-associative operator/operand pairs.
501    There are OP_CNT operators, specified in OPS[].  The
502    operators' operands must all be the same type.  The next
503    higher level is parsed by PARSE_NEXT_LEVEL.  If CHAIN_WARNING
504    is non-null, then it will be issued as a warning if more than
505    one operator/operand pair is parsed. */
506 static union any_node *
507 parse_binary_operators (struct expression *e, union any_node *node,
508                         const struct operator ops[], size_t op_cnt,
509                         parse_recursively_func *parse_next_level,
510                         const char *chain_warning)
511 {
512   atom_type operand_type = get_operand_type (&ops[0]);
513   int op_count;
514   const struct operator *operator;
515
516   assert (check_binary_operators (ops, op_cnt, operand_type));
517   if (node == NULL)
518     return node;
519
520   for (op_count = 0; match_operator (ops, op_cnt, &operator); op_count++)
521     {
522       union any_node *rhs;
523
524       /* Convert the left-hand side to type OPERAND_TYPE. */
525       if (!type_coercion (e, operand_type, &node, operator->name))
526         return NULL;
527
528       /* Parse the right-hand side and coerce to type
529          OPERAND_TYPE. */
530       rhs = parse_next_level (e);
531       if (!type_coercion (e, operand_type, &rhs, operator->name))
532         return NULL;
533       node = expr_allocate_binary (e, operator->type, node, rhs);
534     }
535
536   if (op_count > 1 && chain_warning != NULL)
537     msg (SW, chain_warning);
538
539   return node;
540 }
541
542 static union any_node *
543 parse_inverting_unary_operator (struct expression *e,
544                                 const struct operator *op,
545                                 parse_recursively_func *parse_next_level) 
546 {
547   union any_node *node;
548   unsigned op_count;
549
550   check_operator (op, 1, get_operand_type (op));
551
552   op_count = 0;
553   while (match_operator (op, 1, NULL))
554     op_count++;
555
556   node = parse_next_level (e);
557   if (op_count > 0
558       && type_coercion (e, get_operand_type (op), &node, op->name)
559       && op_count % 2 != 0)
560     return expr_allocate_unary (e, op->type, node);
561   else
562     return node;
563 }
564
565 /* Parses the OR level. */
566 static union any_node *
567 parse_or (struct expression *e)
568 {
569   static const struct operator op = 
570     { T_OR, OP_OR, "logical disjunction (\"OR\")" };
571   
572   return parse_binary_operators (e, parse_and (e), &op, 1, parse_and, NULL);
573 }
574
575 /* Parses the AND level. */
576 static union any_node *
577 parse_and (struct expression *e)
578 {
579   static const struct operator op = 
580     { T_AND, OP_AND, "logical conjunction (\"AND\")" };
581   
582   return parse_binary_operators (e, parse_not (e), &op, 1, parse_not, NULL);
583 }
584
585 /* Parses the NOT level. */
586 static union any_node *
587 parse_not (struct expression *e)
588 {
589   static const struct operator op
590     = { T_NOT, OP_NOT, "logical negation (\"NOT\")" };
591   return parse_inverting_unary_operator (e, &op, parse_rel);
592 }
593
594 /* Parse relational operators. */
595 static union any_node *
596 parse_rel (struct expression *e)
597 {
598   const char *chain_warning = 
599     _("Chaining relational operators (e.g. \"a < b < c\") will "
600       "not produce the mathematically expected result.  "
601       "Use the AND logical operator to fix the problem "
602       "(e.g. \"a < b AND b < c\").  "
603       "If chaining is really intended, parentheses will disable "
604       "this warning (e.g. \"(a < b) < c\".)");
605
606   union any_node *node = parse_add (e);
607
608   if (node == NULL)
609     return NULL;
610   
611   switch (expr_node_returns (node)) 
612     {
613     case OP_number:
614     case OP_boolean: 
615       {
616         static const struct operator ops[] =
617           {
618             { '=', OP_EQ, "numeric equality (\"=\")" },
619             { T_EQ, OP_EQ, "numeric equality (\"EQ\")" },
620             { T_GE, OP_GE, "numeric greater-than-or-equal-to (\">=\")" },
621             { T_GT, OP_GT, "numeric greater than (\">\")" },
622             { T_LE, OP_LE, "numeric less-than-or-equal-to (\"<=\")" },
623             { T_LT, OP_LT, "numeric less than (\"<\")" },
624             { T_NE, OP_NE, "numeric inequality (\"<>\")" },
625           };
626
627         return parse_binary_operators (e, node, ops, sizeof ops / sizeof *ops,
628                                        parse_add, chain_warning);
629       }
630       
631     case OP_string:
632       {
633         static const struct operator ops[] =
634           {
635             { '=', OP_EQ_STRING, "string equality (\"=\")" },
636             { T_EQ, OP_EQ_STRING, "string equality (\"EQ\")" },
637             { T_GE, OP_GE_STRING, "string greater-than-or-equal-to (\">=\")" },
638             { T_GT, OP_GT_STRING, "string greater than (\">\")" },
639             { T_LE, OP_LE_STRING, "string less-than-or-equal-to (\"<=\")" },
640             { T_LT, OP_LT_STRING, "string less than (\"<\")" },
641             { T_NE, OP_NE_STRING, "string inequality (\"<>\")" },
642           };
643
644         return parse_binary_operators (e, node, ops, sizeof ops / sizeof *ops,
645                                        parse_add, chain_warning);
646       }
647       
648     default:
649       return node;
650     }
651 }
652
653 /* Parses the addition and subtraction level. */
654 static union any_node *
655 parse_add (struct expression *e)
656 {
657   static const struct operator ops[] = 
658     {
659       { '+', OP_ADD, "addition (\"+\")" },
660       { '-', OP_SUB, "subtraction (\"-\")" },
661     };
662   
663   return parse_binary_operators (e, parse_mul (e),
664                                  ops, sizeof ops / sizeof *ops,
665                                  parse_mul, NULL);
666 }
667
668 /* Parses the multiplication and division level. */
669 static union any_node *
670 parse_mul (struct expression *e)
671 {
672   static const struct operator ops[] = 
673     {
674       { '*', OP_MUL, "multiplication (\"*\")" },
675       { '/', OP_DIV, "division (\"/\")" },
676     };
677   
678   return parse_binary_operators (e, parse_neg (e),
679                                  ops, sizeof ops / sizeof *ops,
680                                  parse_neg, NULL);
681 }
682
683 /* Parses the unary minus level. */
684 static union any_node *
685 parse_neg (struct expression *e)
686 {
687   static const struct operator op = { '-', OP_NEG, "negation (\"-\")" };
688   return parse_inverting_unary_operator (e, &op, parse_exp);
689 }
690
691 static union any_node *
692 parse_exp (struct expression *e)
693 {
694   static const struct operator op = 
695     { T_EXP, OP_POW, "exponentiation (\"**\")" };
696   
697   const char *chain_warning = 
698     _("The exponentiation operator (\"**\") is left-associative, "
699       "even though right-associative semantics are more useful.  "
700       "That is, \"a**b**c\" equals \"(a**b)**c\", not as \"a**(b**c)\".  "
701       "To disable this warning, insert parentheses.");
702
703   return parse_binary_operators (e, parse_primary (e), &op, 1,
704                                  parse_primary, chain_warning);
705 }
706
707 /* Parses system variables. */
708 static union any_node *
709 parse_sysvar (struct expression *e)
710 {
711   if (lex_match_id ("$CASENUM"))
712     return expr_allocate_nullary (e, OP_CASENUM);
713   else if (lex_match_id ("$DATE"))
714     {
715       static const char *months[12] =
716         {
717           "JAN", "FEB", "MAR", "APR", "MAY", "JUN",
718           "JUL", "AUG", "SEP", "OCT", "NOV", "DEC",
719         };
720
721       struct tm *time;
722       char temp_buf[10];
723
724       time = localtime (&last_vfm_invocation);
725       sprintf (temp_buf, "%02d %s %02d", abs (time->tm_mday) % 100,
726                months[abs (time->tm_mon) % 12], abs (time->tm_year) % 100);
727
728       return expr_allocate_string_buffer (e, temp_buf, strlen (temp_buf));
729     }
730   else if (lex_match_id ("$TRUE"))
731     return expr_allocate_boolean (e, 1.0);
732   else if (lex_match_id ("$FALSE"))
733     return expr_allocate_boolean (e, 0.0);
734   else if (lex_match_id ("$SYSMIS"))
735     return expr_allocate_number (e, SYSMIS);
736   else if (lex_match_id ("$JDATE"))
737     {
738       struct tm *time = localtime (&last_vfm_invocation);
739       return expr_allocate_number (e, expr_ymd_to_ofs (time->tm_year + 1900,
740                                                        time->tm_mon + 1,
741                                                        time->tm_mday));
742     }
743   else if (lex_match_id ("$TIME"))
744     {
745       struct tm *time = localtime (&last_vfm_invocation);
746       return expr_allocate_number (e,
747                                    expr_ymd_to_date (time->tm_year + 1900,
748                                                      time->tm_mon + 1,
749                                                      time->tm_mday)
750                                    + time->tm_hour * 60 * 60.
751                                    + time->tm_min * 60.
752                                    + time->tm_sec);
753     }
754   else if (lex_match_id ("$LENGTH"))
755     return expr_allocate_number (e, get_viewlength ());
756   else if (lex_match_id ("$WIDTH"))
757     return expr_allocate_number (e, get_viewwidth ());
758   else
759     {
760       msg (SE, _("Unknown system variable %s."), tokid);
761       return NULL;
762     }
763 }
764
765 /* Parses numbers, varnames, etc. */
766 static union any_node *
767 parse_primary (struct expression *e)
768 {
769   switch (token)
770     {
771     case T_ID:
772       if (lex_look_ahead () == '(') 
773         {
774           /* An identifier followed by a left parenthesis may be
775              a vector element reference.  If not, it's a function
776              call. */
777           if (e->dict != NULL && dict_lookup_vector (e->dict, tokid) != NULL) 
778             return parse_vector_element (e);
779           else
780             return parse_function (e);
781         }
782       else if (tokid[0] == '$')
783         {
784           /* $ at the beginning indicates a system variable. */
785           return parse_sysvar (e);
786         }
787       else if (e->dict != NULL && dict_lookup_var (e->dict, tokid))
788         {
789           /* It looks like a user variable.
790              (It could be a format specifier, but we'll assume
791              it's a variable unless proven otherwise. */
792           return allocate_unary_variable (e, parse_dict_variable (e->dict));
793         }
794       else 
795         {
796           /* Try to parse it as a format specifier. */
797           struct fmt_spec fmt;
798           if (parse_format_specifier (&fmt, FMTP_SUPPRESS_ERRORS))
799             return expr_allocate_format (e, &fmt);
800
801           /* All attempts failed. */
802           msg (SE, _("Unknown identifier %s."), tokid);
803           return NULL;
804         }
805       break;
806       
807     case T_POS_NUM: 
808     case T_NEG_NUM: 
809       {
810         union any_node *node = expr_allocate_number (e, tokval);
811         lex_get ();
812         return node; 
813       }
814
815     case T_STRING:
816       {
817         union any_node *node = expr_allocate_string_buffer (e, ds_c_str (&tokstr),
818                                                        ds_length (&tokstr));
819         lex_get ();
820         return node;
821       }
822
823     case '(':
824       {
825         union any_node *node;
826         lex_get ();
827         node = parse_or (e);
828         if (node != NULL && !lex_match (')'))
829           {
830             lex_error (_("expecting `)'"));
831             return NULL;
832           }
833         return node;
834       }
835
836     default:
837       lex_error (_("in expression"));
838       return NULL;
839     }
840 }
841
842 static union any_node *
843 parse_vector_element (struct expression *e)
844 {
845   const struct vector *vector;
846   union any_node *element;
847
848   /* Find vector, skip token.
849      The caller must already have verified that the current token
850      is the name of a vector. */
851   vector = dict_lookup_vector (default_dict, tokid);
852   assert (vector != NULL);
853   lex_get ();
854
855   /* Skip left parenthesis token.
856      The caller must have verified that the lookahead is a left
857      parenthesis. */
858   assert (token == '(');
859   lex_get ();
860
861   element = parse_or (e);
862   if (!type_coercion (e, OP_number, &element, "vector indexing")
863       || !lex_match (')'))
864     return NULL;
865
866   return expr_allocate_binary (e, (vector->var[0]->type == NUMERIC
867                                    ? OP_VEC_ELEM_NUM : OP_VEC_ELEM_STR),
868                                element, expr_allocate_vector (e, vector));
869 }
870 \f
871 /* Individual function parsing. */
872
873 struct operation operations[OP_first + OP_cnt] = {
874 #include "parse.inc"
875 };
876     
877 static bool
878 word_matches (const char **test, const char **name) 
879 {
880   size_t test_len = strcspn (*test, ".");
881   size_t name_len = strcspn (*name, ".");
882   if (test_len == name_len) 
883     {
884       if (buf_compare_case (*test, *name, test_len))
885         return false;
886     }
887   else if (test_len < 3 || test_len > name_len)
888     return false;
889   else 
890     {
891       if (buf_compare_case (*test, *name, test_len))
892         return false;
893     }
894
895   *test += test_len;
896   *name += name_len;
897   if (**test != **name)
898     return false;
899
900   if (**test == '.')
901     {
902       (*test)++;
903       (*name)++;
904     }
905   return true;
906 }
907
908 static int
909 compare_names (const char *test, const char *name) 
910 {
911   for (;;) 
912     {
913       if (!word_matches (&test, &name))
914         return true;
915       if (*name == '\0' && *test == '\0')
916         return false;
917     }
918 }
919
920 static int
921 compare_strings (const char *test, const char *name) 
922 {
923   return strcasecmp (test, name);
924 }
925
926 static bool
927 lookup_function_helper (const char *name,
928                         int (*compare) (const char *test, const char *name),
929                         const struct operation **first,
930                         const struct operation **last)
931 {
932   struct operation *f;
933   
934   for (f = operations + OP_function_first;
935        f <= operations + OP_function_last; f++) 
936     if (!compare (name, f->name)) 
937       {
938         *first = f;
939
940         while (f <= operations + OP_function_last && !compare (name, f->name))
941           f++;
942         *last = f;
943
944         return true;
945       }  
946
947   return false;
948 }
949
950 static bool
951 lookup_function (const char *name,
952                  const struct operation **first,
953                  const struct operation **last) 
954 {
955   *first = *last = NULL;
956   return (lookup_function_helper (name, compare_strings, first, last)
957           || lookup_function_helper (name, compare_names, first, last));
958 }
959
960 static int
961 extract_min_valid (char *s) 
962 {
963   char *p = strrchr (s, '.');
964   if (p == NULL
965       || p[1] < '0' || p[1] > '9'
966       || strspn (p + 1, "0123456789") != strlen (p + 1))
967     return -1;
968   *p = '\0';
969   return atoi (p + 1);
970 }
971
972 static atom_type
973 function_arg_type (const struct operation *f, size_t arg_idx) 
974 {
975   assert (arg_idx < f->arg_cnt || (f->flags & OPF_ARRAY_OPERAND));
976
977   return f->args[arg_idx < f->arg_cnt ? arg_idx : f->arg_cnt - 1];
978 }
979
980 static bool
981 match_function (union any_node **args, int arg_cnt, const struct operation *f)
982 {
983   size_t i;
984
985   if (arg_cnt < f->arg_cnt
986       || (arg_cnt > f->arg_cnt && (f->flags & OPF_ARRAY_OPERAND) == 0)
987       || arg_cnt - (f->arg_cnt - 1) < f->array_min_elems)
988     return false;
989
990   for (i = 0; i < arg_cnt; i++)
991     if (!is_coercible (function_arg_type (f, i), &args[i]))
992       return false; 
993
994   return true;
995 }
996
997 static void
998 coerce_function_args (struct expression *e, const struct operation *f,
999                       union any_node **args, size_t arg_cnt) 
1000 {
1001   int i;
1002   
1003   for (i = 0; i < arg_cnt; i++)
1004     type_coercion_assert (e, function_arg_type (f, i), &args[i]);
1005 }
1006
1007 static bool
1008 validate_function_args (const struct operation *f, int arg_cnt, int min_valid) 
1009 {
1010   int array_arg_cnt = arg_cnt - (f->arg_cnt - 1);
1011   if (array_arg_cnt < f->array_min_elems) 
1012     {
1013       msg (SE, _("%s must have at least %d arguments in list."),
1014            f->prototype, f->array_min_elems);
1015       return false;
1016     }
1017
1018   if ((f->flags & OPF_ARRAY_OPERAND)
1019       && array_arg_cnt % f->array_granularity != 0) 
1020     {
1021       if (f->array_granularity == 2)
1022         msg (SE, _("%s must have even number of arguments in list."),
1023              f->prototype);
1024       else
1025         msg (SE, _("%s must have multiple of %d arguments in list."),
1026              f->prototype, f->array_granularity);
1027       return false;
1028     }
1029   
1030   if (min_valid != -1) 
1031     {
1032       if (f->array_min_elems == 0) 
1033         {
1034           assert ((f->flags & OPF_MIN_VALID) == 0);
1035           msg (SE, _("%s function does not accept a minimum valid "
1036                      "argument count."), f->prototype);
1037           return false;
1038         }
1039       else 
1040         {
1041           assert (f->flags & OPF_MIN_VALID);
1042           if (array_arg_cnt < f->array_min_elems)
1043             {
1044               msg (SE, _("%s requires at least %d valid arguments in list."),
1045                    f->prototype, f->array_min_elems);
1046               return false;
1047             }
1048           else if (min_valid > array_arg_cnt) 
1049             {
1050               msg (SE, _("With %s, "
1051                          "using minimum valid argument count of %d "
1052                          "does not make sense when passing only %d "
1053                          "arguments in list."),
1054                    f->prototype, min_valid, array_arg_cnt);
1055               return false;
1056             }
1057         }
1058     }
1059
1060   return true;
1061 }
1062
1063 static void
1064 add_arg (union any_node ***args, int *arg_cnt, int *arg_cap,
1065          union any_node *arg)
1066 {
1067   if (*arg_cnt >= *arg_cap) 
1068     {
1069       *arg_cap += 8;
1070       *args = xrealloc (*args, sizeof **args * *arg_cap);
1071     }
1072
1073   (*args)[(*arg_cnt)++] = arg;
1074 }
1075
1076 static void
1077 put_invocation (struct string *s,
1078                 const char *func_name, union any_node **args, size_t arg_cnt) 
1079 {
1080   size_t i;
1081
1082   ds_printf (s, "%s(", func_name);
1083   for (i = 0; i < arg_cnt; i++)
1084     {
1085       if (i > 0)
1086         ds_puts (s, ", ");
1087       ds_puts (s, operations[expr_node_returns (args[i])].prototype);
1088     }
1089   ds_putc (s, ')');
1090 }
1091
1092 static void
1093 no_match (const char *func_name,
1094           union any_node **args, size_t arg_cnt,
1095           const struct operation *first, const struct operation *last) 
1096 {
1097   struct string s;
1098   const struct operation *f;
1099
1100   ds_init (&s, 128);
1101
1102   if (last - first == 1) 
1103     {
1104       ds_printf (&s, _("Type mismatch invoking %s as "), first->prototype);
1105       put_invocation (&s, func_name, args, arg_cnt);
1106     }
1107   else 
1108     {
1109       ds_puts (&s, _("Function invocation "));
1110       put_invocation (&s, func_name, args, arg_cnt);
1111       ds_puts (&s, _(" does not match any known function.  Candidates are:"));
1112
1113       for (f = first; f < last; f++)
1114         ds_printf (&s, "\n%s", f->prototype);
1115     }
1116   ds_putc (&s, '.');
1117
1118   msg (SE, "%s", ds_c_str (&s));
1119     
1120   ds_destroy (&s);
1121 }
1122
1123 static union any_node *
1124 parse_function (struct expression *e)
1125 {
1126   int min_valid;
1127   const struct operation *f, *first, *last;
1128
1129   union any_node **args = NULL;
1130   int arg_cnt = 0;
1131   int arg_cap = 0;
1132
1133   struct fixed_string func_name;
1134
1135   union any_node *n;
1136
1137   ls_create (&func_name, ds_c_str (&tokstr));
1138   min_valid = extract_min_valid (ds_c_str (&tokstr));
1139   if (!lookup_function (ds_c_str (&tokstr), &first, &last)) 
1140     {
1141       msg (SE, _("No function or vector named %s."), ds_c_str (&tokstr));
1142       ls_destroy (&func_name);
1143       return NULL;
1144     }
1145
1146   lex_get ();
1147   if (!lex_force_match ('(')) 
1148     {
1149       ls_destroy (&func_name);
1150       return NULL; 
1151     }
1152   
1153   args = NULL;
1154   arg_cnt = arg_cap = 0;
1155   if (token != ')')
1156     for (;;)
1157       {
1158         if (token == T_ID && lex_look_ahead () == 'T')
1159           {
1160             struct variable **vars;
1161             int var_cnt;
1162             int i;
1163
1164             if (!parse_variables (default_dict, &vars, &var_cnt, PV_SINGLE))
1165               goto fail;
1166             for (i = 0; i < var_cnt; i++)
1167               add_arg (&args, &arg_cnt, &arg_cap,
1168                        allocate_unary_variable (e, vars[i]));
1169             free (vars);
1170           }
1171         else
1172           {
1173             union any_node *arg = parse_or (e);
1174             if (arg == NULL)
1175               goto fail;
1176
1177             add_arg (&args, &arg_cnt, &arg_cap, arg);
1178           }
1179         if (lex_match (')'))
1180           break;
1181         else if (!lex_match (','))
1182           {
1183             lex_error (_("expecting `,' or `)' invoking %s function"),
1184                        first->name);
1185             goto fail;
1186           }
1187       }
1188
1189   for (f = first; f < last; f++)
1190     if (match_function (args, arg_cnt, f))
1191       break;
1192   if (f >= last) 
1193     {
1194       no_match (ls_c_str (&func_name), args, arg_cnt, first, last);
1195       goto fail;
1196     }
1197
1198   coerce_function_args (e, f, args, arg_cnt);
1199   if (!validate_function_args (f, arg_cnt, min_valid))
1200     goto fail;
1201
1202   if ((f->flags & OPF_EXTENSION) && get_syntax () == COMPATIBLE)
1203     msg (SW, _("%s is a PSPP extension."), f->prototype);
1204   if (f->flags & OPF_UNIMPLEMENTED) 
1205     {
1206       msg (SE, _("%s is not yet implemented."), f->prototype);
1207       goto fail;
1208     }
1209   
1210   n = expr_allocate_composite (e, f - operations, args, arg_cnt);
1211   n->composite.min_valid = min_valid != -1 ? min_valid : f->array_min_elems; 
1212
1213   if (n->type == OP_LAG_Vn || n->type == OP_LAG_Vs) 
1214     {
1215       if (n_lag < 1)
1216         n_lag = 1; 
1217     }
1218   else if (n->type == OP_LAG_Vnn || n->type == OP_LAG_Vsn)
1219     {
1220       int n_before;
1221       assert (n->composite.arg_cnt == 2);
1222       assert (n->composite.args[1]->type == OP_pos_int);
1223       n_before = n->composite.args[1]->integer.i;
1224       if (n_lag < n_before)
1225         n_lag = n_before;
1226     }
1227   
1228   free (args);
1229   ls_destroy (&func_name);
1230   return n;
1231
1232 fail:
1233   free (args);
1234   ls_destroy (&func_name);
1235   return NULL;
1236 }
1237 \f
1238 /* Utility functions. */
1239
1240 static struct expression *
1241 expr_create (struct dictionary *dict)
1242 {
1243   struct pool *pool = pool_create ();
1244   struct expression *e = pool_alloc (pool, sizeof *e);
1245   e->expr_pool = pool;
1246   e->dict = dict;
1247   e->eval_pool = pool_create_subpool (e->expr_pool);
1248   e->ops = NULL;
1249   e->op_types = NULL;
1250   e->op_cnt = e->op_cap = 0;
1251   return e;
1252 }
1253
1254 atom_type
1255 expr_node_returns (const union any_node *n)
1256 {
1257   assert (n != NULL);
1258   assert (is_operation (n->type));
1259   if (is_atom (n->type)) 
1260     return n->type;
1261   else if (is_composite (n->type))
1262     return operations[n->type].returns;
1263   else
1264     abort ();
1265 }
1266
1267 static const char *
1268 atom_type_name (atom_type type)
1269 {
1270   assert (is_atom (type));
1271   return operations[type].name;
1272 }
1273
1274 union any_node *
1275 expr_allocate_nullary (struct expression *e, operation_type op)
1276 {
1277   return expr_allocate_composite (e, op, NULL, 0);
1278 }
1279
1280 union any_node *
1281 expr_allocate_unary (struct expression *e, operation_type op,
1282                      union any_node *arg0)
1283 {
1284   return expr_allocate_composite (e, op, &arg0, 1);
1285 }
1286
1287 union any_node *
1288 expr_allocate_binary (struct expression *e, operation_type op,
1289                       union any_node *arg0, union any_node *arg1)
1290 {
1291   union any_node *args[2];
1292   args[0] = arg0;
1293   args[1] = arg1;
1294   return expr_allocate_composite (e, op, args, 2);
1295 }
1296
1297 static bool
1298 is_valid_node (union any_node *n) 
1299 {
1300   struct operation *op;
1301   size_t i;
1302   
1303   assert (n != NULL);
1304   assert (is_operation (n->type));
1305   op = &operations[n->type];
1306   
1307   if (!is_atom (n->type))
1308     {
1309       struct composite_node *c = &n->composite;
1310       
1311       assert (is_composite (n->type));
1312       assert (c->arg_cnt >= op->arg_cnt);
1313       for (i = 0; i < op->arg_cnt; i++) 
1314         assert (expr_node_returns (c->args[i]) == op->args[i]);
1315       if (c->arg_cnt > op->arg_cnt && !is_operator (n->type)) 
1316         {
1317           assert (op->flags & OPF_ARRAY_OPERAND);
1318           for (i = 0; i < c->arg_cnt; i++)
1319             assert (operations[c->args[i]->type].returns
1320                     == op->args[op->arg_cnt - 1]);
1321         }
1322     }
1323
1324   return true; 
1325 }
1326
1327 union any_node *
1328 expr_allocate_composite (struct expression *e, operation_type op,
1329                          union any_node **args, size_t arg_cnt)
1330 {
1331   union any_node *n;
1332   size_t i;
1333
1334   n = pool_alloc (e->expr_pool, sizeof n->composite);
1335   n->type = op;
1336   n->composite.arg_cnt = arg_cnt;
1337   n->composite.args = pool_alloc (e->expr_pool,
1338                                   sizeof *n->composite.args * arg_cnt);
1339   for (i = 0; i < arg_cnt; i++) 
1340     {
1341       if (args[i] == NULL)
1342         return NULL;
1343       n->composite.args[i] = args[i];
1344     }
1345   memcpy (n->composite.args, args, sizeof *n->composite.args * arg_cnt);
1346   n->composite.min_valid = 0;
1347   assert (is_valid_node (n));
1348   return n;
1349 }
1350
1351 union any_node *
1352 expr_allocate_number (struct expression *e, double d)
1353 {
1354   union any_node *n = pool_alloc (e->expr_pool, sizeof n->number);
1355   n->type = OP_number;
1356   n->number.n = d;
1357   return n;
1358 }
1359
1360 union any_node *
1361 expr_allocate_boolean (struct expression *e, double b)
1362 {
1363   union any_node *n = pool_alloc (e->expr_pool, sizeof n->number);
1364   assert (b == 0.0 || b == 1.0 || b == SYSMIS);
1365   n->type = OP_boolean;
1366   n->number.n = b;
1367   return n;
1368 }
1369
1370 union any_node *
1371 expr_allocate_integer (struct expression *e, int i)
1372 {
1373   union any_node *n = pool_alloc (e->expr_pool, sizeof n->integer);
1374   n->type = OP_integer;
1375   n->integer.i = i;
1376   return n;
1377 }
1378
1379 union any_node *
1380 expr_allocate_pos_int (struct expression *e, int i)
1381 {
1382   union any_node *n = pool_alloc (e->expr_pool, sizeof n->integer);
1383   assert (i > 0);
1384   n->type = OP_pos_int;
1385   n->integer.i = i;
1386   return n;
1387 }
1388
1389 union any_node *
1390 expr_allocate_vector (struct expression *e, const struct vector *vector)
1391 {
1392   union any_node *n = pool_alloc (e->expr_pool, sizeof n->vector);
1393   n->type = OP_vector;
1394   n->vector.v = vector;
1395   return n;
1396 }
1397
1398 union any_node *
1399 expr_allocate_string_buffer (struct expression *e,
1400                              const char *string, size_t length)
1401 {
1402   union any_node *n = pool_alloc (e->expr_pool, sizeof n->string);
1403   n->type = OP_string;
1404   if (length > 255)
1405     length = 255;
1406   n->string.s = copy_string (e, string, length);
1407   return n;
1408 }
1409
1410 union any_node *
1411 expr_allocate_string (struct expression *e, struct fixed_string s)
1412 {
1413   union any_node *n = pool_alloc (e->expr_pool, sizeof n->string);
1414   n->type = OP_string;
1415   n->string.s = s;
1416   return n;
1417 }
1418
1419 union any_node *
1420 expr_allocate_variable (struct expression *e, struct variable *v)
1421 {
1422   union any_node *n = pool_alloc (e->expr_pool, sizeof n->variable);
1423   n->type = v->type == NUMERIC ? OP_num_var : OP_str_var;
1424   n->variable.v = v;
1425   return n;
1426 }
1427
1428 union any_node *
1429 expr_allocate_format (struct expression *e, const struct fmt_spec *format)
1430 {
1431   union any_node *n = pool_alloc (e->expr_pool, sizeof n->format);
1432   n->type = OP_format;
1433   n->format.f = *format;
1434   return n;
1435 }
1436
1437 /* Allocates a unary composite node that represents the value of
1438    variable V in expression E. */
1439 static union any_node *
1440 allocate_unary_variable (struct expression *e, struct variable *v) 
1441 {
1442   assert (v != NULL);
1443   return expr_allocate_unary (e, v->type == NUMERIC ? OP_NUM_VAR : OP_STR_VAR,
1444                               expr_allocate_variable (e, v));
1445 }