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