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

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