Fix assertion for proper Huffman merge pattern: 0 == 1 modulo 1.
[pspp] / 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., 59 Temple Place - Suite 330, Boston, MA
18    02111-1307, 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_integer_p () || 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_integer_p () || 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 len_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 len_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 len_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 len_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,
967                                    default_dict, &nr);
968   
969   procedure (NULL, NULL);
970
971   free (nr.split_values);
972   free (nr.factor_values);
973 }
974
975 /* Mirror data across the diagonal of matrix CP which contains
976    CONTENT type data. */
977 static void
978 fill_matrix (struct matrix_data_pgm *mx, int content, double *cp)
979 {
980   int type = content_type[content];
981
982   if (type == 1 && mx->section != FULL)
983     {
984       if (mx->diag == NODIAGONAL)
985         {
986           const double fill = content == CORR ? 1.0 : SYSMIS;
987           int i;
988
989           for (i = 0; i < mx->n_continuous; i++)
990             cp[i * (1 + mx->n_continuous)] = fill;
991         }
992       
993       {
994         int c, r;
995         
996         if (mx->section == LOWER)
997           {
998             int n_lines = mx->n_continuous;
999             if (mx->section != FULL && mx->diag == NODIAGONAL)
1000               n_lines--;
1001             
1002             for (r = 1; r < n_lines; r++)
1003               for (c = 0; c < r; c++)
1004                 cp[r + c * mx->n_continuous] = cp[c + r * mx->n_continuous];
1005           }
1006         else 
1007           {
1008             assert (mx->section == UPPER);
1009             for (r = 1; r < mx->n_continuous; r++)
1010               for (c = 0; c < r; c++)
1011                 cp[c + r * mx->n_continuous] = cp[r + c * mx->n_continuous];
1012           }
1013       }
1014     }
1015   else if (type == 2)
1016     {
1017       int c;
1018
1019       for (c = 1; c < mx->n_continuous; c++)
1020         cp[c] = cp[0];
1021     }
1022 }
1023
1024 /* Read data lines for content type CONTENT from the data file.
1025    If PER_FACTOR is nonzero, then factor information is read from
1026    the data file.  Data is for cell number CELL. */
1027 static int
1028 nr_read_data_lines (struct nr_aux_data *nr,
1029                     int per_factor, int cell, int content, int compare)
1030 {
1031   struct matrix_data_pgm *mx = nr->mx;
1032   const int type = content_type[content];               /* Content type. */
1033   int n_lines; /* Number of lines to parse from data file for this type. */
1034   double *cp;                   /* Current position in vector or matrix. */
1035   int i;
1036
1037   if (type != 1)
1038     n_lines = 1;
1039   else
1040     {
1041       n_lines = mx->n_continuous;
1042       if (mx->section != FULL && mx->diag == NODIAGONAL)
1043         n_lines--;
1044     }
1045
1046   cp = nr->data[content][cell];
1047   if (type == 1 && mx->section == LOWER && mx->diag == NODIAGONAL)
1048     cp += mx->n_continuous;
1049
1050   for (i = 0; i < n_lines; i++)
1051     {
1052       int n_cols;
1053       
1054       if (!nr_read_splits (nr, 1))
1055         return 0;
1056       if (per_factor && !nr_read_factors (nr, cell))
1057         return 0;
1058       compare = 1;
1059
1060       switch (type)
1061         {
1062         case 0:
1063           n_cols = mx->n_continuous;
1064           break;
1065         case 1:
1066           switch (mx->section)
1067             {
1068             case LOWER:
1069               n_cols = i + 1;
1070               break;
1071             case UPPER:
1072               cp += i;
1073               n_cols = mx->n_continuous - i;
1074               if (mx->diag == NODIAGONAL)
1075                 {
1076                   n_cols--;
1077                   cp++;
1078                 }
1079               break;
1080             case FULL:
1081               n_cols = mx->n_continuous;
1082               break;
1083             default:
1084               assert (0);
1085               abort ();
1086             }
1087           break;
1088         case 2:
1089           n_cols = 1;
1090           break;
1091         default:
1092           assert (0);
1093           abort ();
1094         }
1095
1096       {
1097         int j;
1098         
1099         for (j = 0; j < n_cols; j++)
1100           {
1101             struct matrix_token token;
1102             if (!mget_token (&token, mx->reader))
1103               return 0;
1104             if (token.type != MNUM)
1105               {
1106                 msg (SE, _("expecting value for %s %s"),
1107                      dict_get_var (default_dict, j)->name,
1108                      context (mx->reader));
1109                 return 0;
1110               }
1111
1112             *cp++ = token.number;
1113           }
1114         if (mx->fmt != FREE
1115             && !force_eol (mx->reader, content_names[content]))
1116           return 0;
1117         debug_printf (("\n"));
1118       }
1119
1120       if (mx->section == LOWER)
1121         cp += mx->n_continuous - n_cols;
1122     }
1123
1124   fill_matrix (mx, content, nr->data[content][cell]);
1125
1126   return 1;
1127 }
1128
1129 /* When ROWTYPE_ does not appear in the data, reads the matrices and
1130    writes them to the output file.  Returns success. */
1131 static void
1132 matrix_data_read_without_rowtype (struct case_source *source,
1133                                   struct ccase *c,
1134                                   write_case_func *write_case,
1135                                   write_case_data wc_data)
1136 {
1137   struct nr_aux_data *nr = source->aux;
1138   struct matrix_data_pgm *mx = nr->mx;
1139
1140   {
1141     int *cp;
1142
1143     nr->data = pool_alloc (mx->container, (PROX + 1) * sizeof *nr->data);
1144     
1145     {
1146       int i;
1147
1148       for (i = 0; i <= PROX; i++)
1149         nr->data[i] = NULL;
1150     }
1151     
1152     for (cp = mx->contents; *cp != EOC; cp++)
1153       if (*cp != LPAREN && *cp != RPAREN)
1154         {
1155           int per_factor = mx->is_per_factor[*cp];
1156           int n_entries;
1157           
1158           n_entries = mx->n_continuous;
1159           if (content_type[*cp] == 1)
1160             n_entries *= mx->n_continuous;
1161           
1162           {
1163             int n_vectors = per_factor ? mx->cells : 1;
1164             int i;
1165             
1166             nr->data[*cp] = pool_alloc (mx->container,
1167                                        n_vectors * sizeof **nr->data);
1168             
1169             for (i = 0; i < n_vectors; i++)
1170               nr->data[*cp][i] = pool_alloc (mx->container,
1171                                             n_entries * sizeof ***nr->data);
1172           }
1173         }
1174   }
1175   
1176   for (;;)
1177     {
1178       int *bp, *ep, *np;
1179       
1180       if (!nr_read_splits (nr, 0))
1181         return;
1182       
1183       for (bp = mx->contents; *bp != EOC; bp = np)
1184         {
1185           int per_factor;
1186
1187           /* Trap the CONTENTS that we should parse in this pass
1188              between bp and ep.  Set np to the starting bp for next
1189              iteration. */
1190           if (*bp == LPAREN)
1191             {
1192               ep = ++bp;
1193               while (*ep != RPAREN)
1194                 ep++;
1195               np = &ep[1];
1196               per_factor = 1;
1197             }
1198           else
1199             {
1200               ep = &bp[1];
1201               while (*ep != EOC && *ep != LPAREN)
1202                 ep++;
1203               np = ep;
1204               per_factor = 0;
1205             }
1206           
1207           {
1208             int i;
1209               
1210             for (i = 0; i < (per_factor ? mx->cells : 1); i++)
1211               {
1212                 int *cp;
1213
1214                 for (cp = bp; cp < ep; cp++) 
1215                   if (!nr_read_data_lines (nr, per_factor, i, *cp, cp != bp))
1216                     return;
1217               }
1218           }
1219         }
1220
1221       nr_output_data (nr, c, write_case, wc_data);
1222
1223       if (dict_get_split_cnt (default_dict) == 0
1224           || !another_token (mx->reader))
1225         return;
1226     }
1227 }
1228
1229 /* Read the split file variables.  If COMPARE is 1, compares the
1230    values read to the last values read and returns 1 if they're equal,
1231    0 otherwise. */
1232 static int
1233 nr_read_splits (struct nr_aux_data *nr, int compare)
1234 {
1235   struct matrix_data_pgm *mx = nr->mx;
1236   static int just_read = 0; /* FIXME: WTF? */
1237   size_t split_cnt;
1238   size_t i;
1239
1240   if (compare && just_read)
1241     {
1242       just_read = 0;
1243       return 1;
1244     }
1245   
1246   if (dict_get_split_vars (default_dict) == NULL)
1247     return 1;
1248
1249   if (mx->single_split)
1250     {
1251       if (!compare) 
1252         {
1253           struct mxd_var *mv = dict_get_split_vars (default_dict)[0]->aux;
1254           nr->split_values[0] = ++mv->sub_type; 
1255         }
1256       return 1;
1257     }
1258
1259   if (!compare)
1260     just_read = 1;
1261
1262   split_cnt = dict_get_split_cnt (default_dict);
1263   for (i = 0; i < split_cnt; i++) 
1264     {
1265       struct matrix_token token;
1266       if (!mget_token (&token, mx->reader))
1267         return 0;
1268       if (token.type != MNUM)
1269         {
1270           msg (SE, _("Syntax error expecting SPLIT FILE value %s."),
1271                context (mx->reader));
1272           return 0;
1273         }
1274
1275       if (!compare)
1276         nr->split_values[i] = token.number;
1277       else if (nr->split_values[i] != token.number)
1278         {
1279           msg (SE, _("Expecting value %g for %s."),
1280                nr->split_values[i],
1281                dict_get_split_vars (default_dict)[i]->name);
1282           return 0;
1283         }
1284     }
1285
1286   return 1;
1287 }
1288
1289 /* Read the factors for cell CELL.  If COMPARE is 1, compares the
1290    values read to the last values read and returns 1 if they're equal,
1291    0 otherwise. */
1292 static int
1293 nr_read_factors (struct nr_aux_data *nr, int cell)
1294 {
1295   struct matrix_data_pgm *mx = nr->mx;
1296   int compare;
1297   
1298   if (mx->n_factors == 0)
1299     return 1;
1300
1301   assert (nr->max_cell_idx >= cell);
1302   if (cell != nr->max_cell_idx)
1303     compare = 1;
1304   else
1305     {
1306       compare = 0;
1307       nr->max_cell_idx++;
1308     }
1309       
1310   {
1311     int i;
1312     
1313     for (i = 0; i < mx->n_factors; i++)
1314       {
1315         struct matrix_token token;
1316         if (!mget_token (&token, mx->reader))
1317           return 0;
1318         if (token.type != MNUM)
1319           {
1320             msg (SE, _("Syntax error expecting factor value %s."),
1321                  context (mx->reader));
1322             return 0;
1323           }
1324         
1325         if (!compare)
1326           nr->factor_values[i + mx->n_factors * cell] = token.number;
1327         else if (nr->factor_values[i + mx->n_factors * cell] != token.number)
1328           {
1329             msg (SE, _("Syntax error expecting value %g for %s %s."),
1330                  nr->factor_values[i + mx->n_factors * cell],
1331                  mx->factors[i]->name, context (mx->reader));
1332             return 0;
1333           }
1334       }
1335   }
1336
1337   return 1;
1338 }
1339
1340 /* Write the contents of a cell having content type CONTENT and data
1341    CP to the active file. */
1342 static void
1343 dump_cell_content (struct matrix_data_pgm *mx, int content, double *cp,
1344                    struct ccase *c,
1345                    write_case_func *write_case, write_case_data wc_data)
1346 {
1347   int type = content_type[content];
1348
1349   {
1350     st_bare_pad_copy (case_data_rw (c, mx->rowtype_->fv)->s,
1351                       content_names[content], 8);
1352     
1353     if (type != 1)
1354       memset (case_data_rw (c, mx->varname_->fv)->s, ' ', 8);
1355   }
1356
1357   {
1358     int n_lines = (type == 1) ? mx->n_continuous : 1;
1359     int i;
1360                 
1361     for (i = 0; i < n_lines; i++)
1362       {
1363         int j;
1364
1365         for (j = 0; j < mx->n_continuous; j++)
1366           {
1367             int fv = dict_get_var (default_dict, mx->first_continuous + j)->fv;
1368             case_data_rw (c, fv)->f = *cp;
1369             cp++;
1370           }
1371         if (type == 1)
1372           st_bare_pad_copy (case_data_rw (c, mx->varname_->fv)->s,
1373                             dict_get_var (default_dict,
1374                                           mx->first_continuous + i)->name,
1375                             8);
1376         write_case (wc_data);
1377       }
1378   }
1379 }
1380
1381 /* Finally dump out everything from nr_data[] to the output file. */
1382 static void
1383 nr_output_data (struct nr_aux_data *nr, struct ccase *c,
1384                 write_case_func *write_case, write_case_data wc_data)
1385 {
1386   struct matrix_data_pgm *mx = nr->mx;
1387   
1388   {
1389     struct variable *const *split;
1390     size_t split_cnt;
1391     size_t i;
1392
1393     split_cnt = dict_get_split_cnt (default_dict);
1394     split = dict_get_split_vars (default_dict);
1395     for (i = 0; i < split_cnt; i++)
1396       case_data_rw (c, split[i]->fv)->f = nr->split_values[i];
1397   }
1398
1399   if (mx->n_factors)
1400     {
1401       int cell;
1402
1403       for (cell = 0; cell < mx->cells; cell++)
1404         {
1405           {
1406             int factor;
1407
1408             for (factor = 0; factor < mx->n_factors; factor++)
1409               {
1410                 case_data_rw (c, mx->factors[factor]->fv)->f
1411                   = nr->factor_values[factor + cell * mx->n_factors];
1412                 debug_printf (("f:%s ", mx->factors[factor]->name));
1413               }
1414           }
1415           
1416           {
1417             int content;
1418             
1419             for (content = 0; content <= PROX; content++)
1420               if (mx->is_per_factor[content])
1421                 {
1422                   assert (nr->data[content] != NULL
1423                           && nr->data[content][cell] != NULL);
1424
1425                   dump_cell_content (mx, content, nr->data[content][cell],
1426                                      c, write_case, wc_data);
1427                 }
1428           }
1429         }
1430     }
1431
1432   {
1433     int content;
1434     
1435     {
1436       int factor;
1437
1438       for (factor = 0; factor < mx->n_factors; factor++)
1439         case_data_rw (c, mx->factors[factor]->fv)->f = SYSMIS;
1440     }
1441     
1442     for (content = 0; content <= PROX; content++)
1443       if (!mx->is_per_factor[content] && nr->data[content] != NULL)
1444         dump_cell_content (mx, content, nr->data[content][0],
1445                            c, write_case, wc_data);
1446   }
1447 }
1448 \f
1449 /* Back end, with ROWTYPE_. */
1450
1451 /* All the data for one set of factor values. */
1452 struct factor_data
1453   {
1454     double *factors;
1455     int n_rows[PROX + 1];
1456     double *data[PROX + 1];
1457     struct factor_data *next;
1458   };
1459
1460 /* With ROWTYPE_ auxiliary data. */
1461 struct wr_aux_data 
1462   {
1463     struct matrix_data_pgm *mx;         /* MATRIX DATA program. */
1464     int content;                        /* Type of current row. */
1465     double *split_values;               /* SPLIT FILE variable values. */
1466     struct factor_data *data;           /* All the data. */
1467     struct factor_data *current;        /* Current factor. */
1468   };
1469
1470 static int wr_read_splits (struct wr_aux_data *, struct ccase *,
1471                            write_case_func *, write_case_data);
1472 static int wr_output_data (struct wr_aux_data *, struct ccase *,
1473                            write_case_func *, write_case_data);
1474 static int wr_read_rowtype (struct wr_aux_data *, 
1475                             const struct matrix_token *, struct dfm_reader *);
1476 static int wr_read_factors (struct wr_aux_data *);
1477 static int wr_read_indeps (struct wr_aux_data *);
1478 static void matrix_data_read_with_rowtype (struct case_source *,
1479                                            struct ccase *,
1480                                            write_case_func *,
1481                                            write_case_data);
1482
1483 /* When ROWTYPE_ appears in the data, reads the matrices and writes
1484    them to the output file. */
1485 static void
1486 read_matrices_with_rowtype (struct matrix_data_pgm *mx)
1487 {
1488   struct wr_aux_data wr;
1489
1490   wr.mx = mx;
1491   wr.content = -1;
1492   wr.split_values = NULL;
1493   wr.data = NULL;
1494   wr.current = NULL;
1495   mx->cells = 0;
1496
1497   vfm_source = create_case_source (&matrix_data_with_rowtype_source_class,
1498                                    default_dict, &wr);
1499   procedure (NULL, NULL);
1500
1501   free (wr.split_values);
1502 }
1503
1504 /* Read from the data file and write it to the active file. */
1505 static void
1506 matrix_data_read_with_rowtype (struct case_source *source,
1507                                struct ccase *c,
1508                                write_case_func *write_case,
1509                                write_case_data wc_data)
1510 {
1511   struct wr_aux_data *wr = source->aux;
1512   struct matrix_data_pgm *mx = wr->mx;
1513
1514   do
1515     {
1516       if (!wr_read_splits (wr, c, write_case, wc_data))
1517         return;
1518
1519       if (!wr_read_factors (wr))
1520         return;
1521
1522       if (!wr_read_indeps (wr))
1523         return;
1524     }
1525   while (another_token (mx->reader));
1526
1527   wr_output_data (wr, c, write_case, wc_data);
1528 }
1529
1530 /* Read the split file variables.  If they differ from the previous
1531    set of split variables then output the data.  Returns success. */
1532 static int 
1533 wr_read_splits (struct wr_aux_data *wr,
1534                 struct ccase *c,
1535                 write_case_func *write_case, write_case_data wc_data)
1536 {
1537   struct matrix_data_pgm *mx = wr->mx;
1538   int compare;
1539   size_t split_cnt;
1540
1541   split_cnt = dict_get_split_cnt (default_dict);
1542   if (split_cnt == 0)
1543     return 1;
1544
1545   if (wr->split_values)
1546     compare = 1;
1547   else
1548     {
1549       compare = 0;
1550       wr->split_values = xmalloc (split_cnt * sizeof *wr->split_values);
1551     }
1552   
1553   {
1554     int different = 0;
1555     int i;
1556
1557     for (i = 0; i < split_cnt; i++)
1558       {
1559         struct matrix_token token;
1560         if (!mget_token (&token, mx->reader))
1561           return 0;
1562         if (token.type != MNUM)
1563           {
1564             msg (SE, _("Syntax error %s expecting SPLIT FILE value."),
1565                  context (mx->reader));
1566             return 0;
1567           }
1568
1569         if (compare && wr->split_values[i] != token.number && !different)
1570           {
1571             if (!wr_output_data (wr, c, write_case, wc_data))
1572               return 0;
1573             different = 1;
1574             mx->cells = 0;
1575           }
1576         wr->split_values[i] = token.number;
1577       }
1578   }
1579
1580   return 1;
1581 }
1582
1583 /* Compares doubles A and B, treating SYSMIS as greatest. */
1584 static int
1585 compare_doubles (const void *a_, const void *b_, void *aux UNUSED)
1586 {
1587   const double *a = a_;
1588   const double *b = b_;
1589
1590   if (*a == *b)
1591     return 0;
1592   else if (*a == SYSMIS)
1593     return 1;
1594   else if (*b == SYSMIS)
1595     return -1;
1596   else if (*a > *b)
1597     return 1;
1598   else
1599     return -1;
1600 }
1601
1602 /* Return strcmp()-type comparison of the MX->n_factors factors at _A and
1603    _B.  Sort missing values toward the end. */
1604 static int
1605 compare_factors (const void *a_, const void *b_, void *mx_)
1606 {
1607   struct matrix_data_pgm *mx = mx_;
1608   struct factor_data *const *pa = a_;
1609   struct factor_data *const *pb = b_;
1610   const double *a = (*pa)->factors;
1611   const double *b = (*pb)->factors;
1612
1613   return lexicographical_compare_3way (a, mx->n_factors,
1614                                        b, mx->n_factors,
1615                                        sizeof *a,
1616                                        compare_doubles, NULL);
1617 }
1618
1619 /* Write out the data for the current split file to the active
1620    file. */
1621 static int 
1622 wr_output_data (struct wr_aux_data *wr,
1623                 struct ccase *c,
1624                 write_case_func *write_case, write_case_data wc_data)
1625 {
1626   struct matrix_data_pgm *mx = wr->mx;
1627
1628   {
1629     struct variable *const *split;
1630     size_t split_cnt;
1631     size_t i;
1632
1633     split_cnt = dict_get_split_cnt (default_dict);
1634     split = dict_get_split_vars (default_dict);
1635     for (i = 0; i < split_cnt; i++)
1636       case_data_rw (c, split[i]->fv)->f = wr->split_values[i];
1637   }
1638
1639   /* Sort the wr->data list. */
1640   {
1641     struct factor_data **factors;
1642     struct factor_data *iter;
1643     int i;
1644
1645     factors = xmalloc (sizeof *factors * mx->cells);
1646
1647     for (i = 0, iter = wr->data; iter; iter = iter->next, i++)
1648       factors[i] = iter;
1649
1650     sort (factors, mx->cells, sizeof *factors, compare_factors, mx);
1651
1652     wr->data = factors[0];
1653     for (i = 0; i < mx->cells - 1; i++)
1654       factors[i]->next = factors[i + 1];
1655     factors[mx->cells - 1]->next = NULL;
1656
1657     free (factors);
1658   }
1659
1660   /* Write out records for every set of factor values. */
1661   {
1662     struct factor_data *iter;
1663     
1664     for (iter = wr->data; iter; iter = iter->next)
1665       {
1666         {
1667           int factor;
1668
1669           for (factor = 0; factor < mx->n_factors; factor++)
1670             {
1671               case_data_rw (c, mx->factors[factor]->fv)->f
1672                 = iter->factors[factor];
1673               debug_printf (("f:%s ", factors[factor]->name));
1674             }
1675         }
1676         
1677         {
1678           int content;
1679
1680           for (content = 0; content <= PROX; content++)
1681             {
1682               if (!iter->n_rows[content])
1683                 continue;
1684               
1685               {
1686                 int type = content_type[content];
1687                 int n_lines = (type == 1
1688                                ? (mx->n_continuous
1689                                   - (mx->section != FULL && mx->diag == NODIAGONAL))
1690                                : 1);
1691                 
1692                 if (n_lines != iter->n_rows[content])
1693                   {
1694                     msg (SE, _("Expected %d lines of data for %s content; "
1695                                "actually saw %d lines.  No data will be "
1696                                "output for this content."),
1697                          n_lines, content_names[content],
1698                          iter->n_rows[content]);
1699                     continue;
1700                   }
1701               }
1702
1703               fill_matrix (mx, content, iter->data[content]);
1704
1705               dump_cell_content (mx, content, iter->data[content],
1706                                  c, write_case, wc_data);
1707             }
1708         }
1709       }
1710   }
1711   
1712   pool_destroy (mx->container);
1713   mx->container = pool_create ();
1714   
1715   wr->data = wr->current = NULL;
1716   
1717   return 1;
1718 }
1719
1720 /* Sets ROWTYPE_ based on the given TOKEN read from READER.
1721    Return success. */
1722 static int 
1723 wr_read_rowtype (struct wr_aux_data *wr,
1724                  const struct matrix_token *token,
1725                  struct dfm_reader *reader)
1726 {
1727   if (wr->content != -1)
1728     {
1729       msg (SE, _("Multiply specified ROWTYPE_ %s."), context (reader));
1730       return 0;
1731     }
1732   if (token->type != MSTR)
1733     {
1734       msg (SE, _("Syntax error %s expecting ROWTYPE_ string."),
1735            context (reader));
1736       return 0;
1737     }
1738   
1739   {
1740     char s[16];
1741     char *cp;
1742     
1743     memcpy (s, token->string, min (15, token->length));
1744     s[min (15, token->length)] = 0;
1745
1746     for (cp = s; *cp; cp++)
1747       *cp = toupper ((unsigned char) *cp);
1748
1749     wr->content = string_to_content_type (s, NULL);
1750   }
1751
1752   if (wr->content == -1)
1753     {
1754       msg (SE, _("Syntax error %s."), context (reader));
1755       return 0;
1756     }
1757
1758   return 1;
1759 }
1760
1761 /* Read the factors for the current row.  Select a set of factors and
1762    point wr_current to it. */
1763 static int 
1764 wr_read_factors (struct wr_aux_data *wr)
1765 {
1766   struct matrix_data_pgm *mx = wr->mx;
1767   double *factor_values = local_alloc (sizeof *factor_values * mx->n_factors);
1768
1769   wr->content = -1;
1770   {
1771     int i;
1772   
1773     for (i = 0; i < mx->n_factors; i++)
1774       {
1775         struct matrix_token token;
1776         if (!mget_token (&token, mx->reader))
1777           goto lossage;
1778         if (token.type == MSTR)
1779           {
1780             if (!wr_read_rowtype (wr, &token, mx->reader))
1781               goto lossage;
1782             if (!mget_token (&token, mx->reader))
1783               goto lossage;
1784           }
1785         if (token.type != MNUM)
1786           {
1787             msg (SE, _("Syntax error expecting factor value %s."),
1788                  context (mx->reader));
1789             goto lossage;
1790           }
1791         
1792         factor_values[i] = token.number;
1793       }
1794   }
1795   if (wr->content == -1)
1796     {
1797       struct matrix_token token;
1798       if (!mget_token (&token, mx->reader))
1799         goto lossage;
1800       if (!wr_read_rowtype (wr, &token, mx->reader))
1801         goto lossage;
1802     }
1803   
1804   /* Try the most recent factor first as a simple caching
1805      mechanism. */
1806   if (wr->current)
1807     {
1808       int i;
1809       
1810       for (i = 0; i < mx->n_factors; i++)
1811         if (factor_values[i] != wr->current->factors[i])
1812           goto cache_miss;
1813       goto winnage;
1814     }
1815
1816   /* Linear search through the list. */
1817 cache_miss:
1818   {
1819     struct factor_data *iter;
1820
1821     for (iter = wr->data; iter; iter = iter->next)
1822       {
1823         int i;
1824
1825         for (i = 0; i < mx->n_factors; i++)
1826           if (factor_values[i] != iter->factors[i])
1827             goto next_item;
1828         
1829         wr->current = iter;
1830         goto winnage;
1831         
1832       next_item: ;
1833       }
1834   }
1835
1836   /* Not found.  Make a new item. */
1837   {
1838     struct factor_data *new = pool_alloc (mx->container, sizeof *new);
1839
1840     new->factors = pool_alloc (mx->container, sizeof *new->factors * mx->n_factors);
1841     
1842     {
1843       int i;
1844
1845       for (i = 0; i < mx->n_factors; i++)
1846         new->factors[i] = factor_values[i];
1847     }
1848     
1849     {
1850       int i;
1851
1852       for (i = 0; i <= PROX; i++)
1853         {
1854           new->n_rows[i] = 0;
1855           new->data[i] = NULL;
1856         }
1857     }
1858
1859     new->next = wr->data;
1860     wr->data = wr->current = new;
1861     mx->cells++;
1862   }
1863
1864 winnage:
1865   local_free (factor_values);
1866   return 1;
1867
1868 lossage:
1869   local_free (factor_values);
1870   return 0;
1871 }
1872
1873 /* Read the independent variables into wr->current. */
1874 static int 
1875 wr_read_indeps (struct wr_aux_data *wr)
1876 {
1877   struct matrix_data_pgm *mx = wr->mx;
1878   struct factor_data *c = wr->current;
1879   const int type = content_type[wr->content];
1880   const int n_rows = c->n_rows[wr->content];
1881   double *cp;
1882   int n_cols;
1883
1884   /* Allocate room for data if necessary. */
1885   if (c->data[wr->content] == NULL)
1886     {
1887       int n_items = mx->n_continuous;
1888       if (type == 1)
1889         n_items *= mx->n_continuous;
1890       
1891       c->data[wr->content] = pool_alloc (mx->container,
1892                                         sizeof **c->data * n_items);
1893     }
1894
1895   cp = &c->data[wr->content][n_rows * mx->n_continuous];
1896
1897   /* Figure out how much to read from this line. */
1898   switch (type)
1899     {
1900     case 0:
1901     case 2:
1902       if (n_rows > 0)
1903         {
1904           msg (SE, _("Duplicate specification for %s."),
1905                content_names[wr->content]);
1906           return 0;
1907         }
1908       if (type == 0)
1909         n_cols = mx->n_continuous;
1910       else
1911         n_cols = 1;
1912       break;
1913     case 1:
1914       if (n_rows >= mx->n_continuous - (mx->section != FULL && mx->diag == NODIAGONAL))
1915         {
1916           msg (SE, _("Too many rows of matrix data for %s."),
1917                content_names[wr->content]);
1918           return 0;
1919         }
1920       
1921       switch (mx->section)
1922         {
1923         case LOWER:
1924           n_cols = n_rows + 1;
1925           if (mx->diag == NODIAGONAL)
1926             cp += mx->n_continuous;
1927           break;
1928         case UPPER:
1929           cp += n_rows;
1930           n_cols = mx->n_continuous - n_rows;
1931           if (mx->diag == NODIAGONAL)
1932             {
1933               n_cols--;
1934               cp++;
1935             }
1936           break;
1937         case FULL:
1938           n_cols = mx->n_continuous;
1939           break;
1940         default:
1941           assert (0);
1942           abort ();
1943         }
1944       break;
1945     default:
1946       assert (0);
1947       abort ();
1948     }
1949   c->n_rows[wr->content]++;
1950
1951   debug_printf ((" (c=%p,r=%d,n=%d)", c, n_rows + 1, n_cols));
1952
1953   /* Read N_COLS items at CP. */
1954   {
1955     int j;
1956         
1957     for (j = 0; j < n_cols; j++)
1958       {
1959         struct matrix_token token;
1960         if (!mget_token (&token, mx->reader))
1961           return 0;
1962         if (token.type != MNUM)
1963           {
1964             msg (SE, _("Syntax error expecting value for %s %s."),
1965                  dict_get_var (default_dict, mx->first_continuous + j)->name,
1966                  context (mx->reader));
1967             return 0;
1968           }
1969
1970         *cp++ = token.number;
1971       }
1972     if (mx->fmt != FREE
1973         && !force_eol (mx->reader, content_names[wr->content]))
1974       return 0;
1975     debug_printf (("\n"));
1976   }
1977
1978   return 1;
1979 }
1980 \f
1981 /* Matrix source. */
1982
1983 static const struct case_source_class matrix_data_with_rowtype_source_class = 
1984   {
1985     "MATRIX DATA",
1986     NULL,
1987     matrix_data_read_with_rowtype,
1988     NULL,
1989   };
1990
1991 static const struct case_source_class 
1992 matrix_data_without_rowtype_source_class =
1993   {
1994     "MATRIX DATA",
1995     NULL,
1996     matrix_data_read_without_rowtype,
1997     NULL,
1998   };
1999