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