src/expr-prs.c

   1 /* PSPP - computes sample statistics.
   2    Copyright (C) 1997-9, 2000 Free Software Foundation, Inc.
   3    Written by Ben Pfaff <blp@gnu.org>.
   4
   5    This program is free software; you can redistribute it and/or
   6    modify it under the terms of the GNU General Public License as
   7    published by the Free Software Foundation; either version 2 of the
   8    License, or (at your option) any later version.
   9
  10    This program is distributed in the hope that it will be useful, but
  11    WITHOUT ANY WARRANTY; without even the implied warranty of
  12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13    General Public License for more details.
  14
  15    You should have received a copy of the GNU General Public License
  16    along with this program; if not, write to the Free Software
  17    Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  18    02111-1307, USA. */
  19
  20 #include <config.h>
  21 #include "expr.h"
  22 #include "exprP.h"
  23 #include <assert.h>
  24 #include <ctype.h>
  25 #include <float.h>
  26 #include <stdlib.h>
  27 #include "algorithm.h"
  28 #include "alloc.h"
  29 #include "error.h"
  30 #include "lexer.h"
  31 #include "misc.h"
  32 #include "str.h"
  33 #include "var.h"
  34 #include "vfm.h"
  35 \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 algo_compare_func compare_functions;
  61 static void init_func_tab (void);
  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 = dict_lookup_var (default_dict, 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
 760       && dict_lookup_var (default_dict, tokid) != NULL
 761       && lex_look_ahead () == ')')
 762     {
 763       struct var_node *c = xmalloc (sizeof *c);
 764       c->v = parse_variable ();
 765       c->type = c->v->type == ALPHA ? OP_STR_MIS : OP_NUM_SYS;
 766       *n = (union any_node *) c;
 767       return EX_BOOLEAN;
 768     }
 769   if (!get_num_args (f, 1, n))
 770     return EX_ERROR;
 771   return EX_BOOLEAN;
 772 }
 773
 774 static int
 775 SYSMIS_func (struct function * f unused, int x unused, union any_node ** n)
 776 {
 777   int t;
 778
 779   if (token == T_ID
 780       && dict_lookup_var (default_dict, tokid)
 781       && lex_look_ahead () == ')')
 782     {
 783       struct variable *v;
 784       v = parse_variable ();
 785       if (v->type == ALPHA)
 786         {
 787           struct num_con_node *c = xmalloc (sizeof *c);
 788           c->type = OP_NUM_CON;
 789           c->value = 0;
 790           return EX_BOOLEAN;
 791         }
 792       else
 793         {
 794           struct var_node *c = xmalloc (sizeof *c);
 795           c->type = OP_NUM_SYS;
 796           c->v = v;
 797           return EX_BOOLEAN;
 798         }
 799     }
 800
 801   t = parse_or (n);
 802   if (t == EX_ERROR)
 803     return t;
 804   else if (t == EX_NUMERIC)
 805     {
 806       *n = allocate_nonterminal (OP_SYSMIS, *n);
 807       return EX_BOOLEAN;
 808     }
 809   else /* EX_STRING or EX_BOOLEAN */
 810     {
 811       /* Return constant `true' value. */
 812       free_node (*n);
 813       *n = xmalloc (sizeof (struct num_con_node));
 814       (*n)->num_con.type = OP_NUM_CON;
 815       (*n)->num_con.value = 1.0;
 816       return EX_BOOLEAN;
 817     }
 818 }
 819
 820 static int
 821 VALUE_func (struct function *f unused, int x unused, union any_node **n)
 822 {
 823   struct variable *v = parse_variable ();
 824
 825   if (!v)
 826     return EX_ERROR;
 827   *n = xmalloc (sizeof (struct var_node));
 828   (*n)->var.v = v;
 829   if (v->type == NUMERIC)
 830     {
 831       (*n)->var.type = OP_NUM_VAL;
 832       return EX_NUMERIC;
 833     }
 834   else
 835     {
 836       (*n)->var.type = OP_STR_VAR;
 837       return EX_STRING;
 838     }
 839 }
 840
 841 static int
 842 LAG_func (struct function *f unused, int x unused, union any_node **n)
 843 {
 844   struct variable *v = parse_variable ();
 845   int nlag = 1;
 846
 847   if (!v)
 848     return EX_ERROR;
 849   if (lex_match (','))
 850     {
 851       if (!lex_integer_p () || lex_integer () <= 0 || lex_integer () > 1000)
 852         {
 853           msg (SE, _("Argument 2 to LAG must be a small positive "
 854                      "integer constant."));
 855           return 0;
 856         }
 857
 858       nlag = lex_integer ();
 859       lex_get ();
 860     }
 861   n_lag = max (nlag, n_lag);
 862   *n = xmalloc (sizeof (struct lag_node));
 863   (*n)->lag.type = (v->type == NUMERIC ? OP_NUM_LAG : OP_STR_LAG);
 864   (*n)->lag.v = v;
 865   (*n)->lag.lag = nlag;
 866   return (v->type == NUMERIC ? EX_NUMERIC : EX_STRING);
 867 }
 868
 869 /* This screwball function parses n-ary operators:
 870    1. NMISS, NVALID, SUM, MEAN, MIN, MAX: any number of (numeric) arguments.
 871    2. SD, VARIANCE, CFVAR: at least two (numeric) arguments.
 872    3. RANGE: An odd number of arguments, but at least three.
 873    All arguments must be the same type.
 874    4. ANY: At least two arguments.  All arguments must be the same type.
 875  */
 876 static int
 877 nary_num_func (struct function *f, int min_args, union any_node **n)
 878 {
 879   /* Argument number of current argument (used for error messages). */
 880   int argn = 1;
 881
 882   /* Number of arguments. */
 883   int nargs;
 884
 885   /* Number of arguments allocated. */
 886   int m = 16;
 887
 888   /* Type of arguments. */
 889   int type = (f->t == OP_ANY || f->t == OP_RANGE) ? -1 : NUMERIC;
 890
 891   *n = xmalloc (sizeof (struct nonterm_node) + sizeof (union any_node *[15]));
 892   (*n)->nonterm.type = f->t;
 893   (*n)->nonterm.n = 0;
 894   for (;;)
 895     {
 896       /* Special case: vara TO varb. */
 897
 898       /* FIXME: Is this condition failsafe?  Can we _ever_ have two
 899          juxtaposed identifiers otherwise?  */
 900       if (token == T_ID && dict_lookup_var (default_dict, tokid) != NULL
 901           && toupper (lex_look_ahead ()) == 'T')
 902         {
 903           struct variable **v;
 904           int nv;
 905           int j;
 906           int opts = PV_SINGLE;
 907
 908           if (type == NUMERIC)
 909             opts |= PV_NUMERIC;
 910           else if (type == ALPHA)
 911             opts |= PV_STRING;
 912           if (!parse_variables (default_dict, &v, &nv, opts))
 913             goto fail;
 914           if (nv + (*n)->nonterm.n >= m)
 915             {
 916               m += nv + 16;
 917               *n = xrealloc (*n, (sizeof (struct nonterm_node)
 918                                   + (m - 1) * sizeof (union any_node *)));
 919             }
 920           if (type == -1)
 921             {
 922               type = v[0]->type;
 923               for (j = 1; j < nv; j++)
 924                 if (type != v[j]->type)
 925                   {
 926                     msg (SE, _("Type mismatch in argument %d of %s, which was "
 927                                "expected to be of %s type.  It was actually "
 928                                "of %s type. "),
 929                          argn, f->s, type_name (type), type_name (v[j]->type));
 930                     free (v);
 931                     goto fail;
 932                   }
 933             }
 934           for (j = 0; j < nv; j++)
 935             {
 936               union any_node **c = &(*n)->nonterm.arg[(*n)->nonterm.n++];
 937               *c = xmalloc (sizeof (struct var_node));
 938               (*c)->var.type = (type == NUMERIC ? OP_NUM_VAR : OP_STR_VAR);
 939               (*c)->var.v = v[j];
 940             }
 941         }
 942       else
 943         {
 944           union any_node *c;
 945           int t = parse_or (&c);
 946
 947           if (t == EX_ERROR)
 948             goto fail;
 949           if (t == EX_BOOLEAN)
 950             {
 951               free_node (c);
 952               msg (SE, _("%s cannot take Boolean operands."), f->s);
 953               goto fail;
 954             }
 955           if (type == -1)
 956             {
 957               if (t == EX_NUMERIC)
 958                 type = NUMERIC;
 959               else if (t == EX_STRING)
 960                 type = ALPHA;
 961             }
 962           else if ((t == EX_NUMERIC) ^ (type == NUMERIC))
 963             {
 964               free_node (c);
 965               msg (SE, _("Type mismatch in argument %d of %s, which was "
 966                          "expected to be of %s type.  It was actually "
 967                          "of %s type. "),
 968                    argn, f->s, type_name (type), expr_type_name (t));
 969               goto fail;
 970             }
 971           if ((*n)->nonterm.n + 1 >= m)
 972             {
 973               m += 16;
 974               *n = xrealloc (*n, (sizeof (struct nonterm_node)
 975                                   + (m - 1) * sizeof (union any_node *)));
 976             }
 977           (*n)->nonterm.arg[(*n)->nonterm.n++] = c;
 978         }
 979
 980       if (token == ')')
 981         break;
 982       if (!lex_match (','))
 983         {
 984           lex_error (_("in function call"));
 985           goto fail;
 986         }
 987
 988       argn++;
 989     }
 990   *n = xrealloc (*n, (sizeof (struct nonterm_node)
 991                       + ((*n)->nonterm.n) * sizeof (union any_node *)));
 992
 993   nargs = (*n)->nonterm.n;
 994   if (f->t == OP_RANGE)
 995     {
 996       if (nargs < 3 || (nargs & 1) == 0)
 997         {
 998           msg (SE, _("RANGE requires an odd number of arguments, but "
 999                      "at least three."));
1000           return 0;
1001         }
1002     }
1003   else if (f->t == OP_SD || f->t == OP_VARIANCE
1004            || f->t == OP_CFVAR || f->t == OP_ANY)
1005     {
1006       if (nargs < 2)
1007         {
1008           msg (SE, _("%s requires at least two arguments."), f->s);
1009           return 0;
1010         }
1011     }
1012
1013   if (f->t == OP_CFVAR || f->t == OP_SD || f->t == OP_VARIANCE)
1014     min_args = max (min_args, 2);
1015   else
1016     min_args = max (min_args, 1);
1017
1018   /* Yes, this is admittedly a terrible crock, but it works. */
1019   (*n)->nonterm.arg[(*n)->nonterm.n] = (union any_node *) min_args;
1020
1021   if (min_args > nargs)
1022     {
1023       msg (SE, _("%s.%d requires at least %d arguments."),
1024            f->s, min_args, min_args);
1025       return 0;
1026     }
1027
1028   if (f->t == OP_ANY || f->t == OP_RANGE)
1029     {
1030       if (type == T_STRING)
1031         f->t++;
1032       return EX_BOOLEAN;
1033     }
1034   else
1035     return EX_NUMERIC;
1036
1037 fail:
1038   free_node (*n);
1039   return EX_ERROR;
1040 }
1041
1042 static int
1043 CONCAT_func (struct function * f unused, int x unused, union any_node ** n)
1044 {
1045   int m = 0;
1046
1047   int type;
1048
1049   *n = xmalloc (sizeof (struct nonterm_node) + sizeof (union any_node *[15]));
1050   (*n)->nonterm.type = OP_CONCAT;
1051   (*n)->nonterm.n = 0;
1052   for (;;)
1053     {
1054       if ((*n)->nonterm.n >= m)
1055         {
1056           m += 16;
1057           *n = xrealloc (*n, (sizeof (struct nonterm_node)
1058                               + (m - 1) * sizeof (union any_node *)));
1059         }
1060       type = parse_or (&(*n)->nonterm.arg[(*n)->nonterm.n]);
1061       if (type == EX_ERROR)
1062         goto fail;
1063       if (type != EX_STRING)
1064         {
1065           msg (SE, _("Argument %d to CONCAT is type %s.  All arguments "
1066                      "to CONCAT must be strings."),
1067                (*n)->nonterm.n + 1, expr_type_name (type));
1068           goto fail;
1069         }
1070       (*n)->nonterm.n++;
1071
1072       if (!lex_match (','))
1073         break;
1074     }
1075   *n = xrealloc (*n, (sizeof (struct nonterm_node)
1076                       + ((*n)->nonterm.n - 1) * sizeof (union any_node *)));
1077   return EX_STRING;
1078
1079 fail:
1080   free_node (*n);
1081   return EX_ERROR;
1082 }
1083
1084 /* Parses a string function according to f->desc.  f->desc[0] is the
1085    return type of the function.  Succeeding characters represent
1086    successive args.  Optional args are separated from the required
1087    args by a slash (`/').  Codes are `n', numeric arg; `s', string
1088    arg; and `f', format spec (this must be the last arg).  If the
1089    optional args are included, the type becomes f->t+1. */
1090 static int
1091 generic_str_func (struct function *f, int x unused, union any_node ** n)
1092 {
1093   int max_args = 0;
1094   int type;
1095   const char *cp;
1096
1097   /* Count max number of arguments. */
1098   cp = &f->desc[1];
1099   while (*cp)
1100     {
1101       if (*cp == 'n' || *cp == 's')
1102         max_args++;
1103       else if (*cp == 'f')
1104         max_args += 3;
1105       cp++;
1106     }
1107   cp = &f->desc[1];
1108
1109   *n = xmalloc (sizeof (struct nonterm_node)
1110                 + (max_args - 1) * sizeof (union any_node *));
1111   (*n)->nonterm.type = f->t;
1112   (*n)->nonterm.n = 0;
1113   for (;;)
1114     {
1115       if (*cp == 'n' || *cp == 's')
1116         {
1117           int t = *cp == 'n' ? EX_NUMERIC : EX_STRING;
1118           type = parse_or (&(*n)->nonterm.arg[(*n)->nonterm.n]);
1119
1120           if (type == EX_ERROR)
1121             goto fail;
1122           if (type != t)
1123             {
1124               msg (SE, _("Argument %d to %s was expected to be of %s type.  "
1125                          "It was actually of type %s."),
1126                    (*n)->nonterm.n + 1, f->s,
1127                    *cp == 'n' ? _("numeric") : _("string"),
1128                    expr_type_name (type));
1129               goto fail;
1130             }
1131           (*n)->nonterm.n++;
1132         }
1133       else if (*cp == 'f')
1134         {
1135           /* This is always the very last argument.  Also, this code
1136              is a crock.  However, it works. */
1137           struct fmt_spec fmt;
1138
1139           if (!parse_format_specifier (&fmt, 0))
1140             goto fail;
1141           if (formats[fmt.type].cat & FCAT_STRING)
1142             {
1143               msg (SE, _("%s is not a numeric format."), fmt_to_string (&fmt));
1144               goto fail;
1145             }
1146           (*n)->nonterm.arg[(*n)->nonterm.n + 0] = (union any_node *) fmt.type;
1147           (*n)->nonterm.arg[(*n)->nonterm.n + 1] = (union any_node *) fmt.w;
1148           (*n)->nonterm.arg[(*n)->nonterm.n + 2] = (union any_node *) fmt.d;
1149           break;
1150         }
1151       else
1152         assert (0);
1153
1154       if (*++cp == 0)
1155         break;
1156       if (*cp == '/')
1157         {
1158           cp++;
1159           if (lex_match (','))
1160             {
1161               (*n)->nonterm.type++;
1162               continue;
1163             }
1164           else
1165             break;
1166         }
1167       else if (!lex_match (','))
1168         {
1169           msg (SE, _("Too few arguments to function %s."), f->s);
1170           goto fail;
1171         }
1172     }
1173
1174   return f->desc[0] == 'n' ? EX_NUMERIC : EX_STRING;
1175
1176 fail:
1177   free_node (*n);
1178   return EX_ERROR;
1179 }
1180 \f
1181 /* General function parsing. */
1182
1183 static int
1184 get_num_args (struct function *f, int num_args, union any_node **n)
1185 {
1186   int t;
1187   int i;
1188
1189   *n = xmalloc (sizeof (struct nonterm_node)
1190                 + (num_args - 1) * sizeof (union any_node *));
1191   (*n)->nonterm.type = f->t;
1192   (*n)->nonterm.n = 0;
1193   for (i = 0;;)
1194     {
1195       t = parse_or (&(*n)->nonterm.arg[i]);
1196       if (t == EX_ERROR)
1197         goto fail;
1198       (*n)->nonterm.n++;
1199       if (t != EX_NUMERIC)
1200         {
1201           msg (SE, _("Type mismatch in argument %d of %s, which was expected "
1202                      "to be numeric.  It was actually type %s."),
1203                i + 1, f->s, expr_type_name (t));
1204           goto fail;
1205         }
1206       if (++i >= num_args)
1207         return 1;
1208       if (!lex_match (','))
1209         {
1210           msg (SE, _("Missing comma following argument %d of %s."), i + 1, f->s);
1211           goto fail;
1212         }
1213     }
1214
1215 fail:
1216   free_node (*n);
1217   return 0;
1218 }
1219
1220 static int
1221 parse_function (union any_node ** n)
1222 {
1223   struct function *fp;
1224   char fname[32], *cp;
1225   int t;
1226   int min_args;
1227   const struct vector *v;
1228
1229   /* Check for a vector with this name. */
1230   v = dict_lookup_vector (default_dict, tokid);
1231   if (v)
1232     {
1233       lex_get ();
1234       assert (token == '(');
1235       lex_get ();
1236
1237       *n = xmalloc (sizeof (struct nonterm_node)
1238                     + sizeof (union any_node *[2]));
1239       (*n)->nonterm.type = (v->var[0]->type == NUMERIC
1240                         ? OP_VEC_ELEM_NUM : OP_VEC_ELEM_STR);
1241       (*n)->nonterm.n = 0;
1242
1243       t = parse_or (&(*n)->nonterm.arg[0]);
1244       if (t == EX_ERROR)
1245         goto fail;
1246       if (t != EX_NUMERIC)
1247         {
1248           msg (SE, _("The index value after a vector name must be numeric."));
1249           goto fail;
1250         }
1251       (*n)->nonterm.n++;
1252
1253       if (!lex_match (')'))
1254         {
1255           msg (SE, _("`)' expected after a vector index value."));
1256           goto fail;
1257         }
1258       ((*n)->nonterm.arg[1]) = (union any_node *) v->idx;
1259
1260       return v->var[0]->type == NUMERIC ? EX_NUMERIC : EX_STRING;
1261     }
1262
1263   ds_truncate (&tokstr, 31);
1264   strcpy (fname, ds_value (&tokstr));
1265   cp = strrchr (fname, '.');
1266   if (cp && isdigit ((unsigned char) cp[1]))
1267     {
1268       min_args = atoi (&cp[1]);
1269       *cp = 0;
1270     }
1271   else
1272     min_args = 0;
1273
1274   lex_get ();
1275   if (!lex_force_match ('('))
1276     return 0;
1277
1278   {
1279     struct function f;
1280     f.s = fname;
1281
1282     fp = binary_search (func_tab, func_count, sizeof *func_tab, &f,
1283                         compare_functions, NULL);
1284   }
1285
1286   if (!fp)
1287     {
1288       msg (SE, _("There is no function named %s."), fname);
1289       return 0;
1290     }
1291   if (min_args && fp->func != nary_num_func)
1292     {
1293       msg (SE, _("Function %s may not be given a minimum number of "
1294                  "arguments."), fname);
1295       return 0;
1296     }
1297   t = fp->func (fp, min_args, n);
1298   if (t == EX_ERROR)
1299     return EX_ERROR;
1300   if (!lex_match (')'))
1301     {
1302       lex_error (_("expecting `)' after %s function"), fname);
1303       goto fail;
1304     }
1305
1306   return t;
1307
1308 fail:
1309   free_node (*n);
1310   return EX_ERROR;
1311 }
1312
1313 #if GLOBAL_DEBUGGING
1314 #define op(a,b,c,d) {a,b,c,d}
1315 #else
1316 #define op(a,b,c,d) {b,c,d}
1317 #endif
1318
1319 #define varies 0
1320
1321 struct op_desc ops[OP_SENTINEL + 1] =
1322 {
1323   op ("!?ERROR?!", 000, 0, 0),
1324
1325   op ("plus", 001, varies, 1),
1326   op ("mul", 011, varies, 1),
1327   op ("pow", 010, -1, 0),
1328   op ("and", 010, -1, 0),
1329   op ("or", 010, -1, 0),
1330   op ("not", 000, 0, 0),
1331   op ("eq", 000, -1, 0),
1332   op ("ge", 000, -1, 0),
1333   op ("gt", 000, -1, 0),
1334   op ("le", 000, -1, 0),
1335   op ("lt", 000, -1, 0),
1336   op ("ne", 000, -1, 0),
1337
1338   op ("string-eq", 000, -1, 0),
1339   op ("string-ge", 000, -1, 0),
1340   op ("string-gt", 000, -1, 0),
1341   op ("string-le", 000, -1, 0),
1342   op ("string-lt", 000, -1, 0),
1343   op ("string-ne", 000, -1, 0),
1344
1345   op ("neg", 000, 0, 0),
1346   op ("abs", 000, 0, 0),
1347   op ("arcos", 000, 0, 0),
1348   op ("arsin", 000, 0, 0),
1349   op ("artan", 000, 0, 0),
1350   op ("cos", 000, 0, 0),
1351   op ("exp", 000, 0, 0),
1352   op ("lg10", 000, 0, 0),
1353   op ("ln", 000, 0, 0),
1354   op ("mod10", 000, 0, 0),
1355   op ("rnd", 000, 0, 0),
1356   op ("sin", 000, 0, 0),
1357   op ("sqrt", 000, 0, 0),
1358   op ("tan", 000, 0, 0),
1359   op ("trunc", 000, 0, 0),
1360
1361   op ("any", 011, varies, 1),
1362   op ("any-string", 001, varies, 1),
1363   op ("cfvar", 013, varies, 2),
1364   op ("max", 013, varies, 2),
1365   op ("mean", 013, varies, 2),
1366   op ("min", 013, varies, 2),
1367   op ("nmiss", 011, varies, 1),
1368   op ("nvalid", 011, varies, 1),
1369   op ("range", 011, varies, 1),
1370   op ("range-string", 001, varies, 1),
1371   op ("sd", 013, varies, 2),
1372   op ("sum", 013, varies, 2),
1373   op ("variance", 013, varies, 2),
1374
1375   op ("time_hms", 000, -2, 0),
1376   op ("ctime_days?!", 000, 0, 0),
1377   op ("ctime_hours?!", 000, 0, 0),
1378   op ("ctime_minutes?!", 000, 0, 0),
1379   op ("ctime_seconds?!", 000, 0, 0),
1380   op ("time_days?!", 000, 0, 0),
1381
1382   op ("date_dmy", 000, -2, 0),
1383   op ("date_mdy", 000, -2, 0),
1384   op ("date_moyr", 000, -1, 0),
1385   op ("date_qyr", 000, -1, 0),
1386   op ("date_wkyr", 000, -1, 0),
1387   op ("date_yrday", 000, -1, 0),
1388   op ("yrmoda", 000, -2, 0),
1389
1390   op ("xdate_date", 000, 0, 0),
1391   op ("xdate_hour", 000, 0, 0),
1392   op ("xdate_jday", 000, 0, 0),
1393   op ("xdate_mday", 000, 0, 0),
1394   op ("xdate_minute", 000, 0, 0),
1395   op ("xdate_month", 000, 0, 0),
1396   op ("xdate_quarter", 000, 0, 0),
1397   op ("xdate_second", 000, 0, 0),
1398   op ("xdate_tday", 000, 0, 0),
1399   op ("xdate_time", 000, 0, 0),
1400   op ("xdate_week", 000, 0, 0),
1401   op ("xdate_wkday", 000, 0, 0),
1402   op ("xdate_year", 000, 0, 0),
1403
1404   op ("concat", 001, varies, 1),
1405   op ("index-2", 000, -1, 0),
1406   op ("index-3", 000, -2, 0),
1407   op ("rindex-2", 000, -1, 0),
1408   op ("rindex-3", 000, -2, 0),
1409   op ("length", 000, 0, 0),
1410   op ("lower", 000, 0, 0),
1411   op ("upcas", 000, 0, 0),
1412   op ("lpad-2", 010, -1, 0),
1413   op ("lpad-3", 010, -2, 0),
1414   op ("rpad-2", 010, -1, 0),
1415   op ("rpad-3", 010, -2, 0),
1416   op ("ltrim-1", 000, 0, 0),
1417   op ("ltrim-2", 000, -1, 0),
1418   op ("rtrim-1", 000, 0, 0),
1419   op ("rtrim-2", 000, -1, 0),
1420   op ("number-1", 010, 0, 0),
1421   op ("number-2", 014, 0, 3),
1422   op ("string", 004, 0, 3),
1423   op ("substr-2", 010, -1, 0),
1424   op ("substr-3", 010, -2, 0),
1425
1426   op ("inv", 000, 0, 0),
1427   op ("square", 000, 0, 0),
1428   op ("num-to-Bool", 000, 0, 0),
1429
1430   op ("mod", 010, -1, 0),
1431   op ("normal", 000, 0, 0),
1432   op ("uniform", 000, 0, 0),
1433   op ("sysmis", 010, 0, 0),
1434   op ("vec-elem-num", 002, 0, 1),
1435   op ("vec-elem-str", 002, 0, 1),
1436
1437   op ("!?TERMINAL?!", 000, 0, 0),
1438   op ("num-con", 000, +1, 0),
1439   op ("str-con", 000, +1, 0),
1440   op ("num-var", 000, +1, 0),
1441   op ("str-var", 000, +1, 0),
1442   op ("num-lag", 000, +1, 1),
1443   op ("str-lag", 000, +1, 1),
1444   op ("num-sys", 000, +1, 1),
1445   op ("num-val", 000, +1, 1),
1446   op ("str-mis", 000, +1, 1),
1447   op ("$casenum", 000, +1, 0),
1448   op ("!?SENTINEL?!", 000, 0, 0),
1449 };
1450
1451 #undef op
1452 #undef varies
1453 \f
1454 \f
1455 /* Utility functions. */
1456
1457 static const char *
1458 expr_type_name (int type)
1459 {
1460   switch (type)
1461     {
1462     case EX_ERROR:
1463       return _("error");
1464
1465     case EX_BOOLEAN:
1466       return _("Boolean");
1467
1468     case EX_NUMERIC:
1469       return _("numeric");
1470
1471     case EX_STRING:
1472       return _("string");
1473
1474     default:
1475       assert (0);
1476       return 0;
1477     }
1478 }
1479
1480 static const char *
1481 type_name (int type)
1482 {
1483   switch (type)
1484     {
1485     case NUMERIC:
1486       return _("numeric");
1487     case ALPHA:
1488       return _("string");
1489     default:
1490       assert (0);
1491       return 0;
1492     }
1493 }
1494
1495 static void
1496 make_bool (union any_node **n)
1497 {
1498   union any_node *c;
1499
1500   c = xmalloc (sizeof (struct nonterm_node));
1501   c->nonterm.type = OP_NUM_TO_BOOL;
1502   c->nonterm.n = 1;
1503   c->nonterm.arg[0] = *n;
1504   *n = c;
1505 }
1506
1507 void
1508 free_node (union any_node *n)
1509 {
1510   if (n->type < OP_TERMINAL)
1511     {
1512       int i;
1513
1514       for (i = 0; i < n->nonterm.n; i++)
1515         free_node (n->nonterm.arg[i]);
1516     }
1517   free (n);
1518 }
1519
1520 union any_node *
1521 allocate_nonterminal (int op, union any_node *n)
1522 {
1523   union any_node *c;
1524
1525   c = xmalloc (sizeof c->nonterm);
1526   c->nonterm.type = op;
1527   c->nonterm.n = 1;
1528   c->nonterm.arg[0] = n;
1529
1530   return c;
1531 }
1532
1533 union any_node *
1534 append_nonterminal_arg (union any_node *a, union any_node *b)
1535 {
1536   a = xrealloc (a, sizeof *a + sizeof *a->nonterm.arg * a->nonterm.n);
1537   a->nonterm.arg[a->nonterm.n++] = b;
1538   return a;
1539 }
1540 \f
1541 static struct function func_tab[] =
1542 {
1543   {"ABS", OP_ABS, unary_func, NULL},
1544   {"ACOS", OP_ARCOS, unary_func, NULL},
1545   {"ARCOS", OP_ARCOS, unary_func, NULL},
1546   {"ARSIN", OP_ARSIN, unary_func, NULL},
1547   {"ARTAN", OP_ARTAN, unary_func, NULL},
1548   {"ASIN", OP_ARSIN, unary_func, NULL},
1549   {"ATAN", OP_ARTAN, unary_func, NULL},
1550   {"COS", OP_COS, unary_func, NULL},
1551   {"EXP", OP_EXP, unary_func, NULL},
1552   {"LG10", OP_LG10, unary_func, NULL},
1553   {"LN", OP_LN, unary_func, NULL},
1554   {"MOD10", OP_MOD10, unary_func, NULL},
1555   {"NORMAL", OP_NORMAL, unary_func, NULL},
1556   {"RND", OP_RND, unary_func, NULL},
1557   {"SIN", OP_SIN, unary_func, NULL},
1558   {"SQRT", OP_SQRT, unary_func, NULL},
1559   {"TAN", OP_TAN, unary_func, NULL},
1560   {"TRUNC", OP_TRUNC, unary_func, NULL},
1561   {"UNIFORM", OP_UNIFORM, unary_func, NULL},
1562
1563   {"TIME.DAYS", OP_TIME_DAYS, unary_func, NULL},
1564   {"TIME.HMS", OP_TIME_HMS, ternary_func, NULL},
1565
1566   {"CTIME.DAYS", OP_CTIME_DAYS, unary_func, NULL},
1567   {"CTIME.HOURS", OP_CTIME_HOURS, unary_func, NULL},
1568   {"CTIME.MINUTES", OP_CTIME_MINUTES, unary_func, NULL},
1569   {"CTIME.SECONDS", OP_CTIME_SECONDS, unary_func, NULL},
1570
1571   {"DATE.DMY", OP_DATE_DMY, ternary_func, NULL},
1572   {"DATE.MDY", OP_DATE_MDY, ternary_func, NULL},
1573   {"DATE.MOYR", OP_DATE_MOYR, binary_func, NULL},
1574   {"DATE.QYR", OP_DATE_QYR, binary_func, NULL},
1575   {"DATE.WKYR", OP_DATE_WKYR, binary_func, NULL},
1576   {"DATE.YRDAY", OP_DATE_YRDAY, binary_func, NULL},
1577
1578   {"XDATE.DATE", OP_XDATE_DATE, unary_func, NULL},
1579   {"XDATE.HOUR", OP_XDATE_HOUR, unary_func, NULL},
1580   {"XDATE.JDAY", OP_XDATE_JDAY, unary_func, NULL},
1581   {"XDATE.MDAY", OP_XDATE_MDAY, unary_func, NULL},
1582   {"XDATE.MINUTE", OP_XDATE_MINUTE, unary_func, NULL},
1583   {"XDATE.MONTH", OP_XDATE_MONTH, unary_func, NULL},
1584   {"XDATE.QUARTER", OP_XDATE_QUARTER, unary_func, NULL},
1585   {"XDATE.SECOND", OP_XDATE_SECOND, unary_func, NULL},
1586   {"XDATE.TDAY", OP_XDATE_TDAY, unary_func, NULL},
1587   {"XDATE.TIME", OP_XDATE_TIME, unary_func, NULL},
1588   {"XDATE.WEEK", OP_XDATE_WEEK, unary_func, NULL},
1589   {"XDATE.WKDAY", OP_XDATE_WKDAY, unary_func, NULL},
1590   {"XDATE.YEAR", OP_XDATE_YEAR, unary_func, NULL},
1591
1592   {"MISSING", OP_SYSMIS, MISSING_func, NULL},
1593   {"MOD", OP_MOD, binary_func, NULL},
1594   {"SYSMIS", OP_SYSMIS, SYSMIS_func, NULL},
1595   {"VALUE", OP_NUM_VAL, VALUE_func, NULL},
1596   {"LAG", OP_NUM_LAG, LAG_func, NULL},
1597   {"YRMODA", OP_YRMODA, ternary_func, NULL},
1598
1599   {"ANY", OP_ANY, nary_num_func, NULL},
1600   {"CFVAR", OP_CFVAR, nary_num_func, NULL},
1601   {"MAX", OP_MAX, nary_num_func, NULL},
1602   {"MEAN", OP_MEAN, nary_num_func, NULL},
1603   {"MIN", OP_MIN, nary_num_func, NULL},
1604   {"NMISS", OP_NMISS, nary_num_func, NULL},
1605   {"NVALID", OP_NVALID, nary_num_func, NULL},
1606   {"RANGE", OP_RANGE, nary_num_func, NULL},
1607   {"SD", OP_SD, nary_num_func, NULL},
1608   {"SUM", OP_SUM, nary_num_func, NULL},
1609   {"VARIANCE", OP_VARIANCE, nary_num_func, NULL},
1610
1611   {"CONCAT", OP_CONCAT, CONCAT_func, NULL},
1612   {"INDEX", OP_INDEX, generic_str_func, "nss/n"},
1613   {"RINDEX", OP_RINDEX, generic_str_func, "nss/n"},
1614   {"LENGTH", OP_LENGTH, generic_str_func, "ns"},
1615   {"LOWER", OP_LOWER, generic_str_func, "ss"},
1616   {"UPCAS", OP_UPPER, generic_str_func, "ss"},
1617   {"LPAD", OP_LPAD, generic_str_func, "ssn/s"},
1618   {"RPAD", OP_RPAD, generic_str_func, "ssn/s"},
1619   {"LTRIM", OP_LTRIM, generic_str_func, "ss/s"},
1620   {"RTRIM", OP_RTRIM, generic_str_func, "ss/s"},
1621   {"NUMBER", OP_NUMBER, generic_str_func, "ns/f"},
1622   {"STRING", OP_STRING, generic_str_func, "snf"},
1623   {"SUBSTR", OP_SUBSTR, generic_str_func, "ssn/n"},
1624 };
1625
1626 /* An algo_compare_func that compares functions A and B based on
1627    their names. */
1628 static int
1629 compare_functions (const void *a_, const void *b_, void *aux unused)
1630 {
1631   const struct function *a = a_;
1632   const struct function *b = b_;
1633
1634   return strcmp (a->s, b->s);
1635 }
1636
1637 static void
1638 init_func_tab (void)
1639 {
1640   {
1641     static int inited;
1642
1643     if (inited)
1644       return;
1645     inited = 1;
1646   }
1647
1648   func_count = sizeof func_tab / sizeof *func_tab;
1649   sort (func_tab, func_count, sizeof *func_tab, compare_functions, NULL);
1650 }
1651 \f
1652 /* Debug output. */
1653
1654 #if DEBUGGING
1655 static void
1656 print_type (union any_node * n)
1657 {
1658   const char *s;
1659   size_t len;
1660
1661   s = ops[n->type].name;
1662   len = strlen (s);
1663   if (ops[n->type].flags & OP_MIN_ARGS)
1664     printf ("%s.%d\n", s, (int) n->nonterm.arg[n->nonterm.n]);
1665   else if (ops[n->type].flags & OP_FMT_SPEC)
1666     {
1667       struct fmt_spec f;
1668
1669       f.type = (int) n->nonterm.arg[n->nonterm.n + 0];
1670       f.w = (int) n->nonterm.arg[n->nonterm.n + 1];
1671       f.d = (int) n->nonterm.arg[n->nonterm.n + 2];
1672       printf ("%s(%s)\n", s, fmt_to_string (&f));
1673     }
1674   else
1675     printf ("%s\n", s);
1676 }
1677
1678 static void
1679 debug_print_tree (union any_node * n, int level)
1680 {
1681   int i;
1682   for (i = 0; i < level; i++)
1683     printf ("  ");
1684   if (n->type < OP_TERMINAL)
1685     {
1686       print_type (n);
1687       for (i = 0; i < n->nonterm.n; i++)
1688         debug_print_tree (n->nonterm.arg[i], level + 1);
1689     }
1690   else
1691     {
1692       switch (n->type)
1693         {
1694         case OP_TERMINAL:
1695           printf (_("!!TERMINAL!!"));
1696           break;
1697         case OP_NUM_CON:
1698           if (n->num_con.value == SYSMIS)
1699             printf ("SYSMIS");
1700           else
1701             printf ("%f", n->num_con.value);
1702           break;
1703         case OP_STR_CON:
1704           printf ("\"%.*s\"", n->str_con.len, n->str_con.s);
1705           break;
1706         case OP_NUM_VAR:
1707         case OP_STR_VAR:
1708           printf ("%s", n->var.v->name);
1709           break;
1710         case OP_NUM_LAG:
1711         case OP_STR_LAG:
1712           printf ("LAG(%s,%d)", n->lag.v->name, n->lag.lag);
1713           break;
1714         case OP_NUM_SYS:
1715           printf ("SYSMIS(%s)", n->var.v->name);
1716           break;
1717         case OP_NUM_VAL:
1718           printf ("VALUE(%s)", n->var.v->name);
1719           break;
1720         case OP_SENTINEL:
1721           printf (_("!!SENTINEL!!"));
1722           break;
1723         default:
1724           printf (_("!!ERROR%d!!"), n->type);
1725           assert (0);
1726         }
1727       printf ("\n");
1728     }
1729 }
1730 #endif /* DEBUGGING */
1731
1732 #if GLOBAL_DEBUGGING
1733 static void
1734 debug_print_postfix (struct expression * e)
1735 {
1736   unsigned char *o;
1737   double *num = e->num;
1738   unsigned char *str = e->str;
1739   struct variable **v = e->var;
1740   int t;
1741
1742   debug_printf ((_("postfix:")));
1743   for (o = e->op; *o != OP_SENTINEL;)
1744     {
1745       t = *o++;
1746       if (t < OP_TERMINAL)
1747         {
1748           debug_printf ((" %s", ops[t].name));
1749
1750           if (ops[t].flags & OP_VAR_ARGS)
1751             {
1752               debug_printf (("(%d)", *o));
1753               o++;
1754             }
1755           if (ops[t].flags & OP_MIN_ARGS)
1756             {
1757               debug_printf ((".%d", *o));
1758               o++;
1759             }
1760           if (ops[t].flags & OP_FMT_SPEC)
1761             {
1762               struct fmt_spec f;
1763               f.type = (int) *o++;
1764               f.w = (int) *o++;
1765               f.d = (int) *o++;
1766               debug_printf (("(%s)", fmt_to_string (&f)));
1767             }
1768         }
1769       else if (t == OP_NUM_CON)
1770         {
1771           if (*num == SYSMIS)
1772             debug_printf ((" SYSMIS"));
1773           else
1774             debug_printf ((" %f", *num));
1775           num++;
1776         }
1777       else if (t == OP_STR_CON)
1778         {
1779           debug_printf ((" \"%.*s\"", *str, &str[1]));
1780           str += str[0] + 1;
1781         }
1782       else if (t == OP_NUM_VAR || t == OP_STR_VAR)
1783         {
1784           debug_printf ((" %s", (*v)->name));
1785           v++;
1786         }
1787       else if (t == OP_NUM_SYS)
1788         {
1789           debug_printf ((" SYSMIS(#%d)", *o));
1790           o++;
1791         }
1792       else if (t == OP_NUM_VAL)
1793         {
1794           debug_printf ((" VALUE(#%d)", *o));
1795           o++;
1796         }
1797       else if (t == OP_NUM_LAG || t == OP_STR_LAG)
1798         {
1799           debug_printf ((" LAG(%s,%d)", (*v)->name, *o));
1800           o++;
1801           v++;
1802         }
1803       else
1804         {
1805           printf ("debug_print_postfix(): %d\n", t);
1806           assert (0);
1807         }
1808     }
1809   debug_putc ('\n', stdout);
1810 }
1811 #endif /* GLOBAL_DEBUGGING */