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

   1 /* PSPP - computes sample statistics.
   2    Copyright (C) 1997-9, 2000 Free Software Foundation, Inc.
   3    Written by Ben Pfaff <blp@gnu.org>.
   4
   5    This program is free software; you can redistribute it and/or
   6    modify it under the terms of the GNU General Public License as
   7    published by the Free Software Foundation; either version 2 of the
   8    License, or (at your option) any later version.
   9
  10    This program is distributed in the hope that it will be useful, but
  11    WITHOUT ANY WARRANTY; without even the implied warranty of
  12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13    General Public License for more details.
  14
  15    You should have received a copy of the GNU General Public License
  16    along with this program; if not, write to the Free Software
  17    Foundation, Inc., 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 (char *, int *);
 174 static void attach_mxd_aux (struct variable *, int var_type, int sub_type);
 175
 176 int
 177 cmd_matrix_data (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 (token != '.')
 208     {
 209       lex_match ('/');
 210
 211       if (lex_match_id ("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 ('=');
 224           if (!parse_DATA_LIST_vars (&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 ("FILE"))
 266         {
 267           lex_match ('=');
 268           fh = fh_parse (FH_REF_FILE | FH_REF_INLINE);
 269           if (fh == NULL)
 270             goto lossage;
 271         }
 272       else if (lex_match_id ("FORMAT"))
 273         {
 274           lex_match ('=');
 275
 276           while (token == T_ID)
 277             {
 278               if (lex_match_id ("LIST"))
 279                 mx->fmt = LIST;
 280               else if (lex_match_id ("FREE"))
 281                 mx->fmt = FREE;
 282               else if (lex_match_id ("LOWER"))
 283                 mx->section = LOWER;
 284               else if (lex_match_id ("UPPER"))
 285                 mx->section = UPPER;
 286               else if (lex_match_id ("FULL"))
 287                 mx->section = FULL;
 288               else if (lex_match_id ("DIAGONAL"))
 289                 mx->diag = DIAGONAL;
 290               else if (lex_match_id ("NODIAGONAL"))
 291                 mx->diag = NODIAGONAL;
 292               else
 293                 {
 294                   lex_error (_("in FORMAT subcommand"));
 295                   goto lossage;
 296                 }
 297             }
 298         }
 299       else if (lex_match_id ("SPLIT"))
 300         {
 301           lex_match ('=');
 302
 303           if (seen & 2)
 304             {
 305               msg (SE, _("SPLIT subcommand multiply specified."));
 306               goto lossage;
 307             }
 308           seen |= 2;
 309
 310           if (token != T_ID)
 311             {
 312               lex_error (_("in SPLIT subcommand"));
 313               goto lossage;
 314             }
 315
 316           if (dict_lookup_var (dataset_dict (ds), tokid) == NULL
 317               && (lex_look_ahead () == '.' || lex_look_ahead () == '/'))
 318             {
 319               if (!strcasecmp (tokid, "ROWTYPE_")
 320                   || !strcasecmp (tokid, "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                                                          tokid, 0);
 329               attach_mxd_aux (mx->single_split, MXD_CONTINUOUS, 0);
 330               lex_get ();
 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 (dataset_dict (ds), &split, &n, PV_NO_DUPLICATE))
 340                 goto lossage;
 341
 342               dict_set_split_vars (dataset_dict (ds), split, n);
 343             }
 344
 345           {
 346             struct variable *const *split = dict_get_split_vars (dataset_dict (ds));
 347             size_t split_cnt = dict_get_split_cnt (dataset_dict (ds));
 348             int i;
 349
 350             for (i = 0; i < split_cnt; i++)
 351               {
 352                 struct mxd_var *mv = split[i]->aux;
 353                 assert (mv != NULL);
 354                 if (mv->var_type != MXD_CONTINUOUS)
 355                   {
 356                     msg (SE, _("Split variable %s is already another type."),
 357                          tokid);
 358                     goto lossage;
 359                   }
 360                 var_clear_aux (split[i]);
 361                 attach_mxd_aux (split[i], MXD_SPLIT, i);
 362               }
 363           }
 364         }
 365       else if (lex_match_id ("FACTORS"))
 366         {
 367           lex_match ('=');
 368
 369           if (seen & 4)
 370             {
 371               msg (SE, _("FACTORS subcommand multiply specified."));
 372               goto lossage;
 373             }
 374           seen |= 4;
 375
 376           if (!parse_variables (dataset_dict (ds), &mx->factors, &mx->n_factors,
 377                                 PV_NONE))
 378             goto lossage;
 379
 380           {
 381             size_t i;
 382
 383             for (i = 0; i < mx->n_factors; i++)
 384               {
 385                 struct variable *v = mx->factors[i];
 386                 struct mxd_var *mv = v->aux;
 387                 assert (mv != NULL);
 388                 if (mv->var_type != MXD_CONTINUOUS)
 389                   {
 390                     msg (SE, _("Factor variable %s is already another type."),
 391                          tokid);
 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 ("CELLS"))
 400         {
 401           lex_match ('=');
 402
 403           if (mx->cells != -1)
 404             {
 405               msg (SE, _("CELLS subcommand multiply specified."));
 406               goto lossage;
 407             }
 408
 409           if (!lex_is_integer () || lex_integer () < 1)
 410             {
 411               lex_error (_("expecting positive integer"));
 412               goto lossage;
 413             }
 414
 415           mx->cells = lex_integer ();
 416           lex_get ();
 417         }
 418       else if (lex_match_id ("N"))
 419         {
 420           lex_match ('=');
 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 () || lex_integer () < 1)
 429             {
 430               lex_error (_("expecting positive integer"));
 431               goto lossage;
 432             }
 433
 434           mx->pop_n = lex_integer ();
 435           lex_get ();
 436         }
 437       else if (lex_match_id ("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 ('=');
 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 ('('))
 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 (')'))
 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 (token != T_ID)
 492                     {
 493                       lex_error (_("in CONTENTS subcommand"));
 494                       goto lossage;
 495                     }
 496
 497                   content_type = string_to_content_type (tokid,
 498                                                          &collide_index);
 499                   if (content_type == -1)
 500                     {
 501                       lex_error (_("in CONTENTS subcommand"));
 502                       goto lossage;
 503                     }
 504                   lex_get ();
 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 (token == '/' || token == '.')
 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 (NULL);
 533           goto lossage;
 534         }
 535     }
 536
 537   if (token != '.')
 538     {
 539       lex_error (_("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 = v->aux;
 608         int type = mv->var_type;
 609
 610         assert (type >= 0 && type < MXD_COUNT);
 611         v->print = v->write = 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);
 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 (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 = (*pa)->aux;
 701   const struct mxd_var *b = (*pb)->aux;
 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 (v->aux == 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         {
 868           struct data_in di;
 869
 870           di.s = ss_data (s);
 871           di.e = ss_end (s);
 872           di.v = (union value *) &token->number;
 873           di.f1 = dfm_get_column (reader, di.s);
 874           di.format = make_output_format (FMT_F, token->length, 0);
 875
 876           data_in (&di);
 877         }
 878       else
 879         token->type = MSTR;
 880     }
 881   token->string = ss_data (s);
 882   token->length = ss_length (s);
 883
 884   dfm_reread_record (reader, dfm_get_column (reader, ss_end (s)));
 885
 886   return 1;
 887 }
 888
 889 /* Forcibly skip the end of a line for content type CONTENT in
 890    READER. */
 891 static int
 892 force_eol (struct dfm_reader *reader, const char *content)
 893 {
 894   struct substring p;
 895
 896   if (dfm_eof (reader))
 897     return 0;
 898
 899   p = dfm_get_record (reader);
 900   if (ss_span (p, ss_cstr (CC_SPACES)) != ss_length (p))
 901     {
 902       msg (SE, _("End of line expected %s while reading %s."),
 903            context (reader), content);
 904       return 0;
 905     }
 906
 907   dfm_forward_record (reader);
 908   return 1;
 909 }
 910 \f
 911 /* Back end, omitting ROWTYPE_. */
 912
 913 struct nr_aux_data
 914   {
 915     const struct dictionary *dict; /* The dictionary */
 916     struct matrix_data_pgm *mx; /* MATRIX DATA program. */
 917     double ***data;             /* MATRIX DATA data. */
 918     double *factor_values;      /* Factor values. */
 919     int max_cell_idx;           /* Max-numbered cell that we have
 920                                    read so far, plus one. */
 921     double *split_values;       /* SPLIT FILE variable values. */
 922   };
 923
 924 static bool nr_read_splits (struct nr_aux_data *, int compare);
 925 static bool nr_read_factors (struct nr_aux_data *, int cell);
 926 static bool nr_output_data (struct nr_aux_data *, struct ccase *,
 927                             write_case_func *, write_case_data);
 928 static bool matrix_data_read_without_rowtype (struct case_source *source,
 929                                               struct ccase *,
 930                                               write_case_func *,
 931                                               write_case_data);
 932
 933 /* Read from the data file and write it to the active file.
 934    Returns true if successful, false if an I/O error occurred. */
 935 static bool
 936 read_matrices_without_rowtype (struct dataset *ds, struct matrix_data_pgm *mx)
 937 {
 938   struct nr_aux_data nr;
 939   bool ok;
 940
 941   if (mx->cells == -1)
 942     mx->cells = 1;
 943
 944   nr.mx = mx;
 945   nr.dict = dataset_dict (ds);
 946   nr.data = NULL;
 947   nr.factor_values = xnmalloc (mx->n_factors * mx->cells,
 948                                sizeof *nr.factor_values);
 949   nr.max_cell_idx = 0;
 950   nr.split_values = xnmalloc (dict_get_split_cnt (dataset_dict (ds)),
 951                               sizeof *nr.split_values);
 952
 953   proc_set_source (ds, create_case_source (
 954                      &matrix_data_without_rowtype_source_class, &nr));
 955
 956   ok = procedure (ds, NULL, NULL);
 957
 958   free (nr.split_values);
 959   free (nr.factor_values);
 960
 961   return ok;
 962 }
 963
 964 /* Mirror data across the diagonal of matrix CP which contains
 965    CONTENT type data. */
 966 static void
 967 fill_matrix (struct matrix_data_pgm *mx, int content, double *cp)
 968 {
 969   int type = content_type[content];
 970
 971   if (type == 1 && mx->section != FULL)
 972     {
 973       if (mx->diag == NODIAGONAL)
 974         {
 975           const double fill = content == CORR ? 1.0 : SYSMIS;
 976           int i;
 977
 978           for (i = 0; i < mx->n_continuous; i++)
 979             cp[i * (1 + mx->n_continuous)] = fill;
 980         }
 981
 982       {
 983         int c, r;
 984
 985         if (mx->section == LOWER)
 986           {
 987             int n_lines = mx->n_continuous;
 988             if (mx->section != FULL && mx->diag == NODIAGONAL)
 989               n_lines--;
 990
 991             for (r = 1; r < n_lines; r++)
 992               for (c = 0; c < r; c++)
 993                 cp[r + c * mx->n_continuous] = cp[c + r * mx->n_continuous];
 994           }
 995         else
 996           {
 997             assert (mx->section == UPPER);
 998             for (r = 1; r < mx->n_continuous; r++)
 999               for (c = 0; c < r; c++)
1000                 cp[c + r * mx->n_continuous] = cp[r + c * mx->n_continuous];
1001           }
1002       }
1003     }
1004   else if (type == 2)
1005     {
1006       int c;
1007
1008       for (c = 1; c < mx->n_continuous; c++)
1009         cp[c] = cp[0];
1010     }
1011 }
1012
1013 /* Read data lines for content type CONTENT from the data file.
1014    If PER_FACTOR is nonzero, then factor information is read from
1015    the data file.  Data is for cell number CELL. */
1016 static int
1017 nr_read_data_lines (struct nr_aux_data *nr,
1018                     int per_factor, int cell, int content, int compare)
1019 {
1020   struct matrix_data_pgm *mx = nr->mx;
1021   const int type = content_type[content];               /* Content type. */
1022   int n_lines; /* Number of lines to parse from data file for this type. */
1023   double *cp;                   /* Current position in vector or matrix. */
1024   int i;
1025
1026   if (type != 1)
1027     n_lines = 1;
1028   else
1029     {
1030       n_lines = mx->n_continuous;
1031       if (mx->section != FULL && mx->diag == NODIAGONAL)
1032         n_lines--;
1033     }
1034
1035   cp = nr->data[content][cell];
1036   if (type == 1 && mx->section == LOWER && mx->diag == NODIAGONAL)
1037     cp += mx->n_continuous;
1038
1039   for (i = 0; i < n_lines; i++)
1040     {
1041       int n_cols;
1042
1043       if (!nr_read_splits (nr, 1))
1044         return 0;
1045       if (per_factor && !nr_read_factors (nr, cell))
1046         return 0;
1047       compare = 1;
1048
1049       switch (type)
1050         {
1051         case 0:
1052           n_cols = mx->n_continuous;
1053           break;
1054         case 1:
1055           switch (mx->section)
1056             {
1057             case LOWER:
1058               n_cols = i + 1;
1059               break;
1060             case UPPER:
1061               cp += i;
1062               n_cols = mx->n_continuous - i;
1063               if (mx->diag == NODIAGONAL)
1064                 {
1065                   n_cols--;
1066                   cp++;
1067                 }
1068               break;
1069             case FULL:
1070               n_cols = mx->n_continuous;
1071               break;
1072             default:
1073               NOT_REACHED ();
1074             }
1075           break;
1076         case 2:
1077           n_cols = 1;
1078           break;
1079         default:
1080           NOT_REACHED ();
1081         }
1082
1083       {
1084         int j;
1085
1086         for (j = 0; j < n_cols; j++)
1087           {
1088             struct matrix_token token;
1089             if (!mget_token (&token, mx->reader))
1090               return 0;
1091             if (token.type != MNUM)
1092               {
1093                 msg (SE, _("expecting value for %s %s"),
1094                      dict_get_var (nr->dict, j)->name,
1095                      context (mx->reader));
1096                 return 0;
1097               }
1098
1099             *cp++ = token.number;
1100           }
1101         if (mx->fmt != FREE
1102             && !force_eol (mx->reader, content_names[content]))
1103           return 0;
1104       }
1105
1106       if (mx->section == LOWER)
1107         cp += mx->n_continuous - n_cols;
1108     }
1109
1110   fill_matrix (mx, content, nr->data[content][cell]);
1111
1112   return 1;
1113 }
1114
1115 /* When ROWTYPE_ does not appear in the data, reads the matrices and
1116    writes them to the output file.
1117    Returns true if successful, false if an I/O error occurred. */
1118 static bool
1119 matrix_data_read_without_rowtype (struct case_source *source,
1120                                   struct ccase *c,
1121                                   write_case_func *write_case,
1122                                   write_case_data wc_data)
1123 {
1124   struct nr_aux_data *nr = source->aux;
1125   struct matrix_data_pgm *mx = nr->mx;
1126
1127   {
1128     int *cp;
1129
1130     nr->data = pool_nalloc (mx->container, PROX + 1, sizeof *nr->data);
1131
1132     {
1133       int i;
1134
1135       for (i = 0; i <= PROX; i++)
1136         nr->data[i] = NULL;
1137     }
1138
1139     for (cp = mx->contents; *cp != EOC; cp++)
1140       if (*cp != LPAREN && *cp != RPAREN)
1141         {
1142           int per_factor = mx->is_per_factor[*cp];
1143           int n_entries;
1144
1145           n_entries = mx->n_continuous;
1146           if (content_type[*cp] == 1)
1147             n_entries *= mx->n_continuous;
1148
1149           {
1150             int n_vectors = per_factor ? mx->cells : 1;
1151             int i;
1152
1153             nr->data[*cp] = pool_nalloc (mx->container,
1154                                          n_vectors, sizeof **nr->data);
1155
1156             for (i = 0; i < n_vectors; i++)
1157               nr->data[*cp][i] = pool_nalloc (mx->container,
1158                                               n_entries, sizeof ***nr->data);
1159           }
1160         }
1161   }
1162
1163   for (;;)
1164     {
1165       int *bp, *ep, *np;
1166
1167       if (!nr_read_splits (nr, 0))
1168         return true;
1169
1170       for (bp = mx->contents; *bp != EOC; bp = np)
1171         {
1172           int per_factor;
1173
1174           /* Trap the CONTENTS that we should parse in this pass
1175              between bp and ep.  Set np to the starting bp for next
1176              iteration. */
1177           if (*bp == LPAREN)
1178             {
1179               ep = ++bp;
1180               while (*ep != RPAREN)
1181                 ep++;
1182               np = &ep[1];
1183               per_factor = 1;
1184             }
1185           else
1186             {
1187               ep = &bp[1];
1188               while (*ep != EOC && *ep != LPAREN)
1189                 ep++;
1190               np = ep;
1191               per_factor = 0;
1192             }
1193
1194           {
1195             int i;
1196
1197             for (i = 0; i < (per_factor ? mx->cells : 1); i++)
1198               {
1199                 int *cp;
1200
1201                 for (cp = bp; cp < ep; cp++)
1202                   if (!nr_read_data_lines (nr, per_factor, i, *cp, cp != bp))
1203                     return true;
1204               }
1205           }
1206         }
1207
1208       if (!nr_output_data (nr, c, write_case, wc_data))
1209         return false;
1210
1211       if (dict_get_split_cnt (nr->dict) == 0
1212           || !another_token (mx->reader))
1213         return true;
1214     }
1215 }
1216
1217 /* Read the split file variables.  If COMPARE is 1, compares the
1218    values read to the last values read and returns true if they're equal,
1219    false otherwise. */
1220 static bool
1221 nr_read_splits (struct nr_aux_data *nr, int compare)
1222 {
1223   struct matrix_data_pgm *mx = nr->mx;
1224   static int just_read = 0; /* FIXME: WTF? */
1225   size_t split_cnt;
1226   size_t i;
1227
1228   if (compare && just_read)
1229     {
1230       just_read = 0;
1231       return true;
1232     }
1233
1234   if (dict_get_split_vars (nr->dict) == NULL)
1235     return true;
1236
1237   if (mx->single_split)
1238     {
1239       if (!compare)
1240         {
1241           struct mxd_var *mv = dict_get_split_vars (nr->dict)[0]->aux;
1242           nr->split_values[0] = ++mv->sub_type;
1243         }
1244       return true;
1245     }
1246
1247   if (!compare)
1248     just_read = 1;
1249
1250   split_cnt = dict_get_split_cnt (nr->dict);
1251   for (i = 0; i < split_cnt; i++)
1252     {
1253       struct matrix_token token;
1254       if (!mget_token (&token, mx->reader))
1255         return false;
1256       if (token.type != MNUM)
1257         {
1258           msg (SE, _("Syntax error expecting SPLIT FILE value %s."),
1259                context (mx->reader));
1260           return false;
1261         }
1262
1263       if (!compare)
1264         nr->split_values[i] = token.number;
1265       else if (nr->split_values[i] != token.number)
1266         {
1267           msg (SE, _("Expecting value %g for %s."),
1268                nr->split_values[i],
1269                dict_get_split_vars (nr->dict)[i]->name);
1270           return false;
1271         }
1272     }
1273
1274   return true;
1275 }
1276
1277 /* Read the factors for cell CELL.  If COMPARE is 1, compares the
1278    values read to the last values read and returns true if they're equal,
1279    false otherwise. */
1280 static bool
1281 nr_read_factors (struct nr_aux_data *nr, int cell)
1282 {
1283   struct matrix_data_pgm *mx = nr->mx;
1284   bool compare;
1285
1286   if (mx->n_factors == 0)
1287     return true;
1288
1289   assert (nr->max_cell_idx >= cell);
1290   if (cell != nr->max_cell_idx)
1291     compare = true;
1292   else
1293     {
1294       compare = false;
1295       nr->max_cell_idx++;
1296     }
1297
1298   {
1299     size_t i;
1300
1301     for (i = 0; i < mx->n_factors; i++)
1302       {
1303         struct matrix_token token;
1304         if (!mget_token (&token, mx->reader))
1305           return false;
1306         if (token.type != MNUM)
1307           {
1308             msg (SE, _("Syntax error expecting factor value %s."),
1309                  context (mx->reader));
1310             return false;
1311           }
1312
1313         if (!compare)
1314           nr->factor_values[i + mx->n_factors * cell] = token.number;
1315         else if (nr->factor_values[i + mx->n_factors * cell] != token.number)
1316           {
1317             msg (SE, _("Syntax error expecting value %g for %s %s."),
1318                  nr->factor_values[i + mx->n_factors * cell],
1319                  mx->factors[i]->name, context (mx->reader));
1320             return false;
1321           }
1322       }
1323   }
1324
1325   return true;
1326 }
1327
1328 /* Write the contents of a cell having content type CONTENT and data
1329    CP to the active file.
1330    Returns true if successful, false if an I/O error occurred. */
1331 static bool
1332 dump_cell_content (const struct dictionary *dict,
1333                    struct matrix_data_pgm *mx, int content, double *cp,
1334                    struct ccase *c,
1335                    write_case_func *write_case, write_case_data wc_data)
1336 {
1337   int type = content_type[content];
1338
1339   {
1340     buf_copy_str_rpad (case_data_rw (c, mx->rowtype_->fv)->s, 8,
1341                        content_names[content]);
1342
1343     if (type != 1)
1344       memset (case_data_rw (c, mx->varname_->fv)->s, ' ', 8);
1345   }
1346
1347   {
1348     int n_lines = (type == 1) ? mx->n_continuous : 1;
1349     int i;
1350
1351     for (i = 0; i < n_lines; i++)
1352       {
1353         int j;
1354
1355         for (j = 0; j < mx->n_continuous; j++)
1356           {
1357             int fv = dict_get_var (dict, mx->first_continuous + j)->fv;
1358             case_data_rw (c, fv)->f = *cp;
1359             cp++;
1360           }
1361         if (type == 1)
1362           buf_copy_str_rpad (case_data_rw (c, mx->varname_->fv)->s, 8,
1363                              dict_get_var (dict,
1364                                            mx->first_continuous + i)->name);
1365         if (!write_case (wc_data))
1366           return false;
1367       }
1368   }
1369   return true;
1370 }
1371
1372 /* Finally dump out everything from nr_data[] to the output file. */
1373 static bool
1374 nr_output_data (struct nr_aux_data *nr, struct ccase *c,
1375                 write_case_func *write_case, write_case_data wc_data)
1376 {
1377   struct matrix_data_pgm *mx = nr->mx;
1378
1379   {
1380     struct variable *const *split;
1381     size_t split_cnt;
1382     size_t i;
1383
1384     split_cnt = dict_get_split_cnt (nr->dict);
1385     split = dict_get_split_vars (nr->dict);
1386     for (i = 0; i < split_cnt; i++)
1387       case_data_rw (c, split[i]->fv)->f = nr->split_values[i];
1388   }
1389
1390   if (mx->n_factors)
1391     {
1392       int cell;
1393
1394       for (cell = 0; cell < mx->cells; cell++)
1395         {
1396           {
1397             size_t factor;
1398
1399             for (factor = 0; factor < mx->n_factors; factor++)
1400               case_data_rw (c, mx->factors[factor]->fv)->f
1401                 = nr->factor_values[factor + cell * mx->n_factors];
1402           }
1403
1404           {
1405             int content;
1406
1407             for (content = 0; content <= PROX; content++)
1408               if (mx->is_per_factor[content])
1409                 {
1410                   assert (nr->data[content] != NULL
1411                           && nr->data[content][cell] != NULL);
1412
1413                   if (!dump_cell_content (nr->dict, mx,
1414                                           content, nr->data[content][cell],
1415                                           c, write_case, wc_data))
1416                     return false;
1417                 }
1418           }
1419         }
1420     }
1421
1422   {
1423     int content;
1424
1425     {
1426       size_t factor;
1427
1428       for (factor = 0; factor < mx->n_factors; factor++)
1429         case_data_rw (c, mx->factors[factor]->fv)->f = SYSMIS;
1430     }
1431
1432     for (content = 0; content <= PROX; content++)
1433       if (!mx->is_per_factor[content] && nr->data[content] != NULL)
1434         {
1435           if (!dump_cell_content (nr->dict, mx, content, nr->data[content][0],
1436                                   c, write_case, wc_data))
1437             return false;
1438         }
1439   }
1440
1441   return true;
1442 }
1443 \f
1444 /* Back end, with ROWTYPE_. */
1445
1446 /* All the data for one set of factor values. */
1447 struct factor_data
1448   {
1449     double *factors;
1450     int n_rows[PROX + 1];
1451     double *data[PROX + 1];
1452     struct factor_data *next;
1453   };
1454
1455 /* With ROWTYPE_ auxiliary data. */
1456 struct wr_aux_data
1457   {
1458     const struct dictionary *dict;            /* The dictionary */
1459     struct matrix_data_pgm *mx;         /* MATRIX DATA program. */
1460     int content;                        /* Type of current row. */
1461     double *split_values;               /* SPLIT FILE variable values. */
1462     struct factor_data *data;           /* All the data. */
1463     struct factor_data *current;        /* Current factor. */
1464   };
1465
1466 static bool wr_read_splits (struct wr_aux_data *, struct ccase *,
1467                            write_case_func *, write_case_data);
1468 static bool wr_output_data (struct wr_aux_data *, struct ccase *,
1469                            write_case_func *, write_case_data);
1470 static bool wr_read_rowtype (struct wr_aux_data *,
1471                             const struct matrix_token *, struct dfm_reader *);
1472 static bool wr_read_factors (struct wr_aux_data *);
1473 static bool wr_read_indeps (struct wr_aux_data *);
1474 static bool matrix_data_read_with_rowtype (struct case_source *,
1475                                            struct ccase *,
1476                                            write_case_func *,
1477                                            write_case_data);
1478
1479 /* When ROWTYPE_ appears in the data, reads the matrices and writes
1480    them to the output file.
1481    Returns true if successful, false if an I/O error occurred. */
1482 static bool
1483 read_matrices_with_rowtype (struct dataset *ds, struct matrix_data_pgm *mx)
1484 {
1485   struct wr_aux_data wr;
1486   bool ok;
1487
1488   wr.mx = mx;
1489   wr.content = -1;
1490   wr.split_values = NULL;
1491   wr.data = NULL;
1492   wr.current = NULL;
1493   wr.dict = dataset_dict (ds);
1494   mx->cells = 0;
1495
1496   proc_set_source (ds,
1497                    create_case_source (&matrix_data_with_rowtype_source_class,
1498                                        &wr));
1499   ok = procedure (ds, NULL, NULL);
1500
1501   free (wr.split_values);
1502   return ok;
1503 }
1504
1505 /* Read from the data file and write it to the active file.
1506    Returns true if successful, false if an I/O error occurred. */
1507 static bool
1508 matrix_data_read_with_rowtype (struct case_source *source,
1509                                struct ccase *c,
1510                                write_case_func *write_case,
1511                                write_case_data wc_data)
1512 {
1513   struct wr_aux_data *wr = source->aux;
1514   struct matrix_data_pgm *mx = wr->mx;
1515
1516   do
1517     {
1518       if (!wr_read_splits (wr, c, write_case, wc_data))
1519         return true;
1520
1521       if (!wr_read_factors (wr))
1522         return true;
1523
1524       if (!wr_read_indeps (wr))
1525         return true;
1526     }
1527   while (another_token (mx->reader));
1528
1529   return wr_output_data (wr, c, write_case, wc_data);
1530 }
1531
1532 /* Read the split file variables.  If they differ from the previous
1533    set of split variables then output the data.  Returns success. */
1534 static bool
1535 wr_read_splits (struct wr_aux_data *wr,
1536                 struct ccase *c,
1537                 write_case_func *write_case, write_case_data wc_data)
1538 {
1539   struct matrix_data_pgm *mx = wr->mx;
1540   bool compare;
1541   size_t split_cnt;
1542
1543   split_cnt = dict_get_split_cnt (wr->dict);
1544   if (split_cnt == 0)
1545     return true;
1546
1547   if (wr->split_values)
1548     compare = true;
1549   else
1550     {
1551       compare = false;
1552       wr->split_values = xnmalloc (split_cnt, sizeof *wr->split_values);
1553     }
1554
1555   {
1556     bool different = false;
1557     int i;
1558
1559     for (i = 0; i < split_cnt; i++)
1560       {
1561         struct matrix_token token;
1562         if (!mget_token (&token, mx->reader))
1563           return false;
1564         if (token.type != MNUM)
1565           {
1566             msg (SE, _("Syntax error %s expecting SPLIT FILE value."),
1567                  context (mx->reader));
1568             return false;
1569           }
1570
1571         if (compare && wr->split_values[i] != token.number && !different)
1572           {
1573             if (!wr_output_data (wr, c, write_case, wc_data))
1574               return 0;
1575             different = true;
1576             mx->cells = 0;
1577           }
1578         wr->split_values[i] = token.number;
1579       }
1580   }
1581
1582   return true;
1583 }
1584
1585 /* Compares doubles A and B, treating SYSMIS as greatest. */
1586 static int
1587 compare_doubles (const void *a_, const void *b_, const void *aux UNUSED)
1588 {
1589   const double *a = a_;
1590   const double *b = b_;
1591
1592   if (*a == *b)
1593     return 0;
1594   else if (*a == SYSMIS)
1595     return 1;
1596   else if (*b == SYSMIS)
1597     return -1;
1598   else if (*a > *b)
1599     return 1;
1600   else
1601     return -1;
1602 }
1603
1604 /* Return strcmp()-type comparison of the MX->n_factors factors at _A and
1605    _B.  Sort missing values toward the end. */
1606 static int
1607 compare_factors (const void *a_, const void *b_, const void *mx_)
1608 {
1609   const struct matrix_data_pgm *mx = mx_;
1610   struct factor_data *const *pa = a_;
1611   struct factor_data *const *pb = b_;
1612   const double *a = (*pa)->factors;
1613   const double *b = (*pb)->factors;
1614
1615   return lexicographical_compare_3way (a, mx->n_factors,
1616                                        b, mx->n_factors,
1617                                        sizeof *a,
1618                                        compare_doubles, NULL);
1619 }
1620
1621 /* Write out the data for the current split file to the active
1622    file.
1623    Returns true if successful, false if an I/O error occurred. */
1624 static bool
1625 wr_output_data (struct wr_aux_data *wr,
1626                 struct ccase *c,
1627                 write_case_func *write_case, write_case_data wc_data)
1628 {
1629   struct matrix_data_pgm *mx = wr->mx;
1630   bool ok = true;
1631
1632   {
1633     struct variable *const *split;
1634     size_t split_cnt;
1635     size_t i;
1636
1637     split_cnt = dict_get_split_cnt (wr->dict);
1638     split = dict_get_split_vars (wr->dict);
1639     for (i = 0; i < split_cnt; i++)
1640       case_data_rw (c, split[i]->fv)->f = wr->split_values[i];
1641   }
1642
1643   /* Sort the wr->data list. */
1644   {
1645     struct factor_data **factors;
1646     struct factor_data *iter;
1647     int i;
1648
1649     factors = xnmalloc (mx->cells, sizeof *factors);
1650
1651     for (i = 0, iter = wr->data; iter; iter = iter->next, i++)
1652       factors[i] = iter;
1653
1654     sort (factors, mx->cells, sizeof *factors, compare_factors, mx);
1655
1656     wr->data = factors[0];
1657     for (i = 0; i < mx->cells - 1; i++)
1658       factors[i]->next = factors[i + 1];
1659     factors[mx->cells - 1]->next = NULL;
1660
1661     free (factors);
1662   }
1663
1664   /* Write out records for every set of factor values. */
1665   {
1666     struct factor_data *iter;
1667
1668     for (iter = wr->data; iter; iter = iter->next)
1669       {
1670         {
1671           size_t factor;
1672
1673           for (factor = 0; factor < mx->n_factors; factor++)
1674             case_data_rw (c, mx->factors[factor]->fv)->f
1675               = iter->factors[factor];
1676         }
1677
1678         {
1679           int content;
1680
1681           for (content = 0; content <= PROX; content++)
1682             {
1683               if (!iter->n_rows[content])
1684                 continue;
1685
1686               {
1687                 int type = content_type[content];
1688                 int n_lines = (type == 1
1689                                ? (mx->n_continuous
1690                                   - (mx->section != FULL && mx->diag == NODIAGONAL))
1691                                : 1);
1692
1693                 if (n_lines != iter->n_rows[content])
1694                   {
1695                     msg (SE, _("Expected %d lines of data for %s content; "
1696                                "actually saw %d lines.  No data will be "
1697                                "output for this content."),
1698                          n_lines, content_names[content],
1699                          iter->n_rows[content]);
1700                     continue;
1701                   }
1702               }
1703
1704               fill_matrix (mx, content, iter->data[content]);
1705
1706               ok = dump_cell_content (wr->dict, mx, content,
1707                                       iter->data[content],
1708                                       c, write_case, wc_data);
1709               if (!ok)
1710                 break;
1711             }
1712         }
1713       }
1714   }
1715
1716   pool_destroy (mx->container);
1717   mx->container = pool_create ();
1718
1719   wr->data = wr->current = NULL;
1720
1721   return ok;
1722 }
1723
1724 /* Sets ROWTYPE_ based on the given TOKEN read from READER.
1725    Return success. */
1726 static bool
1727 wr_read_rowtype (struct wr_aux_data *wr,
1728                  const struct matrix_token *token,
1729                  struct dfm_reader *reader)
1730 {
1731   if (wr->content != -1)
1732     {
1733       msg (SE, _("Multiply specified ROWTYPE_ %s."), context (reader));
1734       return false;
1735     }
1736   if (token->type != MSTR)
1737     {
1738       msg (SE, _("Syntax error %s expecting ROWTYPE_ string."),
1739            context (reader));
1740       return false;
1741     }
1742
1743   {
1744     char s[16];
1745     char *cp;
1746
1747     memcpy (s, token->string, min (15, token->length));
1748     s[min (15, token->length)] = 0;
1749
1750     for (cp = s; *cp; cp++)
1751       *cp = toupper ((unsigned char) *cp);
1752
1753     wr->content = string_to_content_type (s, NULL);
1754   }
1755
1756   if (wr->content == -1)
1757     {
1758       msg (SE, _("Syntax error %s."), context (reader));
1759       return 0;
1760     }
1761
1762   return true;
1763 }
1764
1765 /* Read the factors for the current row.  Select a set of factors and
1766    point wr_current to it. */
1767 static bool
1768 wr_read_factors (struct wr_aux_data *wr)
1769 {
1770   struct matrix_data_pgm *mx = wr->mx;
1771   double *factor_values = local_alloc (sizeof *factor_values * mx->n_factors);
1772
1773   wr->content = -1;
1774   {
1775     size_t i;
1776
1777     for (i = 0; i < mx->n_factors; i++)
1778       {
1779         struct matrix_token token;
1780         if (!mget_token (&token, mx->reader))
1781           goto lossage;
1782         if (token.type == MSTR)
1783           {
1784             if (!wr_read_rowtype (wr, &token, mx->reader))
1785               goto lossage;
1786             if (!mget_token (&token, mx->reader))
1787               goto lossage;
1788           }
1789         if (token.type != MNUM)
1790           {
1791             msg (SE, _("Syntax error expecting factor value %s."),
1792                  context (mx->reader));
1793             goto lossage;
1794           }
1795
1796         factor_values[i] = token.number;
1797       }
1798   }
1799   if (wr->content == -1)
1800     {
1801       struct matrix_token token;
1802       if (!mget_token (&token, mx->reader))
1803         goto lossage;
1804       if (!wr_read_rowtype (wr, &token, mx->reader))
1805         goto lossage;
1806     }
1807
1808   /* Try the most recent factor first as a simple caching
1809      mechanism. */
1810   if (wr->current)
1811     {
1812       size_t i;
1813
1814       for (i = 0; i < mx->n_factors; i++)
1815         if (factor_values[i] != wr->current->factors[i])
1816           goto cache_miss;
1817       goto winnage;
1818     }
1819
1820   /* Linear search through the list. */
1821 cache_miss:
1822   {
1823     struct factor_data *iter;
1824
1825     for (iter = wr->data; iter; iter = iter->next)
1826       {
1827         size_t i;
1828
1829         for (i = 0; i < mx->n_factors; i++)
1830           if (factor_values[i] != iter->factors[i])
1831             goto next_item;
1832
1833         wr->current = iter;
1834         goto winnage;
1835
1836       next_item: ;
1837       }
1838   }
1839
1840   /* Not found.  Make a new item. */
1841   {
1842     struct factor_data *new = pool_alloc (mx->container, sizeof *new);
1843
1844     new->factors = pool_nalloc (mx->container,
1845                                 mx->n_factors, sizeof *new->factors);
1846
1847     {
1848       size_t i;
1849
1850       for (i = 0; i < mx->n_factors; i++)
1851         new->factors[i] = factor_values[i];
1852     }
1853
1854     {
1855       int i;
1856
1857       for (i = 0; i <= PROX; i++)
1858         {
1859           new->n_rows[i] = 0;
1860           new->data[i] = NULL;
1861         }
1862     }
1863
1864     new->next = wr->data;
1865     wr->data = wr->current = new;
1866     mx->cells++;
1867   }
1868
1869 winnage:
1870   local_free (factor_values);
1871   return true;
1872
1873 lossage:
1874   local_free (factor_values);
1875   return false;
1876 }
1877
1878 /* Read the independent variables into wr->current. */
1879 static bool
1880 wr_read_indeps (struct wr_aux_data *wr)
1881 {
1882   struct matrix_data_pgm *mx = wr->mx;
1883   struct factor_data *c = wr->current;
1884   const int type = content_type[wr->content];
1885   const int n_rows = c->n_rows[wr->content];
1886   double *cp;
1887   int n_cols;
1888
1889   /* Allocate room for data if necessary. */
1890   if (c->data[wr->content] == NULL)
1891     {
1892       int n_items = mx->n_continuous;
1893       if (type == 1)
1894         n_items *= mx->n_continuous;
1895
1896       c->data[wr->content] = pool_nalloc (mx->container,
1897                                           n_items, sizeof **c->data);
1898     }
1899
1900   cp = &c->data[wr->content][n_rows * mx->n_continuous];
1901
1902   /* Figure out how much to read from this line. */
1903   switch (type)
1904     {
1905     case 0:
1906     case 2:
1907       if (n_rows > 0)
1908         {
1909           msg (SE, _("Duplicate specification for %s."),
1910                content_names[wr->content]);
1911           return false;
1912         }
1913       if (type == 0)
1914         n_cols = mx->n_continuous;
1915       else
1916         n_cols = 1;
1917       break;
1918     case 1:
1919       if (n_rows >= mx->n_continuous - (mx->section != FULL && mx->diag == NODIAGONAL))
1920         {
1921           msg (SE, _("Too many rows of matrix data for %s."),
1922                content_names[wr->content]);
1923           return false;
1924         }
1925
1926       switch (mx->section)
1927         {
1928         case LOWER:
1929           n_cols = n_rows + 1;
1930           if (mx->diag == NODIAGONAL)
1931             cp += mx->n_continuous;
1932           break;
1933         case UPPER:
1934           cp += n_rows;
1935           n_cols = mx->n_continuous - n_rows;
1936           if (mx->diag == NODIAGONAL)
1937             {
1938               n_cols--;
1939               cp++;
1940             }
1941           break;
1942         case FULL:
1943           n_cols = mx->n_continuous;
1944           break;
1945         default:
1946           NOT_REACHED ();
1947         }
1948       break;
1949     default:
1950       NOT_REACHED ();
1951     }
1952   c->n_rows[wr->content]++;
1953
1954   /* Read N_COLS items at CP. */
1955   {
1956     int j;
1957
1958     for (j = 0; j < n_cols; j++)
1959       {
1960         struct matrix_token token;
1961         if (!mget_token (&token, mx->reader))
1962           return false;
1963         if (token.type != MNUM)
1964           {
1965             msg (SE, _("Syntax error expecting value for %s %s."),
1966                  dict_get_var (wr->dict, mx->first_continuous + j)->name,
1967                  context (mx->reader));
1968             return false;
1969           }
1970
1971         *cp++ = token.number;
1972       }
1973     if (mx->fmt != FREE
1974         && !force_eol (mx->reader, content_names[wr->content]))
1975       return false;
1976   }
1977
1978   return true;
1979 }
1980 \f
1981 /* Matrix source. */
1982
1983 static const struct case_source_class matrix_data_with_rowtype_source_class =
1984   {
1985     "MATRIX DATA",
1986     NULL,
1987     matrix_data_read_with_rowtype,
1988     NULL,
1989   };
1990
1991 static const struct case_source_class
1992 matrix_data_without_rowtype_source_class =
1993   {
1994     "MATRIX DATA",
1995     NULL,
1996     matrix_data_read_without_rowtype,
1997     NULL,
1998   };
1999