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