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