src/matrix-data.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 /* AIX requires this to be the first thing in the file.  */
  21 #include <config.h>
  22 #if __GNUC__
  23 #define alloca __builtin_alloca
  24 #else
  25 #if HAVE_ALLOCA_H
  26 #include <alloca.h>
  27 #else
  28 #ifdef _AIX
  29 #pragma alloca
  30 #else
  31 #ifndef alloca                  /* predefined by HP cc +Olibcalls */
  32 char *alloca ();
  33 #endif
  34 #endif
  35 #endif
  36 #endif
  37
  38 #include <assert.h>
  39 #include <stdlib.h>
  40 #include <ctype.h>
  41 #include <float.h>
  42 #include "algorithm.h"
  43 #include "alloc.h"
  44 #include "command.h"
  45 #include "data-in.h"
  46 #include "dfm.h"
  47 #include "error.h"
  48 #include "file-handle.h"
  49 #include "lexer.h"
  50 #include "misc.h"
  51 #include "pool.h"
  52 #include "str.h"
  53 #include "var.h"
  54 #include "vfm.h"
  55
  56 #include "debug-print.h"
  57
  58 /* FIXME: /N subcommand not implemented.  It should be pretty simple,
  59    too. */
  60
  61 /* Format type enums. */
  62 enum
  63   {
  64     LIST,
  65     FREE
  66   };
  67
  68 /* Matrix section enums. */
  69 enum
  70   {
  71     LOWER,
  72     UPPER,
  73     FULL
  74   };
  75
  76 /* Diagonal inclusion enums. */
  77 enum
  78   {
  79     DIAGONAL,
  80     NODIAGONAL
  81   };
  82
  83 /* CONTENTS types. */
  84 enum
  85   {
  86     N_VECTOR,
  87     N_SCALAR,
  88     N_MATRIX,
  89     MEAN,
  90     STDDEV,
  91     COUNT,
  92     MSE,
  93     DFE,
  94     MAT,
  95     COV,
  96     CORR,
  97     PROX,
  98
  99     LPAREN,
 100     RPAREN,
 101     EOC
 102   };
 103
 104 /* 0=vector, 1=matrix, 2=scalar. */
 105 static int content_type[PROX + 1] =
 106   {
 107     0, 2, 1, 0, 0, 0, 0, 0, 1, 1, 1, 1,
 108   };
 109
 110 /* Name of each content type. */
 111 static const char *content_names[PROX + 1] =
 112   {
 113     "N", "N", "N_MATRIX", "MEAN", "STDDEV", "COUNT", "MSE",
 114     "DFE", "MAT", "COV", "CORR", "PROX",
 115   };
 116
 117 /* The data file to be read. */
 118 static struct file_handle *data_file;
 119
 120 /* Format type. */
 121 static int fmt;                 /* LIST or FREE. */
 122 static int section;             /* LOWER or UPPER or FULL. */
 123 static int diag;                /* DIAGONAL or NODIAGONAL. */
 124
 125 /* Arena used for all the MATRIX DATA allocations. */
 126 static struct pool *container;
 127
 128 /* ROWTYPE_ specified explicitly in data? */
 129 static int explicit_rowtype;
 130
 131 /* ROWTYPE_, VARNAME_ variables. */
 132 static struct variable *rowtype_, *varname_;
 133
 134 /* Is is per-factor data? */
 135 int is_per_factor[PROX + 1];
 136
 137 /* Single SPLIT FILE variable. */
 138 static struct variable *single_split;
 139
 140 /* Factor variables.  */
 141 static int n_factors;
 142 static struct variable **factors;
 143
 144 /* Number of cells, or -1 if none. */
 145 static int cells;
 146
 147 /* Population N specified by user. */
 148 static int pop_n;
 149
 150 /* CONTENTS subcommand. */
 151 static int contents[EOC * 3 + 1];
 152 static int n_contents;
 153
 154 /* Number of continuous variables. */
 155 static int n_continuous;
 156
 157 /* Index into default_dict.var of first continuous variables. */
 158 static int first_continuous;
 159
 160 static int compare_variables_by_mxd_vartype (const void *pa,
 161                                              const void *pb);
 162 static void read_matrices_without_rowtype (void);
 163 static void read_matrices_with_rowtype (void);
 164 static int string_to_content_type (char *, int *);
 165
 166 #if DEBUGGING
 167 static void debug_print (void);
 168 #endif
 169
 170 int
 171 cmd_matrix_data (void)
 172 {
 173   unsigned seen = 0;
 174
 175   lex_match_id ("MATRIX");
 176   lex_match_id ("DATA");
 177
 178   container = pool_create ();
 179
 180   discard_variables ();
 181
 182   data_file = inline_file;
 183   fmt = LIST;
 184   section = LOWER;
 185   diag = DIAGONAL;
 186   single_split = NULL;
 187   n_factors = 0;
 188   factors = NULL;
 189   cells = -1;
 190   pop_n = -1;
 191   n_contents = 0;
 192   while (token != '.')
 193     {
 194       lex_match ('/');
 195
 196       if (lex_match_id ("VARIABLES"))
 197         {
 198           char **v;
 199           int nv;
 200
 201           if (seen & 1)
 202             {
 203               msg (SE, _("VARIABLES subcommand multiply specified."));
 204               goto lossage;
 205             }
 206           seen |= 1;
 207
 208           lex_match ('=');
 209           if (!parse_DATA_LIST_vars (&v, &nv, PV_NO_DUPLICATE))
 210             goto lossage;
 211
 212           {
 213             int i;
 214
 215             for (i = 0; i < nv; i++)
 216               if (!strcmp (v[i], "VARNAME_"))
 217                 {
 218                   msg (SE, _("VARNAME_ cannot be explicitly specified on "
 219                              "VARIABLES."));
 220                   for (i = 0; i < nv; i++)
 221                     free (v[i]);
 222                   free (v);
 223                   goto lossage;
 224                 }
 225           }
 226
 227           {
 228             int i;
 229
 230             for (i = 0; i < nv; i++)
 231               {
 232                 struct variable *new_var;
 233
 234                 if (strcmp (v[i], "ROWTYPE_"))
 235                   {
 236                     new_var = force_create_variable (&default_dict, v[i],
 237                                                      NUMERIC, 0);
 238                     new_var->p.mxd.vartype = MXD_CONTINUOUS;
 239                     new_var->p.mxd.subtype = i;
 240                   }
 241                 else
 242                   explicit_rowtype = 1;
 243                 free (v[i]);
 244               }
 245             free (v);
 246           }
 247
 248           {
 249             rowtype_ = force_create_variable (&default_dict, "ROWTYPE_",
 250                                               ALPHA, 8);
 251             rowtype_->p.mxd.vartype = MXD_ROWTYPE;
 252             rowtype_->p.mxd.subtype = 0;
 253           }
 254         }
 255       else if (lex_match_id ("FILE"))
 256         {
 257           lex_match ('=');
 258           data_file = fh_parse_file_handle ();
 259           if (!data_file)
 260             goto lossage;
 261         }
 262       else if (lex_match_id ("FORMAT"))
 263         {
 264           lex_match ('=');
 265
 266           while (token == T_ID)
 267             {
 268               if (lex_match_id ("LIST"))
 269                 fmt = LIST;
 270               else if (lex_match_id ("FREE"))
 271                 fmt = FREE;
 272               else if (lex_match_id ("LOWER"))
 273                 section = LOWER;
 274               else if (lex_match_id ("UPPER"))
 275                 section = UPPER;
 276               else if (lex_match_id ("FULL"))
 277                 section = FULL;
 278               else if (lex_match_id ("DIAGONAL"))
 279                 diag = DIAGONAL;
 280               else if (lex_match_id ("NODIAGONAL"))
 281                 diag = NODIAGONAL;
 282               else
 283                 {
 284                   lex_error (_("in FORMAT subcommand"));
 285                   goto lossage;
 286                 }
 287             }
 288         }
 289       else if (lex_match_id ("SPLIT"))
 290         {
 291           lex_match ('=');
 292
 293           if (seen & 2)
 294             {
 295               msg (SE, _("SPLIT subcommand multiply specified."));
 296               goto lossage;
 297             }
 298           seen |= 2;
 299
 300           if (token != T_ID)
 301             {
 302               lex_error (_("in SPLIT subcommand"));
 303               goto lossage;
 304             }
 305
 306           if (!is_varname (tokid)
 307               && (lex_look_ahead () == '.' || lex_look_ahead () == '/'))
 308             {
 309               if (!strcmp (tokid, "ROWTYPE_") || !strcmp (tokid, "VARNAME_"))
 310                 {
 311                   msg (SE, _("Split variable may not be named ROWTYPE_ "
 312                              "or VARNAME_."));
 313                   goto lossage;
 314                 }
 315
 316               single_split = force_create_variable (&default_dict, tokid,
 317                                                     NUMERIC, 0);
 318               lex_get ();
 319
 320               single_split->p.mxd.vartype = MXD_CONTINUOUS;
 321
 322               default_dict.n_splits = 1;
 323               default_dict.splits = xmalloc (2 * sizeof *default_dict.splits);
 324               default_dict.splits[0] = single_split;
 325               default_dict.splits[1] = NULL;
 326             }
 327           else
 328             {
 329               struct variable **v;
 330               int n;
 331
 332               if (!parse_variables (NULL, &v, &n, PV_NO_DUPLICATE))
 333                 goto lossage;
 334
 335               default_dict.n_splits = n;
 336               default_dict.splits = v = xrealloc (v, sizeof *v * (n + 1));
 337               v[n] = NULL;
 338             }
 339
 340           {
 341             int i;
 342
 343             for (i = 0; i < default_dict.n_splits; i++)
 344               {
 345                 if (default_dict.splits[i]->p.mxd.vartype != MXD_CONTINUOUS)
 346                   {
 347                     msg (SE, _("Split variable %s is already another type."),
 348                          tokid);
 349                     goto lossage;
 350                   }
 351                 default_dict.splits[i]->p.mxd.vartype = MXD_SPLIT;
 352                 default_dict.splits[i]->p.mxd.subtype = i;
 353               }
 354           }
 355         }
 356       else if (lex_match_id ("FACTORS"))
 357         {
 358           lex_match ('=');
 359
 360           if (seen & 4)
 361             {
 362               msg (SE, _("FACTORS subcommand multiply specified."));
 363               goto lossage;
 364             }
 365           seen |= 4;
 366
 367           if (!parse_variables (NULL, &factors, &n_factors, PV_NONE))
 368             goto lossage;
 369
 370           {
 371             int i;
 372
 373             for (i = 0; i < n_factors; i++)
 374               {
 375                 if (factors[i]->p.mxd.vartype != MXD_CONTINUOUS)
 376                   {
 377                     msg (SE, _("Factor variable %s is already another type."),
 378                          tokid);
 379                     goto lossage;
 380                   }
 381                 factors[i]->p.mxd.vartype = MXD_FACTOR;
 382                 factors[i]->p.mxd.subtype = i;
 383               }
 384           }
 385         }
 386       else if (lex_match_id ("CELLS"))
 387         {
 388           lex_match ('=');
 389
 390           if (cells != -1)
 391             {
 392               msg (SE, _("CELLS subcommand multiply specified."));
 393               goto lossage;
 394             }
 395
 396           if (!lex_integer_p () || lex_integer () < 1)
 397             {
 398               lex_error (_("expecting positive integer"));
 399               goto lossage;
 400             }
 401
 402           cells = lex_integer ();
 403           lex_get ();
 404         }
 405       else if (lex_match_id ("N"))
 406         {
 407           lex_match ('=');
 408
 409           if (pop_n != -1)
 410             {
 411               msg (SE, _("N subcommand multiply specified."));
 412               goto lossage;
 413             }
 414
 415           if (!lex_integer_p () || lex_integer () < 1)
 416             {
 417               lex_error (_("expecting positive integer"));
 418               goto lossage;
 419             }
 420
 421           pop_n = lex_integer ();
 422           lex_get ();
 423         }
 424       else if (lex_match_id ("CONTENTS"))
 425         {
 426           int inside_parens = 0;
 427           unsigned collide = 0;
 428           int item;
 429
 430           if (seen & 8)
 431             {
 432               msg (SE, _("CONTENTS subcommand multiply specified."));
 433               goto lossage;
 434             }
 435           seen |= 8;
 436
 437           lex_match ('=');
 438
 439           {
 440             int i;
 441
 442             for (i = 0; i <= PROX; i++)
 443               is_per_factor[i] = 0;
 444           }
 445
 446           for (;;)
 447             {
 448               if (lex_match ('('))
 449                 {
 450                   if (inside_parens)
 451                     {
 452                       msg (SE, _("Nested parentheses not allowed."));
 453                       goto lossage;
 454                     }
 455                   inside_parens = 1;
 456                   item = LPAREN;
 457                 }
 458               else if (lex_match (')'))
 459                 {
 460                   if (!inside_parens)
 461                     {
 462                       msg (SE, _("Mismatched right parenthesis (`(')."));
 463                       goto lossage;
 464                     }
 465                   if (contents[n_contents - 1] == LPAREN)
 466                     {
 467                       msg (SE, _("Empty parentheses not allowed."));
 468                       goto lossage;
 469                     }
 470                   inside_parens = 0;
 471                   item = RPAREN;
 472                 }
 473               else
 474                 {
 475                   int content_type;
 476                   int collide_index;
 477
 478                   if (token != T_ID)
 479                     {
 480                       lex_error (_("in CONTENTS subcommand"));
 481                       goto lossage;
 482                     }
 483
 484                   content_type = string_to_content_type (tokid,
 485                                                          &collide_index);
 486                   if (content_type == -1)
 487                     {
 488                       lex_error (_("in CONTENTS subcommand"));
 489                       goto lossage;
 490                     }
 491                   lex_get ();
 492
 493                   if (collide & (1 << collide_index))
 494                     {
 495                       msg (SE, _("Content multiply specified for %s."),
 496                            content_names[content_type]);
 497                       goto lossage;
 498                     }
 499                   collide |= (1 << collide_index);
 500
 501                   item = content_type;
 502                   is_per_factor[item] = inside_parens;
 503                 }
 504               contents[n_contents++] = item;
 505
 506               if (token == '/' || token == '.')
 507                 break;
 508             }
 509
 510           if (inside_parens)
 511             {
 512               msg (SE, _("Missing right parenthesis."));
 513               goto lossage;
 514             }
 515           contents[n_contents] = EOC;
 516         }
 517       else
 518         {
 519           lex_error (NULL);
 520           goto lossage;
 521         }
 522     }
 523
 524   if (token != '.')
 525     {
 526       lex_error (_("expecting end of command"));
 527       goto lossage;
 528     }
 529
 530   if (!(seen & 1))
 531     {
 532       msg (SE, _("Missing VARIABLES subcommand."));
 533       goto lossage;
 534     }
 535
 536   if (!n_contents && !explicit_rowtype)
 537     {
 538       msg (SW, _("CONTENTS subcommand not specified: assuming file "
 539                  "contains only CORR matrix."));
 540
 541       contents[0] = CORR;
 542       contents[1] = EOC;
 543       n_contents = 0;
 544     }
 545
 546   if (n_factors && !explicit_rowtype && cells == -1)
 547     {
 548       msg (SE, _("Missing CELLS subcommand.  CELLS is required "
 549                  "when ROWTYPE_ is not given in the data and "
 550                  "factors are present."));
 551       goto lossage;
 552     }
 553
 554   if (explicit_rowtype && single_split)
 555     {
 556       msg (SE, _("Split file values must be present in the data when "
 557                  "ROWTYPE_ is present."));
 558       goto lossage;
 559     }
 560
 561   /* Create VARNAME_. */
 562   {
 563     varname_ = force_create_variable (&default_dict, "VARNAME_",
 564                                       ALPHA, 8);
 565     varname_->p.mxd.vartype = MXD_VARNAME;
 566     varname_->p.mxd.subtype = 0;
 567   }
 568
 569   /* Sort the dictionary variables into the desired order for the
 570      system file output. */
 571   {
 572     int i;
 573
 574     qsort (default_dict.var, default_dict.nvar, sizeof *default_dict.var,
 575            compare_variables_by_mxd_vartype);
 576
 577     for (i = 0; i < default_dict.nvar; i++)
 578       default_dict.var[i]->index = i;
 579   }
 580
 581   /* Set formats. */
 582   {
 583     static const struct fmt_spec fmt_tab[MXD_COUNT] =
 584       {
 585         {FMT_F, 4, 0},
 586         {FMT_A, 8, 0},
 587         {FMT_F, 4, 0},
 588         {FMT_A, 8, 0},
 589         {FMT_F, 10, 4},
 590       };
 591
 592     int i;
 593
 594     first_continuous = -1;
 595     for (i = 0; i < default_dict.nvar; i++)
 596       {
 597         struct variable *v = default_dict.var[i];
 598         int type = v->p.mxd.vartype;
 599
 600         assert (type >= 0 && type < MXD_COUNT);
 601         v->print = v->write = fmt_tab[type];
 602
 603         if (type == MXD_CONTINUOUS)
 604           n_continuous++;
 605         if (first_continuous == -1 && type == MXD_CONTINUOUS)
 606           first_continuous = i;
 607       }
 608   }
 609
 610   if (n_continuous == 0)
 611     {
 612       msg (SE, _("No continuous variables specified."));
 613       goto lossage;
 614     }
 615
 616 #if DEBUGGING
 617   debug_print ();
 618 #endif
 619
 620   if (explicit_rowtype)
 621     read_matrices_with_rowtype ();
 622   else
 623     read_matrices_without_rowtype ();
 624
 625   pool_destroy (container);
 626
 627   return CMD_SUCCESS;
 628
 629 lossage:
 630   discard_variables ();
 631   free (factors);
 632   pool_destroy (container);
 633   return CMD_FAILURE;
 634 }
 635
 636 /* Look up string S as a content-type name and return the
 637    corresponding enumerated value, or -1 if there is no match.  If
 638    COLLIDE is non-NULL then *COLLIDE returns a value (suitable for use
 639    as a bit-index) which can be used for determining whether a related
 640    statistic has already been used. */
 641 static int
 642 string_to_content_type (char *s, int *collide)
 643 {
 644   static const struct
 645     {
 646       int value;
 647       int collide;
 648       const char *string;
 649     }
 650   *tp,
 651   tab[] =
 652     {
 653       {N_VECTOR, 0, "N_VECTOR"},
 654       {N_VECTOR, 0, "N"},
 655       {N_SCALAR, 0, "N_SCALAR"},
 656       {N_MATRIX, 1, "N_MATRIX"},
 657       {MEAN, 2, "MEAN"},
 658       {STDDEV, 3, "STDDEV"},
 659       {STDDEV, 3, "SD"},
 660       {COUNT, 4, "COUNT"},
 661       {MSE, 5, "MSE"},
 662       {DFE, 6, "DFE"},
 663       {MAT, 7, "MAT"},
 664       {COV, 8, "COV"},
 665       {CORR, 9, "CORR"},
 666       {PROX, 10, "PROX"},
 667       {-1, -1, NULL},
 668     };
 669
 670   for (tp = tab; tp->value != -1; tp++)
 671     if (!strcmp (s, tp->string))
 672       {
 673         if (collide)
 674           *collide = tp->collide;
 675
 676         return tp->value;
 677       }
 678   return -1;
 679 }
 680
 681 /* Compare two variables using p.mxd.vartype and p.mxd.subtype
 682    fields. */
 683 static int
 684 compare_variables_by_mxd_vartype (const void *a_, const void *b_)
 685 {
 686   struct variable *const *pa = a_;
 687   struct variable *const *pb = b_;
 688   const struct matrix_data_proc *a = &(*pa)->p.mxd;
 689   const struct matrix_data_proc *b = &(*pb)->p.mxd;
 690
 691   if (a->vartype != b->vartype)
 692     return a->vartype > b->vartype ? 1 : -1;
 693   else
 694     return a->subtype < b->subtype ? -1 : a->subtype > b->subtype;
 695 }
 696
 697 #if DEBUGGING
 698 /* Print out the command as input. */
 699 static void
 700 debug_print (void)
 701 {
 702   printf ("MATRIX DATA\n\t/VARIABLES=");
 703
 704   {
 705     int i;
 706
 707     for (i = 0; i < default_dict.nvar; i++)
 708       printf ("%s ", default_dict.var[i]->name);
 709   }
 710   printf ("\n");
 711
 712   printf ("\t/FORMAT=");
 713   if (fmt == LIST)
 714     printf ("LIST");
 715   else if (fmt == FREE)
 716     printf ("FREE");
 717   else
 718     assert (0);
 719   if (section == LOWER)
 720     printf (" LOWER");
 721   else if (section == UPPER)
 722     printf (" UPPER");
 723   else if (section == FULL)
 724     printf (" FULL");
 725   else
 726     assert (0);
 727   if (diag == DIAGONAL)
 728     printf (" DIAGONAL\n");
 729   else if (diag == NODIAGONAL)
 730     printf (" NODIAGONAL\n");
 731   else
 732     assert (0);
 733
 734   if (default_dict.n_splits)
 735     {
 736       int i;
 737
 738       printf ("\t/SPLIT=");
 739       for (i = 0; i < default_dict.n_splits; i++)
 740         printf ("%s ", default_dict.splits[i]->name);
 741       if (single_split)
 742         printf ("\t/* single split");
 743       printf ("\n");
 744     }
 745
 746   if (n_factors)
 747     {
 748       int i;
 749
 750       printf ("\t/FACTORS=");
 751       for (i = 0; i < n_factors; i++)
 752         printf ("%s ", factors[i]->name);
 753       printf ("\n");
 754     }
 755
 756   if (cells != -1)
 757     printf ("\t/CELLS=%d\n", cells);
 758
 759   if (pop_n != -1)
 760     printf ("\t/N=%d\n", pop_n);
 761
 762   if (n_contents)
 763     {
 764       int i;
 765       int space = 0;
 766
 767       printf ("\t/CONTENTS=");
 768       for (i = 0; i < n_contents; i++)
 769         {
 770           if (contents[i] == LPAREN)
 771             {
 772               if (space)
 773                 printf (" ");
 774               printf ("(");
 775               space = 0;
 776             }
 777           else if (contents[i] == RPAREN)
 778             {
 779               printf (")");
 780               space = 1;
 781             }
 782           else
 783             {
 784
 785               assert (contents[i] >= 0 && contents[i] <= PROX);
 786               if (space)
 787                 printf (" ");
 788               printf ("%s", content_names[contents[i]]);
 789               space = 1;
 790             }
 791         }
 792       printf ("\n");
 793     }
 794 }
 795 #endif /* DEBUGGING */
 796 \f
 797 /* Matrix tokenizer. */
 798
 799 /* Matrix token types. */
 800 enum
 801   {
 802     MNULL,              /* No token. */
 803     MNUM,               /* Number. */
 804     MSTR,               /* String. */
 805     MSTOP               /* End of file. */
 806   };
 807
 808 /* Current matrix token. */
 809 static int mtoken;
 810
 811 /* Token string if applicable; not null-terminated. */
 812 static char *mtokstr;
 813
 814 /* Length of mtokstr in characters. */
 815 static int mtoklen;
 816
 817 /* Token value if applicable. */
 818 static double mtokval;
 819
 820 static int mget_token (void);
 821
 822 #if DEBUGGING
 823 #define mget_token() mget_token_dump()
 824
 825 static int
 826 mget_token_dump (void)
 827 {
 828   int result = (mget_token) ();
 829   mdump_token ();
 830   return result;
 831 }
 832
 833 static void
 834 mdump_token (void)
 835 {
 836   switch (mtoken)
 837     {
 838     case MNULL:
 839       printf (" <NULLTOK>");
 840       break;
 841     case MNUM:
 842       printf (" #%g", mtokval);
 843       break;
 844     case MSTR:
 845       printf (" #'%.*s'", mtoklen, mtokstr);
 846       break;
 847     case MSTOP:
 848       printf (" <STOP>");
 849       break;
 850     default:
 851       assert (0);
 852     }
 853   fflush (stdout);
 854 }
 855 #endif
 856
 857 /* Return the current position in the data file. */
 858 static const char *
 859 context (void)
 860 {
 861   static char buf[32];
 862   int len;
 863   char *p = dfm_get_record (data_file, &len);
 864
 865   if (!p || !len)
 866     strcpy (buf, "at end of line");
 867   else
 868     {
 869       char *cp = buf;
 870       int n_copy = min (10, len);
 871       cp = stpcpy (buf, "before `");
 872       while (n_copy && isspace ((unsigned char) *p))
 873         p++, n_copy++;
 874       while (n_copy && !isspace ((unsigned char) *p))
 875         *cp++ = *p++, n_copy--;
 876       *cp++ = '\'';
 877       *cp = 0;
 878     }
 879
 880   return buf;
 881 }
 882
 883 /* Is there at least one token left in the data file? */
 884 static int
 885 another_token (void)
 886 {
 887   char *cp, *ep;
 888   int len;
 889
 890   if (mtoken == MSTOP)
 891     return 0;
 892
 893   for (;;)
 894     {
 895       cp = dfm_get_record (data_file, &len);
 896       if (!cp)
 897         return 0;
 898
 899       ep = cp + len;
 900       while (isspace ((unsigned char) *cp) && cp < ep)
 901         cp++;
 902
 903       if (cp < ep)
 904         break;
 905
 906       dfm_fwd_record (data_file);
 907     }
 908
 909   dfm_set_record (data_file, cp);
 910
 911   return 1;
 912 }
 913
 914 /* Parse a MATRIX DATA token from data_file into mtok*. */
 915 static int
 916 (mget_token) (void)
 917 {
 918   char *cp, *ep;
 919   int len;
 920   int first_column;
 921
 922   for (;;)
 923     {
 924       cp = dfm_get_record (data_file, &len);
 925       if (!cp)
 926         {
 927           if (mtoken == MSTOP)
 928             return 0;
 929           mtoken = MSTOP;
 930           return 1;
 931         }
 932
 933       ep = cp + len;
 934       while (isspace ((unsigned char) *cp) && cp < ep)
 935         cp++;
 936
 937       if (cp < ep)
 938         break;
 939
 940       dfm_fwd_record (data_file);
 941     }
 942
 943   dfm_set_record (data_file, cp);
 944   first_column = dfm_get_cur_col (data_file) + 1;
 945
 946   /* Three types of fields: quoted with ', quoted with ", unquoted. */
 947   if (*cp == '\'' || *cp == '"')
 948     {
 949       int quote = *cp;
 950
 951       mtoken = MSTR;
 952       mtokstr = ++cp;
 953       while (cp < ep && *cp != quote)
 954         cp++;
 955       mtoklen = cp - mtokstr;
 956       if (cp < ep)
 957         cp++;
 958       else
 959         msg (SW, _("Scope of string exceeds line."));
 960     }
 961   else
 962     {
 963       int is_num = isdigit ((unsigned char) *cp) || *cp == '.';
 964
 965       mtokstr = cp++;
 966       while (cp < ep && !isspace ((unsigned char) *cp) && *cp != ','
 967              && *cp != '-' && *cp != '+')
 968         {
 969           if (isdigit ((unsigned char) *cp))
 970             is_num = 1;
 971
 972           if ((tolower ((unsigned char) *cp) == 'd'
 973                || tolower ((unsigned char) *cp) == 'e')
 974               && (cp[1] == '+' || cp[1] == '-'))
 975             cp += 2;
 976           else
 977             cp++;
 978         }
 979
 980       mtoklen = cp - mtokstr;
 981       assert (mtoklen);
 982
 983       if (is_num)
 984         {
 985           struct data_in di;
 986
 987           di.s = mtokstr;
 988           di.e = mtokstr + mtoklen;
 989           di.v = (union value *) &mtokval;
 990           di.f1 = first_column;
 991           di.format.type = FMT_F;
 992           di.format.w = mtoklen;
 993           di.format.d = 0;
 994
 995           if (!data_in (&di))
 996             return 0;
 997         }
 998       else
 999         mtoken = MSTR;
1000     }
1001
1002   dfm_set_record (data_file, cp);
1003
1004   return 1;
1005 }
1006
1007 /* Forcibly skip the end of a line for content type CONTENT in
1008    data_file. */
1009 static int
1010 force_eol (const char *content)
1011 {
1012   char *cp;
1013   int len;
1014
1015   if (fmt == FREE)
1016     return 1;
1017
1018   cp = dfm_get_record (data_file, &len);
1019   if (!cp)
1020     return 0;
1021   while (len && isspace (*cp))
1022     cp++, len--;
1023
1024   if (len)
1025     {
1026       msg (SE, _("End of line expected %s while reading %s."),
1027            context (), content);
1028       return 0;
1029     }
1030
1031   dfm_fwd_record (data_file);
1032
1033   return 1;
1034 }
1035 \f
1036 /* Back end, omitting ROWTYPE_. */
1037
1038 /* MATRIX DATA data. */
1039 static double ***nr_data;
1040
1041 /* Factor values. */
1042 static double *nr_factor_values;
1043
1044 /* Largest-numbered cell that we have read in thus far, plus one. */
1045 static int max_cell_index;
1046
1047 /* SPLIT FILE variable values. */
1048 static double *split_values;
1049
1050 static int nr_read_splits (int compare);
1051 static int nr_read_factors (int cell);
1052 static void nr_output_data (void);
1053 static int matrix_data_read_without_rowtype (void);
1054
1055 /* Read from the data file and write it to the active file. */
1056 static void
1057 read_matrices_without_rowtype (void)
1058 {
1059   if (cells == -1)
1060     cells = 1;
1061
1062   mtoken = MNULL;
1063   split_values = xmalloc (sizeof *split_values * default_dict.n_splits);
1064   nr_factor_values = xmalloc (sizeof *nr_factor_values * n_factors * cells);
1065   max_cell_index = 0;
1066
1067   matrix_data_source.read = (void (*)(void)) matrix_data_read_without_rowtype;
1068   vfm_source = &matrix_data_source;
1069
1070   procedure (NULL, NULL, NULL);
1071
1072   free (split_values);
1073   free (nr_factor_values);
1074
1075   fh_close_handle (data_file);
1076 }
1077
1078 /* Mirror data across the diagonal of matrix CP which contains
1079    CONTENT type data. */
1080 static void
1081 fill_matrix (int content, double *cp)
1082 {
1083   int type = content_type[content];
1084
1085   if (type == 1 && section != FULL)
1086     {
1087       if (diag == NODIAGONAL)
1088         {
1089           const double fill = content == CORR ? 1.0 : SYSMIS;
1090           int i;
1091
1092           for (i = 0; i < n_continuous; i++)
1093             cp[i * (1 + n_continuous)] = fill;
1094         }
1095
1096       {
1097         int c, r;
1098
1099         if (section == LOWER)
1100           {
1101             int n_lines = n_continuous;
1102             if (section != FULL && diag == NODIAGONAL)
1103               n_lines--;
1104
1105             for (r = 1; r < n_lines; r++)
1106               for (c = 0; c < r; c++)
1107                 cp[r + c * n_continuous] = cp[c + r * n_continuous];
1108           }
1109         else
1110           {
1111             assert (section == UPPER);
1112             for (r = 1; r < n_continuous; r++)
1113               for (c = 0; c < r; c++)
1114                 cp[c + r * n_continuous] = cp[r + c * n_continuous];
1115           }
1116       }
1117     }
1118   else if (type == 2)
1119     {
1120       int c;
1121
1122       for (c = 1; c < n_continuous; c++)
1123         cp[c] = cp[0];
1124     }
1125 }
1126
1127 /* Read data lines for content type CONTENT from the data file.  If
1128    PER_FACTOR is nonzero, then factor information is read from the
1129    data file.  Data is for cell number CELL. */
1130 static int
1131 nr_read_data_lines (int per_factor, int cell, int content, int compare)
1132 {
1133   /* Content type. */
1134   const int type = content_type[content];
1135
1136   /* Number of lines that must be parsed from the data file for this
1137      content type. */
1138   int n_lines;
1139
1140   /* Current position in vector or matrix. */
1141   double *cp;
1142
1143   /* Counter. */
1144   int i;
1145
1146   if (type != 1)
1147     n_lines = 1;
1148   else
1149     {
1150       n_lines = n_continuous;
1151       if (section != FULL && diag == NODIAGONAL)
1152         n_lines--;
1153     }
1154
1155   cp = nr_data[content][cell];
1156   if (type == 1 && section == LOWER && diag == NODIAGONAL)
1157     cp += n_continuous;
1158
1159   for (i = 0; i < n_lines; i++)
1160     {
1161       int n_cols;
1162
1163       if (!nr_read_splits (1))
1164         return 0;
1165       if (per_factor && !nr_read_factors (cell))
1166         return 0;
1167       compare = 1;
1168
1169       switch (type)
1170         {
1171         case 0:
1172           n_cols = n_continuous;
1173           break;
1174         case 1:
1175           switch (section)
1176             {
1177             case LOWER:
1178               n_cols = i + 1;
1179               break;
1180             case UPPER:
1181               cp += i;
1182               n_cols = n_continuous - i;
1183               if (diag == NODIAGONAL)
1184                 {
1185                   n_cols--;
1186                   cp++;
1187                 }
1188               break;
1189             case FULL:
1190               n_cols = n_continuous;
1191               break;
1192             default:
1193               assert (0);
1194             }
1195           break;
1196         case 2:
1197           n_cols = 1;
1198           break;
1199         default:
1200           assert (0);
1201         }
1202
1203       {
1204         int j;
1205
1206         for (j = 0; j < n_cols; j++)
1207           {
1208             if (!mget_token ())
1209               return 0;
1210             if (mtoken != MNUM)
1211               {
1212                 msg (SE, _("expecting value for %s %s"),
1213                      default_dict.var[j]->name, context ());
1214                 return 0;
1215               }
1216
1217             *cp++ = mtokval;
1218           }
1219         if (!force_eol (content_names[content]))
1220           return 0;
1221         debug_printf (("\n"));
1222       }
1223
1224       if (section == LOWER)
1225         cp += n_continuous - n_cols;
1226     }
1227
1228   fill_matrix (content, nr_data[content][cell]);
1229
1230   return 1;
1231 }
1232
1233 /* When ROWTYPE_ does not appear in the data, reads the matrices and
1234    writes them to the output file.  Returns success. */
1235 static int
1236 matrix_data_read_without_rowtype (void)
1237 {
1238   {
1239     int *cp;
1240
1241     nr_data = pool_alloc (container, (PROX + 1) * sizeof *nr_data);
1242
1243     {
1244       int i;
1245
1246       for (i = 0; i <= PROX; i++)
1247         nr_data[i] = NULL;
1248     }
1249
1250     for (cp = contents; *cp != EOC; cp++)
1251       if (*cp != LPAREN && *cp != RPAREN)
1252         {
1253           int per_factor = is_per_factor[*cp];
1254           int n_entries;
1255
1256           n_entries = n_continuous;
1257           if (content_type[*cp] == 1)
1258             n_entries *= n_continuous;
1259
1260           {
1261             int n_vectors = per_factor ? cells : 1;
1262             int i;
1263
1264             nr_data[*cp] = pool_alloc (container,
1265                                        n_vectors * sizeof **nr_data);
1266
1267             for (i = 0; i < n_vectors; i++)
1268               nr_data[*cp][i] = pool_alloc (container,
1269                                             n_entries * sizeof ***nr_data);
1270           }
1271         }
1272   }
1273
1274   for (;;)
1275     {
1276       int *bp, *ep, *np;
1277
1278       if (!nr_read_splits (0))
1279         return 0;
1280
1281       for (bp = contents; *bp != EOC; bp = np)
1282         {
1283           int per_factor;
1284
1285           /* Trap the CONTENTS that we should parse in this pass
1286              between bp and ep.  Set np to the starting bp for next
1287              iteration. */
1288           if (*bp == LPAREN)
1289             {
1290               ep = ++bp;
1291               while (*ep != RPAREN)
1292                 ep++;
1293               np = &ep[1];
1294               per_factor = 1;
1295             }
1296           else
1297             {
1298               ep = &bp[1];
1299               while (*ep != EOC && *ep != LPAREN)
1300                 ep++;
1301               np = ep;
1302               per_factor = 0;
1303             }
1304
1305           {
1306             int i;
1307
1308             for (i = 0; i < (per_factor ? cells : 1); i++)
1309               {
1310                 int *cp;
1311
1312                 for (cp = bp; cp < ep; cp++)
1313                   if (!nr_read_data_lines (per_factor, i, *cp, cp != bp))
1314                     return 0;
1315               }
1316           }
1317         }
1318
1319       nr_output_data ();
1320
1321       if (default_dict.n_splits == 0 || !another_token ())
1322         return 1;
1323     }
1324 }
1325
1326 /* Read the split file variables.  If COMPARE is 1, compares the
1327    values read to the last values read and returns 1 if they're equal,
1328    0 otherwise. */
1329 static int
1330 nr_read_splits (int compare)
1331 {
1332   static int just_read = 0;
1333
1334   if (compare && just_read)
1335     {
1336       just_read = 0;
1337       return 1;
1338     }
1339
1340   if (default_dict.n_splits == 0)
1341     return 1;
1342
1343   if (single_split)
1344     {
1345       if (!compare)
1346         split_values[0] = ++default_dict.splits[0]->p.mxd.subtype;
1347       return 1;
1348     }
1349
1350   if (!compare)
1351     just_read = 1;
1352
1353   {
1354     int i;
1355
1356     for (i = 0; i < default_dict.n_splits; i++)
1357       {
1358         if (!mget_token ())
1359           return 0;
1360         if (mtoken != MNUM)
1361           {
1362             msg (SE, _("Syntax error expecting SPLIT FILE value %s."),
1363                  context ());
1364             return 0;
1365           }
1366
1367         if (!compare)
1368           split_values[i] = mtokval;
1369         else if (split_values[i] != mtokval)
1370           {
1371             msg (SE, _("Expecting value %g for %s."),
1372                   split_values[i], default_dict.splits[i]->name);
1373             return 0;
1374           }
1375       }
1376   }
1377
1378   return 1;
1379 }
1380
1381 /* Read the factors for cell CELL.  If COMPARE is 1, compares the
1382    values read to the last values read and returns 1 if they're equal,
1383    0 otherwise. */
1384 static int
1385 nr_read_factors (int cell)
1386 {
1387   int compare;
1388
1389   if (n_factors == 0)
1390     return 1;
1391
1392   assert (max_cell_index >= cell);
1393   if (cell != max_cell_index)
1394     compare = 1;
1395   else
1396     {
1397       compare = 0;
1398       max_cell_index++;
1399     }
1400
1401   {
1402     int i;
1403
1404     for (i = 0; i < n_factors; i++)
1405       {
1406         if (!mget_token ())
1407           return 0;
1408         if (mtoken != MNUM)
1409           {
1410             msg (SE, _("Syntax error expecting factor value %s."),
1411                  context ());
1412             return 0;
1413           }
1414
1415         if (!compare)
1416           nr_factor_values[i + n_factors * cell] = mtokval;
1417         else if (nr_factor_values[i + n_factors * cell] != mtokval)
1418           {
1419             msg (SE, _("Syntax error expecting value %g for %s %s."),
1420                  nr_factor_values[i + n_factors * cell],
1421                  factors[i]->name, context ());
1422             return 0;
1423           }
1424       }
1425   }
1426
1427   return 1;
1428 }
1429
1430 /* Write the contents of a cell having content type CONTENT and data
1431    CP to the active file. */
1432 static void
1433 dump_cell_content (int content, double *cp)
1434 {
1435   int type = content_type[content];
1436
1437   {
1438     st_bare_pad_copy (temp_case->data[rowtype_->fv].s,
1439                       content_names[content], 8);
1440
1441     if (type != 1)
1442       memset (&temp_case->data[varname_->fv].s, ' ', 8);
1443   }
1444
1445   {
1446     int n_lines = (type == 1) ? n_continuous : 1;
1447     int i;
1448
1449     for (i = 0; i < n_lines; i++)
1450       {
1451         int j;
1452
1453         for (j = 0; j < n_continuous; j++)
1454           {
1455             temp_case->data[(default_dict.var
1456                              [first_continuous + j]->fv)].f = *cp;
1457             debug_printf (("c:%s(%g) ",
1458                            default_dict.var[first_continuous + j]->name,
1459                            *cp));
1460             cp++;
1461           }
1462         if (type == 1)
1463           st_bare_pad_copy (temp_case->data[varname_->fv].s,
1464                             default_dict.var[first_continuous + i]->name,
1465                             8);
1466         debug_printf (("\n"));
1467         write_case ();
1468       }
1469   }
1470 }
1471
1472 /* Finally dump out everything from nr_data[] to the output file. */
1473 static void
1474 nr_output_data (void)
1475 {
1476   {
1477     int i;
1478
1479     for (i = 0; i < default_dict.n_splits; i++)
1480       temp_case->data[default_dict.splits[i]->fv].f = split_values[i];
1481   }
1482
1483   if (n_factors)
1484     {
1485       int cell;
1486
1487       for (cell = 0; cell < cells; cell++)
1488         {
1489           {
1490             int factor;
1491
1492             for (factor = 0; factor < n_factors; factor++)
1493               {
1494                 temp_case->data[factors[factor]->fv].f
1495                   = nr_factor_values[factor + cell * n_factors];
1496                 debug_printf (("f:%s ", factors[factor]->name));
1497               }
1498           }
1499
1500           {
1501             int content;
1502
1503             for (content = 0; content <= PROX; content++)
1504               if (is_per_factor[content])
1505                 {
1506                   assert (nr_data[content] != NULL
1507                           && nr_data[content][cell] != NULL);
1508
1509                   dump_cell_content (content, nr_data[content][cell]);
1510                 }
1511           }
1512         }
1513     }
1514
1515   {
1516     int content;
1517
1518     {
1519       int factor;
1520
1521       for (factor = 0; factor < n_factors; factor++)
1522         temp_case->data[factors[factor]->fv].f = SYSMIS;
1523     }
1524
1525     for (content = 0; content <= PROX; content++)
1526       if (!is_per_factor[content] && nr_data[content] != NULL)
1527         dump_cell_content (content, nr_data[content][0]);
1528   }
1529 }
1530 \f
1531 /* Back end, with ROWTYPE_. */
1532
1533 /* Type of current row. */
1534 static int wr_content;
1535
1536 /* All the data for one set of factor values. */
1537 struct factor_data
1538   {
1539     double *factors;
1540     int n_rows[PROX + 1];
1541     double *data[PROX + 1];
1542     struct factor_data *next;
1543   };
1544
1545 /* All the data, period. */
1546 struct factor_data *wr_data;
1547
1548 /* Current factor. */
1549 struct factor_data *wr_current;
1550
1551 static int wr_read_splits (void);
1552 static int wr_output_data (void);
1553 static int wr_read_rowtype (void);
1554 static int wr_read_factors (void);
1555 static int wr_read_indeps (void);
1556 static int matrix_data_read_with_rowtype (void);
1557
1558 /* When ROWTYPE_ appears in the data, reads the matrices and writes
1559    them to the output file. */
1560 static void
1561 read_matrices_with_rowtype (void)
1562 {
1563   mtoken = MNULL;
1564   wr_data = wr_current = NULL;
1565   split_values = NULL;
1566   cells = 0;
1567
1568   matrix_data_source.read = (void (*)(void)) matrix_data_read_with_rowtype;
1569   vfm_source = &matrix_data_source;
1570
1571   procedure (NULL, NULL, NULL);
1572
1573   free (split_values);
1574   fh_close_handle (data_file);
1575 }
1576
1577 /* Read from the data file and write it to the active file. */
1578 static int
1579 matrix_data_read_with_rowtype (void)
1580 {
1581   do
1582     {
1583       if (!wr_read_splits ())
1584         return 0;
1585
1586       if (!wr_read_factors ())
1587         return 0;
1588
1589       if (!wr_read_indeps ())
1590         return 0;
1591     }
1592   while (another_token ());
1593
1594   wr_output_data ();
1595   return 1;
1596 }
1597
1598 /* Read the split file variables.  If they differ from the previous
1599    set of split variables then output the data.  Returns success. */
1600 static int
1601 wr_read_splits (void)
1602 {
1603   int compare;
1604
1605   if (default_dict.n_splits == 0)
1606     return 1;
1607
1608   if (split_values)
1609     compare = 1;
1610   else
1611     {
1612       compare = 0;
1613       split_values = xmalloc (sizeof *split_values * default_dict.n_splits);
1614     }
1615
1616   {
1617     int different = 0;
1618     int i;
1619
1620     for (i = 0; i < default_dict.n_splits; i++)
1621       {
1622         if (!mget_token ())
1623           return 0;
1624         if (mtoken != MNUM)
1625           {
1626             msg (SE, _("Syntax error %s expecting SPLIT FILE value."),
1627                  context ());
1628             return 0;
1629           }
1630
1631         if (compare && split_values[i] != mtokval && !different)
1632           {
1633             if (!wr_output_data ())
1634               return 0;
1635             different = 1;
1636             cells = 0;
1637           }
1638         split_values[i] = mtokval;
1639       }
1640   }
1641
1642   return 1;
1643 }
1644
1645 /* Compares doubles A and B, treating SYSMIS as greatest. */
1646 static int
1647 compare_doubles (const void *a_, const void *b_, void *aux unused)
1648 {
1649   const double *a = a_;
1650   const double *b = b_;
1651
1652   if (*a == *b)
1653     return 0;
1654   else if (*a == SYSMIS)
1655     return 1;
1656   else if (*b == SYSMIS)
1657     return -1;
1658   else if (*a > *b)
1659     return 1;
1660   else
1661     return -1;
1662 }
1663
1664 /* Return strcmp()-type comparison of the n_factors factors at _A and
1665    _B.  Sort missing values toward the end. */
1666 static int
1667 compare_factors (const void *a_, const void *b_)
1668 {
1669   struct factor_data *const *pa = a_;
1670   struct factor_data *const *pb = b_;
1671   const double *a = (*pa)->factors;
1672   const double *b = (*pb)->factors;
1673
1674   return lexicographical_compare (a, n_factors,
1675                                   b, n_factors,
1676                                   sizeof *a,
1677                                   compare_doubles, NULL);
1678 }
1679
1680 /* Write out the data for the current split file to the active
1681    file. */
1682 static int
1683 wr_output_data (void)
1684 {
1685   {
1686     int i;
1687
1688     for (i = 0; i < default_dict.n_splits; i++)
1689       temp_case->data[default_dict.splits[i]->fv].f = split_values[i];
1690   }
1691
1692   /* Sort the wr_data list. */
1693   {
1694     struct factor_data **factors;
1695     struct factor_data *iter;
1696     int i;
1697
1698     factors = xmalloc (sizeof *factors * cells);
1699
1700     for (i = 0, iter = wr_data; iter; iter = iter->next, i++)
1701       factors[i] = iter;
1702
1703     qsort (factors, cells, sizeof *factors, compare_factors);
1704
1705     wr_data = factors[0];
1706     for (i = 0; i < cells - 1; i++)
1707       factors[i]->next = factors[i + 1];
1708     factors[cells - 1]->next = NULL;
1709
1710     free (factors);
1711   }
1712
1713   /* Write out records for every set of factor values. */
1714   {
1715     struct factor_data *iter;
1716
1717     for (iter = wr_data; iter; iter = iter->next)
1718       {
1719         {
1720           int factor;
1721
1722           for (factor = 0; factor < n_factors; factor++)
1723             {
1724               temp_case->data[factors[factor]->fv].f
1725                 = iter->factors[factor];
1726               debug_printf (("f:%s ", factors[factor]->name));
1727             }
1728         }
1729
1730         {
1731           int content;
1732
1733           for (content = 0; content <= PROX; content++)
1734             {
1735               if (!iter->n_rows[content])
1736                 continue;
1737
1738               {
1739                 int type = content_type[content];
1740                 int n_lines = (type == 1
1741                                ? (n_continuous
1742                                   - (section != FULL && diag == NODIAGONAL))
1743                                : 1);
1744
1745                 if (n_lines != iter->n_rows[content])
1746                   {
1747                     msg (SE, _("Expected %d lines of data for %s content; "
1748                                "actually saw %d lines.  No data will be "
1749                                "output for this content."),
1750                          n_lines, content_names[content],
1751                          iter->n_rows[content]);
1752                     continue;
1753                   }
1754               }
1755
1756               fill_matrix (content, iter->data[content]);
1757
1758               dump_cell_content (content, iter->data[content]);
1759             }
1760         }
1761       }
1762   }
1763
1764   pool_destroy (container);
1765   container = pool_create ();
1766
1767   wr_data = wr_current = NULL;
1768
1769   return 1;
1770 }
1771
1772 /* Read ROWTYPE_ from the data file.  Return success. */
1773 static int
1774 wr_read_rowtype (void)
1775 {
1776   if (wr_content != -1)
1777     {
1778       msg (SE, _("Multiply specified ROWTYPE_ %s."), context ());
1779       return 0;
1780     }
1781   if (mtoken != MSTR)
1782     {
1783       msg (SE, _("Syntax error %s expecting ROWTYPE_ string."), context ());
1784       return 0;
1785     }
1786
1787   {
1788     char s[16];
1789     char *cp;
1790
1791     memcpy (s, mtokstr, min (15, mtoklen));
1792     s[min (15, mtoklen)] = 0;
1793
1794     for (cp = s; *cp; cp++)
1795       *cp = toupper ((unsigned char) *cp);
1796
1797     wr_content = string_to_content_type (s, NULL);
1798   }
1799
1800   if (wr_content == -1)
1801     {
1802       msg (SE, _("Syntax error %s."), context ());
1803       return 0;
1804     }
1805
1806   return 1;
1807 }
1808
1809 /* Read the factors for the current row.  Select a set of factors and
1810    point wr_current to it. */
1811 static int
1812 wr_read_factors (void)
1813 {
1814   double *factor_values = local_alloc (sizeof *factor_values * n_factors);
1815
1816   wr_content = -1;
1817   {
1818     int i;
1819
1820     for (i = 0; i < n_factors; i++)
1821       {
1822         if (!mget_token ())
1823           goto lossage;
1824         if (mtoken == MSTR)
1825           {
1826             if (!wr_read_rowtype ())
1827               goto lossage;
1828             if (!mget_token ())
1829               goto lossage;
1830           }
1831         if (mtoken != MNUM)
1832           {
1833             msg (SE, _("Syntax error expecting factor value %s."),
1834                  context ());
1835             goto lossage;
1836           }
1837
1838         factor_values[i] = mtokval;
1839       }
1840   }
1841   if (wr_content == -1)
1842     {
1843       if (!mget_token ())
1844         goto lossage;
1845       if (!wr_read_rowtype ())
1846         goto lossage;
1847     }
1848
1849   /* Try the most recent factor first as a simple caching
1850      mechanism. */
1851   if (wr_current)
1852     {
1853       int i;
1854
1855       for (i = 0; i < n_factors; i++)
1856         if (factor_values[i] != wr_current->factors[i])
1857           goto cache_miss;
1858       goto winnage;
1859     }
1860
1861   /* Linear search through the list. */
1862 cache_miss:
1863   {
1864     struct factor_data *iter;
1865
1866     for (iter = wr_data; iter; iter = iter->next)
1867       {
1868         int i;
1869
1870         for (i = 0; i < n_factors; i++)
1871           if (factor_values[i] != iter->factors[i])
1872             goto next_item;
1873
1874         wr_current = iter;
1875         goto winnage;
1876
1877       next_item: ;
1878       }
1879   }
1880
1881   /* Not found.  Make a new item. */
1882   {
1883     struct factor_data *new = pool_alloc (container, sizeof *new);
1884
1885     new->factors = pool_alloc (container, sizeof *new->factors * n_factors);
1886
1887     {
1888       int i;
1889
1890       for (i = 0; i < n_factors; i++)
1891         new->factors[i] = factor_values[i];
1892     }
1893
1894     {
1895       int i;
1896
1897       for (i = 0; i <= PROX; i++)
1898         {
1899           new->n_rows[i] = 0;
1900           new->data[i] = NULL;
1901         }
1902     }
1903
1904     new->next = wr_data;
1905     wr_data = wr_current = new;
1906     cells++;
1907   }
1908
1909 winnage:
1910   local_free (factor_values);
1911   return 1;
1912
1913 lossage:
1914   local_free (factor_values);
1915   return 0;
1916 }
1917
1918 /* Read the independent variables into wr_current. */
1919 static int
1920 wr_read_indeps (void)
1921 {
1922   struct factor_data *c = wr_current;
1923   const int type = content_type[wr_content];
1924   const int n_rows = c->n_rows[wr_content];
1925   double *cp;
1926   int n_cols;
1927
1928   /* Allocate room for data if necessary. */
1929   if (c->data[wr_content] == NULL)
1930     {
1931       int n_items = n_continuous;
1932       if (type == 1)
1933         n_items *= n_continuous;
1934
1935       c->data[wr_content] = pool_alloc (container,
1936                                         sizeof **c->data * n_items);
1937     }
1938
1939   cp = &c->data[wr_content][n_rows * n_continuous];
1940
1941   /* Figure out how much to read from this line. */
1942   switch (type)
1943     {
1944     case 0:
1945     case 2:
1946       if (n_rows > 0)
1947         {
1948           msg (SE, _("Duplicate specification for %s."),
1949                content_names[wr_content]);
1950           return 0;
1951         }
1952       if (type == 0)
1953         n_cols = n_continuous;
1954       else
1955         n_cols = 1;
1956       break;
1957     case 1:
1958       if (n_rows >= n_continuous - (section != FULL && diag == NODIAGONAL))
1959         {
1960           msg (SE, _("Too many rows of matrix data for %s."),
1961                content_names[wr_content]);
1962           return 0;
1963         }
1964
1965       switch (section)
1966         {
1967         case LOWER:
1968           n_cols = n_rows + 1;
1969           if (diag == NODIAGONAL)
1970             cp += n_continuous;
1971           break;
1972         case UPPER:
1973           cp += n_rows;
1974           n_cols = n_continuous - n_rows;
1975           if (diag == NODIAGONAL)
1976             {
1977               n_cols--;
1978               cp++;
1979             }
1980           break;
1981         case FULL:
1982           n_cols = n_continuous;
1983           break;
1984         default:
1985           assert (0);
1986         }
1987       break;
1988     default:
1989       assert (0);
1990     }
1991   c->n_rows[wr_content]++;
1992
1993   debug_printf ((" (c=%p,r=%d,n=%d)", c, n_rows + 1, n_cols));
1994
1995   /* Read N_COLS items at CP. */
1996   {
1997     int j;
1998
1999     for (j = 0; j < n_cols; j++)
2000       {
2001         if (!mget_token ())
2002           return 0;
2003         if (mtoken != MNUM)
2004           {
2005             msg (SE, _("Syntax error expecting value for %s %s."),
2006                  default_dict.var[first_continuous + j]->name, context ());
2007             return 0;
2008           }
2009
2010         *cp++ = mtokval;
2011       }
2012     if (!force_eol (content_names[wr_content]))
2013       return 0;
2014     debug_printf (("\n"));
2015   }
2016
2017   return 1;
2018 }
2019 \f
2020 /* Matrix source. */
2021
2022 struct case_stream matrix_data_source =
2023   {
2024     NULL,
2025     NULL,
2026     NULL,
2027     NULL,
2028     NULL,
2029     NULL,
2030     "MATRIX DATA",
2031   };
2032