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       return 0;
1472     }
1473 }
1474
1475 static const char *
1476 type_name (int type)
1477 {
1478   switch (type)
1479     {
1480     case NUMERIC:
1481       return _("numeric");
1482     case ALPHA:
1483       return _("string");
1484     default:
1485       assert (0);
1486       return 0;
1487     }
1488 }
1489
1490 static void
1491 make_bool (union any_node **n)
1492 {
1493   union any_node *c;
1494
1495   c = xmalloc (sizeof (struct nonterm_node));
1496   c->nonterm.type = OP_NUM_TO_BOOL;
1497   c->nonterm.n = 1;
1498   c->nonterm.arg[0] = *n;
1499   *n = c;
1500 }
1501
1502 void
1503 free_node (union any_node *n)
1504 {
1505   if (n->type < OP_TERMINAL)
1506     {
1507       int i;
1508
1509       for (i = 0; i < n->nonterm.n; i++)
1510         free_node (n->nonterm.arg[i]);
1511     }
1512   free (n);
1513 }
1514
1515 union any_node *
1516 allocate_nonterminal (int op, union any_node *n)
1517 {
1518   union any_node *c;
1519
1520   c = xmalloc (sizeof c->nonterm);
1521   c->nonterm.type = op;
1522   c->nonterm.n = 1;
1523   c->nonterm.arg[0] = n;
1524
1525   return c;
1526 }
1527
1528 union any_node *
1529 append_nonterminal_arg (union any_node *a, union any_node *b)
1530 {
1531   a = xrealloc (a, sizeof *a + sizeof *a->nonterm.arg * a->nonterm.n);
1532   a->nonterm.arg[a->nonterm.n++] = b;
1533   return a;
1534 }
1535 \f
1536 static struct function func_tab[] =
1537 {
1538   {"ABS", OP_ABS, unary_func, NULL},
1539   {"ACOS", OP_ARCOS, unary_func, NULL},
1540   {"ARCOS", OP_ARCOS, unary_func, NULL},
1541   {"ARSIN", OP_ARSIN, unary_func, NULL},
1542   {"ARTAN", OP_ARTAN, unary_func, NULL},
1543   {"ASIN", OP_ARSIN, unary_func, NULL},
1544   {"ATAN", OP_ARTAN, unary_func, NULL},
1545   {"COS", OP_COS, unary_func, NULL},
1546   {"EXP", OP_EXP, unary_func, NULL},
1547   {"LG10", OP_LG10, unary_func, NULL},
1548   {"LN", OP_LN, unary_func, NULL},
1549   {"MOD10", OP_MOD10, unary_func, NULL},
1550   {"NORMAL", OP_NORMAL, unary_func, NULL},
1551   {"RND", OP_RND, unary_func, NULL},
1552   {"SIN", OP_SIN, unary_func, NULL},
1553   {"SQRT", OP_SQRT, unary_func, NULL},
1554   {"TAN", OP_TAN, unary_func, NULL},
1555   {"TRUNC", OP_TRUNC, unary_func, NULL},
1556   {"UNIFORM", OP_UNIFORM, unary_func, NULL},
1557
1558   {"TIME.DAYS", OP_TIME_DAYS, unary_func, NULL},
1559   {"TIME.HMS", OP_TIME_HMS, ternary_func, NULL},
1560
1561   {"CTIME.DAYS", OP_CTIME_DAYS, unary_func, NULL},
1562   {"CTIME.HOURS", OP_CTIME_HOURS, unary_func, NULL},
1563   {"CTIME.MINUTES", OP_CTIME_MINUTES, unary_func, NULL},
1564   {"CTIME.SECONDS", OP_CTIME_SECONDS, unary_func, NULL},
1565
1566   {"DATE.DMY", OP_DATE_DMY, ternary_func, NULL},
1567   {"DATE.MDY", OP_DATE_MDY, ternary_func, NULL},
1568   {"DATE.MOYR", OP_DATE_MOYR, binary_func, NULL},
1569   {"DATE.QYR", OP_DATE_QYR, binary_func, NULL},
1570   {"DATE.WKYR", OP_DATE_WKYR, binary_func, NULL},
1571   {"DATE.YRDAY", OP_DATE_YRDAY, binary_func, NULL},
1572
1573   {"XDATE.DATE", OP_XDATE_DATE, unary_func, NULL},
1574   {"XDATE.HOUR", OP_XDATE_HOUR, unary_func, NULL},
1575   {"XDATE.JDAY", OP_XDATE_JDAY, unary_func, NULL},
1576   {"XDATE.MDAY", OP_XDATE_MDAY, unary_func, NULL},
1577   {"XDATE.MINUTE", OP_XDATE_MINUTE, unary_func, NULL},
1578   {"XDATE.MONTH", OP_XDATE_MONTH, unary_func, NULL},
1579   {"XDATE.QUARTER", OP_XDATE_QUARTER, unary_func, NULL},
1580   {"XDATE.SECOND", OP_XDATE_SECOND, unary_func, NULL},
1581   {"XDATE.TDAY", OP_XDATE_TDAY, unary_func, NULL},
1582   {"XDATE.TIME", OP_XDATE_TIME, unary_func, NULL},
1583   {"XDATE.WEEK", OP_XDATE_WEEK, unary_func, NULL},
1584   {"XDATE.WKDAY", OP_XDATE_WKDAY, unary_func, NULL},
1585   {"XDATE.YEAR", OP_XDATE_YEAR, unary_func, NULL},
1586
1587   {"MISSING", OP_SYSMIS, MISSING_func, NULL},
1588   {"MOD", OP_MOD, binary_func, NULL},
1589   {"SYSMIS", OP_SYSMIS, SYSMIS_func, NULL},
1590   {"VALUE", OP_NUM_VAL, VALUE_func, NULL},
1591   {"LAG", OP_NUM_LAG, LAG_func, NULL},
1592   {"YRMODA", OP_YRMODA, ternary_func, NULL},
1593
1594   {"ANY", OP_ANY, nary_num_func, NULL},
1595   {"CFVAR", OP_CFVAR, nary_num_func, NULL},
1596   {"MAX", OP_MAX, nary_num_func, NULL},
1597   {"MEAN", OP_MEAN, nary_num_func, NULL},
1598   {"MIN", OP_MIN, nary_num_func, NULL},
1599   {"NMISS", OP_NMISS, nary_num_func, NULL},
1600   {"NVALID", OP_NVALID, nary_num_func, NULL},
1601   {"RANGE", OP_RANGE, nary_num_func, NULL},
1602   {"SD", OP_SD, nary_num_func, NULL},
1603   {"SUM", OP_SUM, nary_num_func, NULL},
1604   {"VARIANCE", OP_VARIANCE, nary_num_func, NULL},
1605
1606   {"CONCAT", OP_CONCAT, CONCAT_func, NULL},
1607   {"INDEX", OP_INDEX, generic_str_func, "nss/n"},
1608   {"RINDEX", OP_RINDEX, generic_str_func, "nss/n"},
1609   {"LENGTH", OP_LENGTH, generic_str_func, "ns"},
1610   {"LOWER", OP_LOWER, generic_str_func, "ss"},
1611   {"UPCAS", OP_UPPER, generic_str_func, "ss"},
1612   {"LPAD", OP_LPAD, generic_str_func, "ssn/s"},
1613   {"RPAD", OP_RPAD, generic_str_func, "ssn/s"},
1614   {"LTRIM", OP_LTRIM, generic_str_func, "ss/s"},
1615   {"RTRIM", OP_RTRIM, generic_str_func, "ss/s"},
1616   {"NUMBER", OP_NUMBER, generic_str_func, "ns/f"},
1617   {"STRING", OP_STRING, generic_str_func, "snf"},
1618   {"SUBSTR", OP_SUBSTR, generic_str_func, "ssn/n"},
1619 };
1620
1621 static int
1622 cmp_func (const void *a, const void *b)
1623 {
1624   return strcmp (*(char **) a, *(char **) b);
1625 }
1626
1627 static void
1628 init_func_tab (void)
1629 {
1630   {
1631     static int inited;
1632
1633     if (inited)
1634       return;
1635     inited = 1;
1636   }
1637
1638   func_count = sizeof func_tab / sizeof *func_tab;
1639   qsort (func_tab, func_count, sizeof *func_tab, cmp_func);
1640 }
1641 \f
1642 /* Debug output. */
1643
1644 #if DEBUGGING
1645 static void
1646 print_type (union any_node * n)
1647 {
1648   const char *s;
1649   size_t len;
1650
1651   s = ops[n->type].name;
1652   len = strlen (s);
1653   if (ops[n->type].flags & OP_MIN_ARGS)
1654     printf ("%s.%d\n", s, (int) n->nonterm.arg[n->nonterm.n]);
1655   else if (ops[n->type].flags & OP_FMT_SPEC)
1656     {
1657       struct fmt_spec f;
1658
1659       f.type = (int) n->nonterm.arg[n->nonterm.n + 0];
1660       f.w = (int) n->nonterm.arg[n->nonterm.n + 1];
1661       f.d = (int) n->nonterm.arg[n->nonterm.n + 2];
1662       printf ("%s(%s)\n", s, fmt_to_string (&f));
1663     }
1664   else
1665     printf ("%s\n", s);
1666 }
1667
1668 static void
1669 debug_print_tree (union any_node * n, int level)
1670 {
1671   int i;
1672   for (i = 0; i < level; i++)
1673     printf ("  ");
1674   if (n->type < OP_TERMINAL)
1675     {
1676       print_type (n);
1677       for (i = 0; i < n->nonterm.n; i++)
1678         debug_print_tree (n->nonterm.arg[i], level + 1);
1679     }
1680   else
1681     {
1682       switch (n->type)
1683         {
1684         case OP_TERMINAL:
1685           printf (_("!!TERMINAL!!"));
1686           break;
1687         case OP_NUM_CON:
1688           if (n->num_con.value == SYSMIS)
1689             printf ("SYSMIS");
1690           else
1691             printf ("%f", n->num_con.value);
1692           break;
1693         case OP_STR_CON:
1694           printf ("\"%.*s\"", n->str_con.len, n->str_con.s);
1695           break;
1696         case OP_NUM_VAR:
1697         case OP_STR_VAR:
1698           printf ("%s", n->var.v->name);
1699           break;
1700         case OP_NUM_LAG:
1701         case OP_STR_LAG:
1702           printf ("LAG(%s,%d)", n->lag.v->name, n->lag.lag);
1703           break;
1704         case OP_NUM_SYS:
1705           printf ("SYSMIS(%s)", n->var.v->name);
1706           break;
1707         case OP_NUM_VAL:
1708           printf ("VALUE(%s)", n->var.v->name);
1709           break;
1710         case OP_SENTINEL:
1711           printf (_("!!SENTINEL!!"));
1712           break;
1713         default:
1714           printf (_("!!ERROR%d!!"), n->type);
1715           assert (0);
1716         }
1717       printf ("\n");
1718     }
1719 }
1720 #endif /* DEBUGGING */
1721
1722 #if GLOBAL_DEBUGGING
1723 static void
1724 debug_print_postfix (struct expression * e)
1725 {
1726   unsigned char *o;
1727   double *num = e->num;
1728   unsigned char *str = e->str;
1729   struct variable **v = e->var;
1730   int t;
1731
1732   debug_printf ((_("postfix:")));
1733   for (o = e->op; *o != OP_SENTINEL;)
1734     {
1735       t = *o++;
1736       if (t < OP_TERMINAL)
1737         {
1738           debug_printf ((" %s", ops[t].name));
1739
1740           if (ops[t].flags & OP_VAR_ARGS)
1741             {
1742               debug_printf (("(%d)", *o));
1743               o++;
1744             }
1745           if (ops[t].flags & OP_MIN_ARGS)
1746             {
1747               debug_printf ((".%d", *o));
1748               o++;
1749             }
1750           if (ops[t].flags & OP_FMT_SPEC)
1751             {
1752               struct fmt_spec f;
1753               f.type = (int) *o++;
1754               f.w = (int) *o++;
1755               f.d = (int) *o++;
1756               debug_printf (("(%s)", fmt_to_string (&f)));
1757             }
1758         }
1759       else if (t == OP_NUM_CON)
1760         {
1761           if (*num == SYSMIS)
1762             debug_printf ((" SYSMIS"));
1763           else
1764             debug_printf ((" %f", *num));
1765           num++;
1766         }
1767       else if (t == OP_STR_CON)
1768         {
1769           debug_printf ((" \"%.*s\"", *str, &str[1]));
1770           str += str[0] + 1;
1771         }
1772       else if (t == OP_NUM_VAR || t == OP_STR_VAR)
1773         {
1774           debug_printf ((" %s", (*v)->name));
1775           v++;
1776         }
1777       else if (t == OP_NUM_SYS)
1778         {
1779           debug_printf ((" SYSMIS(#%d)", *o));
1780           o++;
1781         }
1782       else if (t == OP_NUM_VAL)
1783         {
1784           debug_printf ((" VALUE(#%d)", *o));
1785           o++;
1786         }
1787       else if (t == OP_NUM_LAG || t == OP_STR_LAG)
1788         {
1789           debug_printf ((" LAG(%s,%d)", (*v)->name, *o));
1790           o++;
1791           v++;
1792         }
1793       else
1794         {
1795           printf ("debug_print_postfix(): %d\n", t);
1796           assert (0);
1797         }
1798     }
1799   debug_putc ('\n', stdout);
1800 }
1801 #endif /* GLOBAL_DEBUGGING */