src/expr-opt.c

   1 /* PSPP - computes sample statistics.
   2    Copyright (C) 1997-9, 2000 Free Software Foundation, Inc.
   3    Written by Ben Pfaff <blp@gnu.org>.
   4
   5    This program is free software; you can redistribute it and/or
   6    modify it under the terms of the GNU General Public License as
   7    published by the Free Software Foundation; either version 2 of the
   8    License, or (at your option) any later version.
   9
  10    This program is distributed in the hope that it will be useful, but
  11    WITHOUT ANY WARRANTY; without even the implied warranty of
  12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13    General Public License for more details.
  14
  15    You should have received a copy of the GNU General Public License
  16    along with this program; if not, write to the Free Software
  17    Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  18    02111-1307, USA. */
  19
  20 #include <config.h>
  21 #include "expr.h"
  22 #include "exprP.h"
  23 #include "error.h"
  24 #include <math.h>
  25 #include <ctype.h>
  26 #include <errno.h>
  27 #include <stdlib.h>
  28 #include "alloc.h"
  29 #include "data-in.h"
  30 #include "error.h"
  31 #include "julcal/julcal.h"
  32 #include "misc.h"
  33 #include "pool.h"
  34 #include "stats.h"
  35 #include "str.h"
  36 #include "var.h"
  37
  38 static void evaluate_tree_no_missing (union any_node **);
  39 static void evaluate_tree_with_missing (union any_node **, size_t count);
  40 static void optimize_tree (union any_node **);
  41
  42 static void collapse_node (union any_node **node, size_t child_idx);
  43 static void set_number (union any_node **node, double);
  44 static void set_number_errno (union any_node **node, double);
  45 static void set_string (union any_node **node, const char *, size_t);
  46
  47 void
  48 optimize_expression (union any_node **node)
  49 {
  50   int nonconst = 0;     /* Number of nonconstant children. */
  51   int sysmis = 0;       /* Number of system-missing children. */
  52   struct nonterm_node *nonterm;
  53   int i;
  54
  55   /* We can't optimize a terminal node. */
  56   if (IS_TERMINAL ((*node)->type))
  57     return;
  58   nonterm = &(*node)->nonterm;
  59
  60   /* Start by optimizing all the children. */
  61   for (i = 0; i < nonterm->n; i++)
  62     {
  63       optimize_expression (&nonterm->arg[i]);
  64       if (nonterm->arg[i]->type == OP_NUM_CON)
  65         {
  66           if (nonterm->arg[i]->num_con.value == SYSMIS)
  67             sysmis++;
  68         }
  69       else if (nonterm->arg[i]->type != OP_STR_CON)
  70         nonconst++;
  71     }
  72
  73   if (sysmis && !(ops[nonterm->type].flags & OP_ABSORB_MISS))
  74     {
  75       /* Most operation produce SYSMIS given any SYSMIS
  76          argument. */
  77       set_number (node, SYSMIS);
  78     }
  79   else if (!nonconst)
  80     {
  81       /* Evaluate constant expressions. */
  82       if (!sysmis)
  83         evaluate_tree_no_missing (node);
  84       else
  85         evaluate_tree_with_missing (node, sysmis);
  86     }
  87   else
  88     {
  89       /* A few optimization possibilities are still left. */
  90       optimize_tree (node);
  91     }
  92 }
  93
  94 static int
  95 eq_num_con (union any_node *node, double number)
  96 {
  97   return node->type == OP_NUM_CON && node->num_con.value == number;
  98 }
  99
 100 static void
 101 optimize_tree (union any_node **node)
 102 {
 103   struct nonterm_node *n = &(*node)->nonterm;
 104
 105   /* x+0, x-0, 0+x => x. */
 106   if ((n->type == OP_ADD || n->type == OP_SUB) && eq_num_con (n->arg[1], 0.))
 107     collapse_node (node, 1);
 108   else if (n->type == OP_ADD && eq_num_con (n->arg[0], 0.))
 109     collapse_node (node, 0);
 110
 111   /* x*1, x/1, 1*x => x. */
 112   else if ((n->type == OP_MUL || n->type == OP_DIV)
 113            && eq_num_con (n->arg[1], 1.))
 114     collapse_node (node, 0);
 115   else if (n->type == OP_MUL && eq_num_con (n->arg[0], 1.))
 116     collapse_node (node, 1);
 117
 118   /* 0*x, 0/x, x*0, MOD(0,x) => x. */
 119   else if (((n->type == OP_MUL || n->type == OP_DIV || n->type == OP_MOD)
 120             && eq_num_con (n->arg[0], 0.))
 121            || (n->type == OP_MUL && eq_num_con (n->arg[1], 0.)))
 122     set_number (node, 0.);
 123
 124   /* x**1 => x. */
 125   else if (n->type == OP_POW && eq_num_con (n->arg[1], 1))
 126     collapse_node (node, 0);
 127
 128   /* x**2 => SQUARE(x). */
 129   else if (n->type == OP_POW && eq_num_con (n->arg[2], 2))
 130     {
 131       n->type = OP_SQUARE;
 132       n->n = 1;
 133     }
 134 }
 135
 136 /* Finds the first NEEDLE of length NEEDLE_LEN in a HAYSTACK of length
 137    HAYSTACK_LEN.  Returns a 1-based index, 0 on failure. */
 138 static int
 139 str_search (const char *haystack, int haystack_len,
 140             const char *needle, int needle_len)
 141 {
 142   char *p = memmem (haystack, haystack_len, needle, needle_len);
 143   return p ? p - haystack + 1 : 0;
 144 }
 145
 146 /* Finds the last NEEDLE of length NEEDLE_LEN in a HAYSTACK of length
 147    HAYSTACK_LEN.  Returns a 1-based index, 0 on failure. */
 148 static int
 149 str_rsearch (const char *haystack, int haystack_len,
 150              const char *needle, int needle_len)
 151 {
 152   char *p = mm_find_reverse (haystack, haystack_len, needle, needle_len);
 153   return p ? p - haystack + 1 : 0;
 154 }
 155
 156 static void
 157 evaluate_tree_no_missing (union any_node **node)
 158 {
 159   struct nonterm_node *n = &(*node)->nonterm;
 160   double num[3];
 161   char *str[3];
 162   size_t str_len[3];
 163   int i;
 164
 165   errno = 0;
 166
 167   for (i = 0; i < n->n && i < 3; i++)
 168     {
 169       union any_node *arg = n->arg[i];
 170
 171       if (arg->type == OP_NUM_CON)
 172         num[i] = arg->num_con.value;
 173       else if (arg->type == OP_STR_CON)
 174         {
 175           str[i] = arg->str_con.s;
 176           str_len[i] = arg->str_con.len;
 177         }
 178     }
 179
 180   switch (n->type)
 181     {
 182     case OP_ADD:
 183       set_number (node, num[0] + num[1]);
 184       break;
 185
 186     case OP_SUB:
 187       set_number (node, num[0] - num[1]);
 188       break;
 189
 190     case OP_MUL:
 191       set_number (node, num[0] * num[1]);
 192       break;
 193
 194     case OP_DIV:
 195       if (num[1] != 0.)
 196         set_number (node, num[0] / num[1]);
 197       break;
 198
 199     case OP_POW:
 200       if (num[0] == 0. && num[1] == 0.)
 201         set_number (node, SYSMIS);
 202       else
 203         set_number_errno (node, pow (num[0], num[1]));
 204       break;
 205
 206     case OP_AND:
 207       set_number (node, num[0] && num[1]);
 208       break;
 209
 210     case OP_OR:
 211       set_number (node, num[0] || num[1]);
 212       break;
 213
 214     case OP_NOT:
 215       set_number (node, !num[0]);
 216       break;
 217
 218     case OP_EQ:
 219       set_number (node, num[0] == num[1]);
 220       break;
 221     case OP_GE:
 222       set_number (node, num[0] >= num[1]);
 223       break;
 224     case OP_GT:
 225       set_number (node, num[0] > num[1]);
 226       break;
 227     case OP_LE:
 228       set_number (node, num[0] <= num[1]);
 229       break;
 230     case OP_LT:
 231       set_number (node, num[0] < num[1]);
 232       break;
 233     case OP_NE:
 234       set_number (node, num[0] != num[1]);
 235       break;
 236
 237       /* String operators. */
 238     case OP_EQ_STRING:
 239       set_number (node, st_compare_pad (str[0], str_len[0],
 240                                         str[1], str_len[1]) == 0);
 241       break;
 242     case OP_GE_STRING:
 243       set_number (node, st_compare_pad (str[0], str_len[0],
 244                                         str[1], str_len[1]) >= 0);
 245       break;
 246     case OP_GT_STRING:
 247       set_number (node, st_compare_pad (str[0], str_len[0],
 248                                         str[1], str_len[1]) > 0);
 249       break;
 250     case OP_LE_STRING:
 251       set_number (node, st_compare_pad (str[0], str_len[0],
 252                                         str[1], str_len[1]) <= 0);
 253       break;
 254     case OP_LT_STRING:
 255       set_number (node, st_compare_pad (str[0], str_len[0],
 256                                         str[1], str_len[1]) < 0);
 257       break;
 258     case OP_NE_STRING:
 259       set_number (node, st_compare_pad (str[0], str_len[0],
 260                                         str[1], str_len[1]) != 0);
 261       break;
 262
 263       /* Unary functions. */
 264     case OP_NEG:
 265       set_number (node, -num[0]);
 266       break;
 267     case OP_ABS:
 268       set_number (node, fabs (num[0]));
 269       break;
 270     case OP_ARCOS:
 271       set_number_errno (node, acos (num[0]));
 272       break;
 273     case OP_ARSIN:
 274       set_number_errno (node, asin (num[0]));
 275       break;
 276     case OP_ARTAN:
 277       set_number_errno (node, atan (num[0]));
 278       break;
 279     case OP_COS:
 280       set_number_errno (node, cos (num[0]));
 281       break;
 282     case OP_EXP:
 283       set_number_errno (node, exp (num[0]));
 284       break;
 285     case OP_LG10:
 286       set_number_errno (node, log10 (num[0]));
 287       break;
 288     case OP_LN:
 289       set_number_errno (node, log (num[0]));
 290       break;
 291     case OP_MOD10:
 292       set_number_errno (node, fmod (num[0], 10));
 293       break;
 294     case OP_RND:
 295       if (num[0] >= 0.0)
 296         set_number_errno (node, floor (num[0] + 0.5));
 297       else
 298         set_number_errno (node, -floor (-num[0] + 0.5));
 299       break;
 300     case OP_SIN:
 301       set_number_errno (node, sin (num[0]));
 302       break;
 303     case OP_SQRT:
 304       set_number_errno (node, sqrt (num[0]));
 305       break;
 306     case OP_TAN:
 307       set_number_errno (node, tan (num[0]));
 308       break;
 309     case OP_TRUNC:
 310       if (num[0] >= 0.0)
 311         set_number_errno (node, floor (num[0]));
 312       else
 313         set_number_errno (node, -floor (-num[0]));
 314       break;
 315
 316       /* N-ary numeric functions. */
 317     case OP_ANY:
 318       {
 319         double result = 0.0;
 320         for (i = 1; i < n->n; i++)
 321           if (num[0] == n->arg[i]->num_con.value)
 322             {
 323               result = 1.0;
 324               break;
 325             }
 326         set_number (node, result);
 327       }
 328       break;
 329     case OP_ANY_STRING:
 330       {
 331         double result = 0.0;
 332         for (i = 1; i < n->n; i++)
 333           if (!st_compare_pad (n->arg[0]->str_con.s, n->arg[0]->str_con.len,
 334                                n->arg[i]->str_con.s, n->arg[i]->str_con.len))
 335             {
 336               result = 1.0;
 337               break;
 338             }
 339         set_number (node, result);
 340       }
 341       break;
 342
 343     case OP_CFVAR:
 344     case OP_MAX:
 345     case OP_MEAN:
 346     case OP_MIN:
 347     case OP_NMISS:
 348     case OP_NVALID:
 349     case OP_SD:
 350     case OP_SUM:
 351     case OP_VARIANCE:
 352       /* FIXME */
 353       break;
 354
 355     case OP_RANGE:
 356       {
 357         double result = 0.0;
 358
 359         for (i = 1; i < n->n; i += 2)
 360           {
 361             double min = n->arg[i]->num_con.value;
 362             double max = n->arg[i + 1]->num_con.value;
 363             if (num[0] >= min && num[0] <= max)
 364               {
 365                 result = 1.0;
 366                 break;
 367               }
 368           }
 369         set_number (node, result);
 370       }
 371       break;
 372
 373     case OP_RANGE_STRING:
 374       {
 375         double result = 0.0;
 376
 377         for (i = 1; i < n->n; i += 2)
 378           {
 379             const char *min = n->arg[i]->str_con.s;
 380             size_t min_len = n->arg[i]->str_con.len;
 381             const char *max = n->arg[i + 1]->str_con.s;
 382             size_t max_len = n->arg[i + 1]->str_con.len;
 383
 384             if (st_compare_pad (str[0], str_len[0], min, min_len) >= 0
 385                 && st_compare_pad (str[0], str_len[0], max, max_len) <= 0)
 386               {
 387                 result = 1.0;
 388                 break;
 389               }
 390           }
 391         set_number (node, result);
 392         break;
 393       }
 394
 395       /* Time functions. */
 396     case OP_TIME_HMS:
 397       {
 398         double min, max;
 399         min = min (num[0], min (num[1], num[2]));
 400         max = max (num[0], max (num[1], num[2]));
 401         if (min < 0. && max > 0.)
 402           break;
 403         set_number (node, 60. * (60. * num[0] + num[1]) + num[2]);
 404       }
 405       break;
 406     case OP_CTIME_DAYS:
 407       set_number (node, num[0] / (60. * 60. * 24.));
 408       break;
 409     case OP_CTIME_HOURS:
 410       set_number (node, num[0] / (60. * 60.));
 411       break;
 412     case OP_CTIME_MINUTES:
 413       set_number (node, num[0] / 60.);
 414       break;
 415     case OP_TIME_DAYS:
 416       set_number (node, num[0] * (60. * 60. * 24.));
 417       break;
 418     case OP_CTIME_SECONDS:
 419       set_number (node, num[0]);
 420       break;
 421
 422       /* Date construction functions. */
 423     case OP_DATE_DMY:
 424       set_number (node, 60. * 60. * 24. * yrmoda (num[2], num[1], num[0]));
 425       break;
 426     case OP_DATE_MDY:
 427       set_number (node, 60. * 60. * 24. * yrmoda (num[2], num[0], num[1]));
 428       break;
 429     case OP_DATE_MOYR:
 430       set_number (node, 60. * 60. * 24. * yrmoda (num[1], num[0], 1));
 431       break;
 432     case OP_DATE_QYR:
 433       set_number (node,
 434                   60. * 60. * 24. * yrmoda (num[1], 3 * (int) num[0] - 2, 1));
 435       break;
 436     case OP_DATE_WKYR:
 437       {
 438         double t = yrmoda (num[1], 1, 1);
 439         if (num[0] < 0. || num[0] > 53.)
 440           break;
 441         if (t != SYSMIS)
 442           t = 60. * 60. * 24. * (t + 7. * (num[0] - 1));
 443         set_number (node, t);
 444       }
 445       break;
 446     case OP_DATE_YRDAY:
 447       {
 448         double t = yrmoda (num[0], 1, 1);
 449         if (t != SYSMIS)
 450           t = 60. * 60. * 24. * (t + num[1] - 1);
 451         set_number (node, t);
 452       }
 453       break;
 454     case OP_YRMODA:
 455       set_number (node, yrmoda (num[0], num[1], num[2]));
 456       break;
 457
 458       /* Date extraction functions. */
 459     case OP_XDATE_DATE:
 460       set_number_errno (node,
 461                         floor (num[0] / 60. / 60. / 24.) * 60. * 60. * 24.);
 462       break;
 463     case OP_XDATE_HOUR:
 464       set_number_errno (node, fmod (floor (num[0] / 60. / 60.), 24.));
 465       break;
 466     case OP_XDATE_JDAY:
 467       set_number (node, julian_to_jday (num[0] / 86400.));
 468       break;
 469     case OP_XDATE_MDAY:
 470       {
 471         int day;
 472         julian_to_calendar (num[0] / 86400., NULL, NULL, &day);
 473         set_number (node, day);
 474       }
 475       break;
 476     case OP_XDATE_MINUTE:
 477       set_number_errno (node, fmod (floor (num[0] / 60.), 60.));
 478       break;
 479     case OP_XDATE_MONTH:
 480       {
 481         int month;
 482         julian_to_calendar (num[0] / 86400., NULL, &month, NULL);
 483         set_number (node, month);
 484       }
 485       break;
 486     case OP_XDATE_QUARTER:
 487       {
 488         int month;
 489         julian_to_calendar (num[0] / 86400., NULL, &month, NULL);
 490         set_number (node, (month - 1) / 3 + 1);
 491       }
 492       break;
 493     case OP_XDATE_SECOND:
 494       set_number_errno (node, fmod (num[0], 60.));
 495       break;
 496     case OP_XDATE_TDAY:
 497       set_number_errno (node, floor (num[0] / 60. / 60. / 24.));
 498       break;
 499     case OP_XDATE_TIME:
 500       set_number_errno (node, num[0] - (floor (num[0] / 60. / 60. / 24.)
 501                                         * 60. * 60. * 24.));
 502       break;
 503     case OP_XDATE_WEEK:
 504       set_number (node, (julian_to_jday (num[0]) - 1) / 7 + 1);
 505       break;
 506     case OP_XDATE_WKDAY:
 507       set_number (node, julian_to_wday (num[0]));
 508       break;
 509     case OP_XDATE_YEAR:
 510       {
 511         int year;
 512         julian_to_calendar (num[0] / 86400., &year, NULL, NULL);
 513         set_number (node, year);
 514       }
 515       break;
 516
 517       /* String functions. */
 518     case OP_CONCAT:
 519       {
 520         char string[256];
 521         int length = str_len[0];
 522         memcpy (string, str[0], length);
 523         for (i = 1; i < n->n; i++)
 524           {
 525             int add = n->arg[i]->str_con.len;
 526             if (add + length > 255)
 527               add = 255 - length;
 528             memcpy (&string[length], n->arg[i]->str_con.s, add);
 529             length += add;
 530           }
 531         set_string (node, string, length);
 532       }
 533       break;
 534     case OP_INDEX_2:
 535     case OP_INDEX_3:
 536     case OP_RINDEX_2:
 537     case OP_RINDEX_3:
 538       {
 539         int result, chunk_width, chunk_cnt;
 540
 541         if (n->type == OP_INDEX_2 || n->type == OP_RINDEX_2)
 542           chunk_width = str_len[1];
 543         else
 544           chunk_width = num[2];
 545         if (chunk_width <= 0 || chunk_width > str_len[1]
 546             || str_len[1] % chunk_width != 0)
 547           break;
 548         chunk_cnt = str_len[1] / chunk_width;
 549
 550         result = 0;
 551         for (i = 0; i < chunk_cnt; i++)
 552           {
 553             const char *chunk = str[1] + chunk_width * i;
 554             int ofs;
 555             if (n->type == OP_INDEX_2 || n->type == OP_INDEX_3)
 556               {
 557                 ofs = str_search (str[0], str_len[0], chunk, chunk_width);
 558                 if (ofs < result || result == 0)
 559                   result = ofs;
 560               }
 561             else
 562               {
 563                 ofs = str_rsearch (str[0], str_len[0], chunk, chunk_width);
 564                 if (ofs > result)
 565                   result = ofs;
 566               }
 567           }
 568         set_number (node, result);
 569       }
 570       break;
 571     case OP_LENGTH:
 572       set_number (node, str_len[0]);
 573       break;
 574     case OP_LOWER:
 575       {
 576         char *cp;
 577         for (cp = str[0]; cp < str[0] + str_len[0]; cp++)
 578           *cp = tolower ((unsigned char) *cp);
 579       }
 580       break;
 581     case OP_UPPER:
 582       {
 583         char *cp;
 584         for (cp = str[0]; cp < str[0] + str_len[0]; cp++)
 585           *cp = toupper ((unsigned char) *cp);
 586       }
 587       break;
 588     case OP_LPAD:
 589     case OP_RPAD:
 590       {
 591         char string[256];
 592         int len, pad_len;
 593         char pad_char;
 594
 595         /* Target length. */
 596         len = num[1];
 597         if (len < 1 || len > 255)
 598           break;
 599
 600         /* Pad character. */
 601         if (str_len[2] != 1)
 602           break;
 603         pad_char = str[2][0];
 604
 605         if (str_len[0] >= len)
 606           len = str_len[0];
 607         pad_len = len - str_len[0];
 608         if (n->type == OP_LPAD)
 609           {
 610             memset (string, pad_char, pad_len);
 611             memcpy (string + pad_len, str[0], str_len[0]);
 612           }
 613         else
 614           {
 615             memcpy (string, str[0], str_len[0]);
 616             memset (string + str_len[0], pad_char, pad_len);
 617           }
 618
 619         set_string (node, string, len);
 620       }
 621       break;
 622     case OP_LTRIM:
 623     case OP_RTRIM:
 624       {
 625         char pad_char;
 626         const char *cp = str[0];
 627         int len = str_len[0];
 628
 629         /* Pad character. */
 630         if (str_len[1] != 1)
 631           break;
 632         pad_char = str[1][0];
 633
 634         if (n->type == OP_LTRIM)
 635           while (len > 0 && *cp == pad_char)
 636             cp++, len--;
 637         else
 638           while (len > 0 && str[0][len - 1] == pad_char)
 639             len--;
 640         set_string (node, cp, len);
 641       }
 642       break;
 643     case OP_SUBSTR_2:
 644     case OP_SUBSTR_3:
 645       {
 646         int pos = (int) num[1];
 647         if (pos > str_len[0] || pos <= 0 || num[1] == SYSMIS
 648             || (n->type == OP_SUBSTR_3 && num[2] == SYSMIS))
 649           set_string (node, NULL, 0);
 650         else
 651           {
 652             int len;
 653             if (n->type == OP_SUBSTR_3)
 654               {
 655                 len = (int) num[2];
 656                 if (len + pos - 1 > str_len[0])
 657                   len = str_len[0] - pos + 1;
 658               }
 659             else
 660               len = str_len[0] - pos + 1;
 661             set_string (node, &str[0][pos - 1], len);
 662           }
 663       }
 664       break;
 665
 666       /* Weirdness. */
 667     case OP_MOD:
 668       if (num[0] == 0.0 && num[1] == SYSMIS)
 669         set_number (node, 0.0);
 670       else
 671         set_number (node, fmod (num[0], num[1]));
 672       break;
 673     case OP_NUM_TO_BOOL:
 674       if (num[0] == 0.0)
 675         num[0] = 0.0;
 676       else if (num[0] == 1.0)
 677         num[0] = 1.0;
 678       else if (num[0] != SYSMIS)
 679         {
 680           msg (SE, _("When optimizing a constant expression, an integer "
 681                "that was being used as an Boolean value was found "
 682                "to have a constant value other than 0, 1, or SYSMIS."));
 683           num[0] = 0.0;
 684         }
 685       set_number (node, num[0]);
 686       break;
 687     }
 688 }
 689
 690 static void
 691 evaluate_tree_with_missing (union any_node **node UNUSED, size_t count UNUSED)
 692 {
 693   /* FIXME */
 694 }
 695
 696 static void
 697 collapse_node (union any_node **node, size_t child_idx)
 698 {
 699   struct nonterm_node *nonterm = &(*node)->nonterm;
 700   union any_node *child;
 701
 702   child = nonterm->arg[child_idx];
 703   nonterm->arg[child_idx] = NULL;
 704   free_node (*node);
 705   *node = child;
 706 }
 707
 708
 709 static void
 710 set_number (union any_node **node, double value)
 711 {
 712   struct num_con_node *num;
 713
 714   free_node (*node);
 715
 716   *node = xmalloc (sizeof *num);
 717   num = &(*node)->num_con;
 718   num->type = OP_NUM_CON;
 719   num->value = finite (value) ? value : SYSMIS;
 720 }
 721
 722 static void
 723 set_number_errno (union any_node **node, double value)
 724 {
 725   if (errno == EDOM || errno == ERANGE)
 726     value = SYSMIS;
 727   set_number (node, value);
 728 }
 729
 730 static void
 731 set_string (union any_node **node, const char *string, size_t length)
 732 {
 733   struct str_con_node *str;
 734
 735   /* The ordering here is important since the source string may be
 736      part of a subnode of n. */
 737   str = xmalloc (sizeof *str + length - 1);
 738   str->type = OP_STR_CON;
 739   str->len = length;
 740   memcpy (str->s, string, length);
 741   free_node (*node);
 742   *node = (union any_node *) str;
 743 }
 744
 745 /* Returns the number of days since 10 Oct 1582 for the date
 746    YEAR/MONTH/DAY, where YEAR is in range 0..199 or 1582..19999, MONTH
 747    is in 1..12, and DAY is in 1..31. */
 748 double
 749 yrmoda (double year, double month, double day)
 750 {
 751   if (year == SYSMIS || month == SYSMIS || day == SYSMIS)
 752     return SYSMIS;
 753
 754   /* The addition of EPSILON avoids converting, for example,
 755      1991.9999997=>1991. */
 756   year = floor (year + EPSILON);
 757   month = floor (month + EPSILON);
 758   day = floor (day + EPSILON);
 759
 760   if (year >= 0. && year <= 29.)
 761     year += 2000.;
 762   else if (year >= 30. && year <= 99.)
 763     year += 1900.;
 764   if ((year < 1582. || year > 19999.)
 765       || (year == 1582. && (month < 10. || (month == 10. && day < 15.)))
 766       || (month < 0 || month > 13)
 767       || (day < 0 || day > 31))
 768     return SYSMIS;
 769   return calendar_to_julian (year, month, day);
 770 }
 771 \f
 772 /* Expression dumper. */
 773
 774 struct expr_dump_state
 775   {
 776     struct expression *expr;    /* Output expression. */
 777     int op_cnt, op_cap;         /* Number of ops, allocated space. */
 778     int dbl_cnt, dbl_cap;       /* Number of doubles, allocated space. */
 779     int str_cnt, str_cap;       /* Number of strings, allocated space. */
 780     int var_cnt, var_cap;       /* Number of variables, allocated space. */
 781   };
 782
 783 static void dump_node (struct expr_dump_state *, union any_node * n);
 784 static void emit (struct expr_dump_state *, int);
 785 static void emit_num_con (struct expr_dump_state *, double);
 786 static void emit_str_con (struct expr_dump_state *, char *, int);
 787 static void emit_var (struct expr_dump_state *, struct variable *);
 788
 789 void
 790 dump_expression (union any_node * n, struct expression * expr)
 791 {
 792   struct expr_dump_state eds;
 793   unsigned char *o;
 794   int height = 0;
 795   int max_height = 0;
 796
 797   expr->op = NULL;
 798   expr->num = NULL;
 799   expr->str = NULL;
 800   expr->var = NULL;
 801   eds.expr = expr;
 802   eds.op_cnt = eds.op_cap = 0;
 803   eds.dbl_cnt = eds.dbl_cap = 0;
 804   eds.str_cnt = eds.str_cap = 0;
 805   eds.var_cnt = eds.var_cap = 0;
 806   dump_node (&eds, n);
 807   emit (&eds, OP_SENTINEL);
 808
 809   /* Now compute the stack height needed to evaluate the expression. */
 810   for (o = expr->op; *o != OP_SENTINEL; o++)
 811     {
 812       if (ops[*o].flags & OP_VAR_ARGS)
 813         height += 1 - o[1];
 814       else
 815         height += ops[*o].height;
 816       o += ops[*o].skip;
 817       if (height > max_height)
 818         max_height = height;
 819     }
 820
 821   /* We waste space for one `value' since pointers are not
 822      guaranteed to be able to point to a spot before a block. */
 823   max_height++;
 824
 825   expr->stack = xmalloc (max_height * sizeof *expr->stack);
 826
 827   expr->pool = pool_create ();
 828 }
 829
 830 static void
 831 dump_node (struct expr_dump_state *eds, union any_node * n)
 832 {
 833   if (IS_NONTERMINAL (n->type))
 834     {
 835       int i;
 836       for (i = 0; i < n->nonterm.n; i++)
 837         dump_node (eds, n->nonterm.arg[i]);
 838       emit (eds, n->type);
 839       if (ops[n->type].flags & OP_VAR_ARGS)
 840         emit (eds, n->nonterm.n);
 841       if (ops[n->type].flags & OP_MIN_ARGS)
 842         emit (eds, (int) n->nonterm.arg[n->nonterm.n]);
 843       if (ops[n->type].flags & OP_FMT_SPEC)
 844         {
 845           emit (eds, (int) n->nonterm.arg[n->nonterm.n]);
 846           emit (eds, (int) n->nonterm.arg[n->nonterm.n + 1]);
 847           emit (eds, (int) n->nonterm.arg[n->nonterm.n + 2]);
 848         }
 849     }
 850   else
 851     {
 852       emit (eds, n->type);
 853       if (n->type == OP_NUM_CON)
 854         emit_num_con (eds, n->num_con.value);
 855       else if (n->type == OP_STR_CON)
 856         emit_str_con (eds, n->str_con.s, n->str_con.len);
 857       else if (n->type == OP_NUM_VAR || n->type == OP_STR_VAR)
 858         emit_var (eds, n->var.v);
 859       else if (n->type == OP_NUM_LAG || n->type == OP_STR_LAG)
 860         {
 861           emit_var (eds, n->lag.v);
 862           emit (eds, n->lag.lag);
 863         }
 864       else if (n->type == OP_NUM_SYS || n->type == OP_NUM_VAL)
 865         emit (eds, n->var.v->fv);
 866       else
 867         assert (n->type == OP_CASENUM);
 868     }
 869 }
 870
 871 static void
 872 emit (struct expr_dump_state *eds, int op)
 873 {
 874   if (eds->op_cnt >= eds->op_cap)
 875     {
 876       eds->op_cap += 16;
 877       eds->expr->op = xrealloc (eds->expr->op,
 878                                 eds->op_cap * sizeof *eds->expr->op);
 879     }
 880   eds->expr->op[eds->op_cnt++] = op;
 881 }
 882
 883 static void
 884 emit_num_con (struct expr_dump_state *eds, double dbl)
 885 {
 886   if (eds->dbl_cnt >= eds->dbl_cap)
 887     {
 888       eds->dbl_cap += 16;
 889       eds->expr->num = xrealloc (eds->expr->num,
 890                                  eds->dbl_cap * sizeof *eds->expr->num);
 891     }
 892   eds->expr->num[eds->dbl_cnt++] = dbl;
 893 }
 894
 895 static void
 896 emit_str_con (struct expr_dump_state *eds, char *str, int len)
 897 {
 898   if (eds->str_cnt + len + 1 > eds->str_cap)
 899     {
 900       eds->str_cap += 256;
 901       eds->expr->str = xrealloc (eds->expr->str, eds->str_cap);
 902     }
 903   eds->expr->str[eds->str_cnt++] = len;
 904   memcpy (&eds->expr->str[eds->str_cnt], str, len);
 905   eds->str_cnt += len;
 906 }
 907
 908 static void
 909 emit_var (struct expr_dump_state *eds, struct variable * v)
 910 {
 911   if (eds->var_cnt >= eds->var_cap)
 912     {
 913       eds->var_cap += 16;
 914       eds->expr->var = xrealloc (eds->expr->var,
 915                                  eds->var_cap * sizeof *eds->expr->var);
 916     }
 917   eds->expr->var[eds->var_cnt++] = v;
 918 }