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