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