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