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