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