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