src/language/data-io/matrix-data.c

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