pintos-os.org Git - pspp/blob - src/language/stats/matrix.c

   1 /* PSPP - a program for statistical analysis.
   2    Copyright (C) 2021 Free Software Foundation, Inc.
   3
   4    This program is free software: you can redistribute it and/or modify
   5    it under the terms of the GNU General Public License as published by
   6    the Free Software Foundation, either version 3 of the License, or
   7    (at your option) any later version.
   8
   9    This program is distributed in the hope that it will be useful,
  10    but WITHOUT ANY WARRANTY; without even the implied warranty of
  11    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12    GNU General Public License for more details.
  13
  14    You should have received a copy of the GNU General Public License
  15    along with this program.  If not, see <http://www.gnu.org/licenses/>. */
  16
  17 #include <config.h>
  18
  19 #include <gsl/gsl_blas.h>
  20 #include <gsl/gsl_cdf.h>
  21 #include <gsl/gsl_eigen.h>
  22 #include <gsl/gsl_linalg.h>
  23 #include <gsl/gsl_matrix.h>
  24 #include <gsl/gsl_permutation.h>
  25 #include <gsl/gsl_randist.h>
  26 #include <gsl/gsl_vector.h>
  27 #include <limits.h>
  28 #include <math.h>
  29 #include <uniwidth.h>
  30
  31 #include "data/any-reader.h"
  32 #include "data/any-writer.h"
  33 #include "data/casereader.h"
  34 #include "data/casewriter.h"
  35 #include "data/data-in.h"
  36 #include "data/data-out.h"
  37 #include "data/dataset.h"
  38 #include "data/dictionary.h"
  39 #include "data/file-handle-def.h"
  40 #include "language/command.h"
  41 #include "language/data-io/data-reader.h"
  42 #include "language/data-io/data-writer.h"
  43 #include "language/data-io/file-handle.h"
  44 #include "language/lexer/format-parser.h"
  45 #include "language/lexer/lexer.h"
  46 #include "language/lexer/variable-parser.h"
  47 #include "libpspp/array.h"
  48 #include "libpspp/assertion.h"
  49 #include "libpspp/compiler.h"
  50 #include "libpspp/hmap.h"
  51 #include "libpspp/i18n.h"
  52 #include "libpspp/intern.h"
  53 #include "libpspp/misc.h"
  54 #include "libpspp/str.h"
  55 #include "libpspp/string-array.h"
  56 #include "libpspp/stringi-set.h"
  57 #include "libpspp/u8-line.h"
  58 #include "math/distributions.h"
  59 #include "math/random.h"
  60 #include "output/driver.h"
  61 #include "output/output-item.h"
  62 #include "output/pivot-table.h"
  63
  64 #include "gl/c-ctype.h"
  65 #include "gl/c-strcase.h"
  66 #include "gl/ftoastr.h"
  67 #include "gl/minmax.h"
  68 #include "gl/xsize.h"
  69
  70 #include "gettext.h"
  71 #define _(msgid) gettext (msgid)
  72 #define N_(msgid) (msgid)
  73
  74 struct matrix_var
  75   {
  76     struct hmap_node hmap_node;
  77     char *name;
  78     gsl_matrix *value;
  79   };
  80
  81 struct msave_common
  82   {
  83     /* Configuration. */
  84     struct file_handle *outfile;
  85     struct string_array variables;
  86     struct string_array fnames;
  87     struct string_array snames;
  88     size_t n_varnames;
  89
  90     /* Collects and owns factors and splits.  The individual msave_command
  91        structs point to these but do not own them. */
  92     struct matrix_expr **factors;
  93     size_t n_factors, allocated_factors;
  94     struct matrix_expr **splits;
  95     size_t n_splits, allocated_splits;
  96
  97     /* Execution state. */
  98     struct dictionary *dict;
  99     struct casewriter *writer;
 100   };
 101
 102 struct read_file
 103   {
 104     struct file_handle *file;
 105     struct dfm_reader *reader;
 106     char *encoding;
 107   };
 108
 109 struct write_file
 110   {
 111     struct file_handle *file;
 112     struct dfm_writer *writer;
 113     char *encoding;
 114     struct u8_line *held;
 115   };
 116
 117 struct save_file
 118   {
 119     struct file_handle *file;
 120     struct dataset *dataset;
 121
 122     /* Parameters from parsing the first SAVE command for 'file'. */
 123     struct string_array variables;
 124     struct matrix_expr *names;
 125     struct stringi_set strings;
 126
 127     /* Results from the first (only) attempt to open this save_file. */
 128     bool error;
 129     struct casewriter *writer;
 130     struct dictionary *dict;
 131   };
 132
 133 struct matrix_state
 134   {
 135     struct dataset *dataset;
 136     struct session *session;
 137     struct lexer *lexer;
 138     struct hmap vars;
 139     bool in_loop;
 140     struct msave_common *common;
 141
 142     struct file_handle *prev_read_file;
 143     struct read_file **read_files;
 144     size_t n_read_files;
 145
 146     struct file_handle *prev_write_file;
 147     struct write_file **write_files;
 148     size_t n_write_files;
 149
 150     struct file_handle *prev_save_file;
 151     struct save_file **save_files;
 152     size_t n_save_files;
 153   };
 154
 155 static struct matrix_var *
 156 matrix_var_lookup (struct matrix_state *s, struct substring name)
 157 {
 158   struct matrix_var *var;
 159
 160   HMAP_FOR_EACH_WITH_HASH (var, struct matrix_var, hmap_node,
 161                            utf8_hash_case_substring (name, 0), &s->vars)
 162     if (!utf8_sscasecmp (ss_cstr (var->name), name))
 163       return var;
 164
 165   return NULL;
 166 }
 167
 168 static struct matrix_var *
 169 matrix_var_create (struct matrix_state *s, struct substring name)
 170 {
 171   struct matrix_var *var = xmalloc (sizeof *var);
 172   *var = (struct matrix_var) { .name = ss_xstrdup (name) };
 173   hmap_insert (&s->vars, &var->hmap_node, utf8_hash_case_substring (name, 0));
 174   return var;
 175 }
 176
 177 static void
 178 matrix_var_set (struct matrix_var *var, gsl_matrix *value)
 179 {
 180   gsl_matrix_free (var->value);
 181   var->value = value;
 182 }
 183 \f
 184 /* The third argument to F() is a "prototype".  For most prototypes, the first
 185    letter (before the _) represents the return type and each other letter
 186    (after the _) is an argument type.  The types are:
 187
 188      - "m": A matrix of unrestricted dimensions.
 189
 190      - "d": A scalar.
 191
 192      - "v": A row or column vector.
 193
 194      - "e": Primarily for the first argument, this is a matrix with
 195        unrestricted dimensions treated elementwise.  Each element in the matrix
 196        is passed to the implementation function separately.
 197
 198    The fourth argument is an optional constraints string.  For this purpose the
 199    first argument is named "a", the second "b", and so on.  The following kinds
 200    of constraints are supported.  For matrix arguments, the constraints are
 201    applied to each value in the matrix separately:
 202
 203      - "a(0,1)" or "a[0,1]": 0 < a < 1 or 0 <= a <= 1, respectively.  Any
 204        integer may substitute for 0 and 1.  Half-open constraints (] and [) are
 205        also supported.
 206
 207      - "ai": Restrict a to integer values.
 208
 209      - "a>0", "a<0", "a>=0", "a<=0", "a!=0".
 210
 211      - "a<b", "a>b", "a<=b", "a>=b", "b!=0".
 212 */
 213 #define MATRIX_FUNCTIONS                                                \
 214     F(ABS,      "ABS",      m_e, NULL)                                  \
 215     F(ALL,      "ALL",      d_m, NULL)                                  \
 216     F(ANY,      "ANY",      d_m, NULL)                                  \
 217     F(ARSIN,    "ARSIN",    m_e, "a[-1,1]")                             \
 218     F(ARTAN,    "ARTAN",    m_e, NULL)                                  \
 219     F(BLOCK,    "BLOCK",    m_any, NULL)                                \
 220     F(CHOL,     "CHOL",     m_me, NULL)                                 \
 221     F(CMIN,     "CMIN",     m_m, NULL)                                  \
 222     F(CMAX,     "CMAX",     m_m, NULL)                                  \
 223     F(COS,      "COS",      m_e, NULL)                                  \
 224     F(CSSQ,     "CSSQ",     m_m, NULL)                                  \
 225     F(CSUM,     "CSUM",     m_m, NULL)                                  \
 226     F(DESIGN,   "DESIGN",   m_m, NULL)                                  \
 227     F(DET,      "DET",      d_m, NULL)                                  \
 228     F(DIAG,     "DIAG",     m_m, NULL)                                  \
 229     F(EVAL,     "EVAL",     m_m, NULL)                                  \
 230     F(EXP,      "EXP",      m_e, NULL)                                  \
 231     F(GINV,     "GINV",     m_m, NULL)                                  \
 232     F(GRADE,    "GRADE",    m_m, NULL)                                  \
 233     F(GSCH,     "GSCH",     m_m, NULL)                                  \
 234     F(IDENT,    "IDENT",    IDENT, "ai>=0 bi>=0")                       \
 235     F(INV,      "INV",      m_m, NULL)                                  \
 236     F(KRONEKER, "KRONEKER", m_mm, NULL)                                 \
 237     F(LG10,     "LG10",     m_e, "a>0")                                 \
 238     F(LN,       "LN",       m_e, "a>0")                                 \
 239     F(MAGIC,    "MAGIC",    m_d, "ai>=3")                               \
 240     F(MAKE,     "MAKE",     m_ddd, "ai>=0 bi>=0")                       \
 241     F(MDIAG,    "MDIAG",    m_v, NULL)                                  \
 242     F(MMAX,     "MMAX",     d_m, NULL)                                  \
 243     F(MMIN,     "MMIN",     d_m, NULL)                                  \
 244     F(MOD,      "MOD",      m_md, "b!=0")                               \
 245     F(MSSQ,     "MSSQ",     d_m, NULL)                                  \
 246     F(MSUM,     "MSUM",     d_m, NULL)                                  \
 247     F(NCOL,     "NCOL",     d_m, NULL)                                  \
 248     F(NROW,     "NROW",     d_m, NULL)                                  \
 249     F(RANK,     "RANK",     d_m, NULL)                                  \
 250     F(RESHAPE,  "RESHAPE",  m_mdd, NULL)                                \
 251     F(RMAX,     "RMAX",     m_m, NULL)                                  \
 252     F(RMIN,     "RMIN",     m_m, NULL)                                  \
 253     F(RND,      "RND",      m_e, NULL)                                  \
 254     F(RNKORDER, "RNKORDER", m_m, NULL)                                  \
 255     F(RSSQ,     "RSSQ",     m_m, NULL)                                  \
 256     F(RSUM,     "RSUM",     m_m, NULL)                                  \
 257     F(SIN,      "SIN",      m_e, NULL)                                  \
 258     F(SOLVE,    "SOLVE",    m_mm, NULL)                                 \
 259     F(SQRT,     "SQRT",     m_e, "a>=0")                                \
 260     F(SSCP,     "SSCP",     m_m, NULL)                                  \
 261     F(SVAL,     "SVAL",     m_m, NULL)                                  \
 262     F(SWEEP,    "SWEEP",    m_md, NULL)                                 \
 263     F(T,        "T",        m_m, NULL)                                  \
 264     F(TRACE,    "TRACE",    d_m, NULL)                                  \
 265     F(TRANSPOS, "TRANSPOS", m_m, NULL)                                  \
 266     F(TRUNC,    "TRUNC",    m_e, NULL)                                  \
 267     F(UNIFORM,  "UNIFORM",  m_dd, "ai>=0 bi>=0")                        \
 268     F(PDF_BETA, "PDF.BETA", m_edd, "a[0,1] b>0 c>0")                    \
 269     F(CDF_BETA, "CDF.BETA", m_edd, "a[0,1] b>0 c>0")                    \
 270     F(IDF_BETA, "IDF.BETA", m_edd, "a[0,1] b>0 c>0")                    \
 271     F(RV_BETA,  "RV.BETA",  d_dd, "a>0 b>0")                            \
 272     F(NCDF_BETA, "NCDF.BETA", m_eddd, "a>=0 b>0 c>0 d>0")               \
 273     F(NPDF_BETA, "NCDF.BETA", m_eddd, "a>=0 b>0 c>0 d>0")               \
 274     F(CDF_BVNOR, "CDF.BVNOR", m_eed, "c[-1,1]")                         \
 275     F(PDF_BVNOR, "PDF.BVNOR", m_eed, "c[-1,1]")                         \
 276     F(CDF_CAUCHY, "CDF.CAUCHY", m_edd, "c>0")                           \
 277     F(IDF_CAUCHY, "IDF.CAUCHY", m_edd, "a(0,1) c>0")                    \
 278     F(PDF_CAUCHY, "PDF.CAUCHY", m_edd, "c>0")                           \
 279     F(RV_CAUCHY, "RV.CAUCHY", d_dd, "b>0")                              \
 280     F(CDF_CHISQ, "CDF.CHISQ", m_ed, "a>=0 b>0")                         \
 281     F(CHICDF, "CHICDF", m_ed, "a>=0 b>0")                               \
 282     F(IDF_CHISQ, "IDF.CHISQ", m_ed, "a[0,1) b>0")                       \
 283     F(PDF_CHISQ, "PDF.CHISQ", m_ed, "a>=0 b>0")                         \
 284     F(RV_CHISQ, "RV.CHISQ", d_d, "a>0")                                 \
 285     F(SIG_CHISQ, "SIG.CHISQ", m_ed, "a>=0 b>0")                         \
 286     F(CDF_EXP, "CDF.EXP", m_ed, "a>=0 b>=0")                            \
 287     F(IDF_EXP, "IDF.EXP", m_ed, "a[0,1) b>0")                           \
 288     F(PDF_EXP, "PDF.EXP", m_ed, "a>=0 b>0")                             \
 289     F(RV_EXP, "RV.EXP", d_d, "a>0")                                     \
 290     F(PDF_XPOWER, "PDF.XPOWER", m_edd, "b>0 c>=0")                      \
 291     F(RV_XPOWER, "RV.XPOWER", d_dd, "a>0 c>=0")                         \
 292     F(CDF_F, "CDF.F", m_edd, "a>=0 b>0 c>0")                            \
 293     F(FCDF, "FCDF", m_edd, "a>=0 b>0 c>0")                              \
 294     F(IDF_F, "IDF.F", m_edd, "a[0,1) b>0 c>0")                          \
 295     F(PDF_F, "PDF.F", m_edd, "a>=0 b>0 c>0")                            \
 296     F(RV_F, "RV.F", d_dd, "a>0 b>0")                                    \
 297     F(SIG_F, "SIG.F", m_edd, "a>=0 b>0 c>0")                            \
 298     F(CDF_GAMMA, "CDF.GAMMA", m_edd, "a>=0 b>0 c>0")                    \
 299     F(IDF_GAMMA, "IDF.GAMMA", m_edd, "a[0,1] b>0 c>0")                  \
 300     F(PDF_GAMMA, "PDF.GAMMA", m_edd, "a>=0 b>0 c>0")                    \
 301     F(RV_GAMMA, "RV.GAMMA", d_dd, "a>0 b>0")                            \
 302     F(PDF_LANDAU, "PDF.LANDAU", m_e, NULL)                              \
 303     F(RV_LANDAU, "RV.LANDAU", d_none, NULL)                             \
 304     F(CDF_LAPLACE, "CDF.LAPLACE", m_edd, "c>0")                         \
 305     F(IDF_LAPLACE, "IDF.LAPLACE", m_edd, "a(0,1) c>0")                  \
 306     F(PDF_LAPLACE, "PDF.LAPLACE", m_edd, "c>0")                         \
 307     F(RV_LAPLACE, "RV.LAPLACE", d_dd, "b>0")                            \
 308     F(RV_LEVY, "RV.LEVY", d_dd, "b(0,2]")                               \
 309     F(RV_LVSKEW, "RV.LVSKEW", d_ddd, "b(0,2] c[-1,1]")                  \
 310     F(CDF_LOGISTIC, "CDF.LOGISTIC", m_edd, "c>0")                       \
 311     F(IDF_LOGISTIC, "IDF.LOGISTIC", m_edd, "a(0,1) c>0")                \
 312     F(PDF_LOGISTIC, "PDF.LOGISTIC", m_edd, "c>0")                       \
 313     F(RV_LOGISTIC, "RV.LOGISTIC", d_dd, "b>0")                          \
 314     F(CDF_LNORMAL, "CDF.LNORMAL", m_edd, "a>=0 b>0 c>0")                \
 315     F(IDF_LNORMAL, "IDF.LNORMAL", m_edd, "a[0,1) b>0 c>0")              \
 316     F(PDF_LNORMAL, "PDF.LNORMAL", m_edd, "a>=0 b>0 c>0")                \
 317     F(RV_LNORMAL, "RV.LNORMAL", d_dd, "a>0 b>0")                        \
 318     F(CDF_NORMAL, "CDF.NORMAL", m_edd, "c>0")                           \
 319     F(IDF_NORMAL, "IDF.NORMAL", m_edd, "a(0,1) c>0")                    \
 320     F(PDF_NORMAL, "PDF.NORMAL", m_edd, "c>0")                           \
 321     F(RV_NORMAL, "RV.NORMAL", d_dd, "b>0")                              \
 322     F(CDFNORM, "CDFNORM", m_e, NULL)                                    \
 323     F(PROBIT, "PROBIT", m_e, "a(0,1)")                                  \
 324     F(NORMAL, "NORMAL", m_e, "a>0")                                     \
 325     F(PDF_NTAIL, "PDF.NTAIL", m_edd, "b>0 c>0")                         \
 326     F(RV_NTAIL, "RV.NTAIL", d_dd, "a>0 b>0")                            \
 327     F(CDF_PARETO, "CDF.PARETO", m_edd, "a>=b b>0 c>0")                  \
 328     F(IDF_PARETO, "IDF.PARETO", m_edd, "a[0,1) b>0 c>0")                \
 329     F(PDF_PARETO, "PDF.PARETO", m_edd, "a>=b b>0 c>0")                  \
 330     F(RV_PARETO, "RV.PARETO", d_dd, "a>0 b>0")                          \
 331     F(CDF_RAYLEIGH, "CDF.RAYLEIGH", m_ed, "b>0")                        \
 332     F(IDF_RAYLEIGH, "IDF.RAYLEIGH", m_ed, "a[0,1] b>0")                 \
 333     F(PDF_RAYLEIGH, "PDF.RAYLEIGH", m_ed, "b>0")                        \
 334     F(RV_RAYLEIGH, "RV.RAYLEIGH", d_d, "a>0")                           \
 335     F(PDF_RTAIL, "PDF.RTAIL", m_edd, NULL)                              \
 336     F(RV_RTAIL, "RV.RTAIL", d_dd, NULL)                                 \
 337     F(CDF_T, "CDF.T", m_ed, "b>0")                                      \
 338     F(TCDF, "TCDF", m_ed, "b>0")                                        \
 339     F(IDF_T, "IDF.T", m_ed, "a(0,1) b>0")                               \
 340     F(PDF_T, "PDF.T", m_ed, "b>0")                                      \
 341     F(RV_T, "RV.T", d_d, "a>0")                                         \
 342     F(CDF_T1G, "CDF.T1G", m_edd, NULL)                                  \
 343     F(IDF_T1G, "IDF.T1G", m_edd, "a(0,1)")                              \
 344     F(PDF_T1G, "PDF.T1G", m_edd, NULL)                                  \
 345     F(RV_T1G, "RV.T1G", d_dd, NULL)                                     \
 346     F(CDF_T2G, "CDF.T2G", m_edd, NULL)                                  \
 347     F(IDF_T2G, "IDF.T2G", m_edd, "a(0,1)")                              \
 348     F(PDF_T2G, "PDF.T2G", m_edd, NULL)                                  \
 349     F(RV_T2G, "RV.T2G", d_dd, NULL)                                     \
 350     F(CDF_UNIFORM, "CDF.UNIFORM", m_edd, "a<=c b<=c")                   \
 351     F(IDF_UNIFORM, "IDF.UNIFORM", m_edd, "a[0,1] b<=c")                 \
 352     F(PDF_UNIFORM, "PDF.UNIFORM", m_edd, "a<=c b<=c")                   \
 353     F(RV_UNIFORM, "RV.UNIFORM", d_dd, "a<=b")                           \
 354     F(CDF_WEIBULL, "CDF.WEIBULL", m_edd, "a>=0 b>0 c>0")                \
 355     F(IDF_WEIBULL, "IDF.WEIBULL", m_edd, "a[0,1) b>0 c>0")              \
 356     F(PDF_WEIBULL, "PDF.WEIBULL", m_edd, "a>=0 b>0 c>0")                \
 357     F(RV_WEIBULL, "RV.WEIBULL", d_dd, "a>0 b>0")                        \
 358     F(CDF_BERNOULLI, "CDF.BERNOULLI", m_ed, "ai[0,1] b[0,1]")           \
 359     F(PDF_BERNOULLI, "PDF.BERNOULLI", m_ed, "ai[0,1] b[0,1]")           \
 360     F(RV_BERNOULLI, "RV.BERNOULLI", d_d, "a[0,1]")                      \
 361     F(CDF_BINOM, "CDF.BINOM", m_edd, "bi>0 c[0,1]")                     \
 362     F(PDF_BINOM, "PDF.BINOM", m_edd, "ai>=0<=b bi>0 c[0,1]")            \
 363     F(RV_BINOM, "RV.BINOM", d_dd, "ai>0 b[0,1]")                        \
 364     F(CDF_GEOM, "CDF.GEOM", m_ed, "ai>=1 b[0,1]")                       \
 365     F(PDF_GEOM, "PDF.GEOM", m_ed, "ai>=1 b[0,1]")                       \
 366     F(RV_GEOM, "RV.GEOM", d_d, "a[0,1]")                                \
 367     F(CDF_HYPER, "CDF.HYPER", m_eddd, "ai>=0<=d bi>0 ci>0<=b di>0<=b")  \
 368     F(PDF_HYPER, "PDF.HYPER", m_eddd, "ai>=0<=d bi>0 ci>0<=b di>0<=b")  \
 369     F(RV_HYPER, "RV.HYPER", d_ddd, "ai>0 bi>0<=a ci>0<=a")              \
 370     F(PDF_LOG, "PDF.LOG", m_ed, "a>=1 b(0,1]")                          \
 371     F(RV_LOG, "RV.LOG", d_d, "a(0,1]")                                  \
 372     F(CDF_NEGBIN, "CDF.NEGBIN", m_edd, "a>=1 bi c(0,1]")                \
 373     F(PDF_NEGBIN, "PDF.NEGBIN", m_edd, "a>=1 bi c(0,1]")                \
 374     F(RV_NEGBIN, "RV.NEGBIN", d_dd, "ai b(0,1]")                        \
 375     F(CDF_POISSON, "CDF.POISSON", m_ed, "ai>=0 b>0")                    \
 376     F(PDF_POISSON, "PDF.POISSON", m_ed, "ai>=0 b>0")                    \
 377     F(RV_POISSON, "RV.POISSON", d_d, "a>0")
 378
 379 struct matrix_function_properties
 380   {
 381     const char *name;
 382     const char *constraints;
 383   };
 384
 385 enum { d_none_MIN_ARGS = 0, d_none_MAX_ARGS = 0 };
 386 enum { d_d_MIN_ARGS = 1, d_d_MAX_ARGS = 1 };
 387 enum { d_dd_MIN_ARGS = 2, d_dd_MAX_ARGS = 2 };
 388 enum { d_ddd_MIN_ARGS = 3, d_ddd_MAX_ARGS = 3 };
 389 enum { m_d_MIN_ARGS = 1, m_d_MAX_ARGS = 1 };
 390 enum { m_dd_MIN_ARGS = 2, m_dd_MAX_ARGS = 2 };
 391 enum { m_ddd_MIN_ARGS = 3, m_ddd_MAX_ARGS = 3 };
 392 enum { m_m_MIN_ARGS = 1, m_m_MAX_ARGS = 1 };
 393 enum { m_me_MIN_ARGS = 1, m_me_MAX_ARGS = 1 };
 394 enum { m_e_MIN_ARGS = 1, m_e_MAX_ARGS = 1 };
 395 enum { m_md_MIN_ARGS = 2, m_md_MAX_ARGS = 2 };
 396 enum { m_ed_MIN_ARGS = 2, m_ed_MAX_ARGS = 2 };
 397 enum { m_mdd_MIN_ARGS = 3, m_mdd_MAX_ARGS = 3 };
 398 enum { m_edd_MIN_ARGS = 3, m_edd_MAX_ARGS = 3 };
 399 enum { m_eddd_MIN_ARGS = 4, m_eddd_MAX_ARGS = 4 };
 400 enum { m_eed_MIN_ARGS = 3, m_eed_MAX_ARGS = 3 };
 401 enum { m_mm_MIN_ARGS = 2, m_mm_MAX_ARGS = 2 };
 402 enum { m_v_MIN_ARGS = 1, m_v_MAX_ARGS = 1 };
 403 enum { d_m_MIN_ARGS = 1, d_m_MAX_ARGS = 1 };
 404 enum { m_any_MIN_ARGS = 1, m_any_MAX_ARGS = INT_MAX };
 405 enum { IDENT_MIN_ARGS = 1, IDENT_MAX_ARGS = 2 };
 406
 407 typedef double matrix_proto_d_none (void);
 408 typedef double matrix_proto_d_d (double);
 409 typedef double matrix_proto_d_dd (double, double);
 410 typedef double matrix_proto_d_dd (double, double);
 411 typedef double matrix_proto_d_ddd (double, double, double);
 412 typedef gsl_matrix *matrix_proto_m_d (double);
 413 typedef gsl_matrix *matrix_proto_m_dd (double, double);
 414 typedef gsl_matrix *matrix_proto_m_ddd (double, double, double);
 415 typedef gsl_matrix *matrix_proto_m_m (gsl_matrix *);
 416 typedef gsl_matrix *matrix_proto_m_me (gsl_matrix *, const struct matrix_expr *);
 417 typedef double matrix_proto_m_e (double);
 418 typedef gsl_matrix *matrix_proto_m_md (gsl_matrix *, double);
 419 typedef double matrix_proto_m_ed (double, double);
 420 typedef gsl_matrix *matrix_proto_m_mdd (gsl_matrix *, double, double);
 421 typedef double matrix_proto_m_edd (double, double, double);
 422 typedef double matrix_proto_m_eddd (double, double, double, double);
 423 typedef double matrix_proto_m_eed (double, double, double);
 424 typedef gsl_matrix *matrix_proto_m_mm (gsl_matrix *, gsl_matrix *);
 425 typedef gsl_matrix *matrix_proto_m_v (gsl_vector *);
 426 typedef double matrix_proto_d_m (gsl_matrix *);
 427 typedef gsl_matrix *matrix_proto_m_any (gsl_matrix *[], size_t n);
 428 typedef gsl_matrix *matrix_proto_IDENT (double, double);
 429
 430 #define F(ENUM, STRING, PROTO, CONSTRAINTS) \
 431     static matrix_proto_##PROTO matrix_eval_##ENUM;
 432 MATRIX_FUNCTIONS
 433 #undef F
 434 \f
 435 /* Matrix expressions. */
 436
 437 struct matrix_expr
 438   {
 439     enum matrix_op
 440       {
 441         /* Functions. */
 442 #define F(ENUM, STRING, PROTO, CONSTRAINTS) MOP_F_##ENUM,
 443         MATRIX_FUNCTIONS
 444 #undef F
 445
 446         /* Elementwise and scalar arithmetic. */
 447         MOP_NEGATE,             /* unary - */
 448         MOP_ADD_ELEMS,          /* + */
 449         MOP_SUB_ELEMS,          /* - */
 450         MOP_MUL_ELEMS,          /* &* */
 451         MOP_DIV_ELEMS,          /* / and &/ */
 452         MOP_EXP_ELEMS,          /* &** */
 453         MOP_SEQ,                /* a:b */
 454         MOP_SEQ_BY,             /* a:b:c */
 455
 456         /* Matrix arithmetic. */
 457         MOP_MUL_MAT,            /* * */
 458         MOP_EXP_MAT,            /* ** */
 459
 460         /* Relational. */
 461         MOP_GT,                 /* > */
 462         MOP_GE,                 /* >= */
 463         MOP_LT,                 /* < */
 464         MOP_LE,                 /* <= */
 465         MOP_EQ,                 /* = */
 466         MOP_NE,                 /* <> */
 467
 468         /* Logical. */
 469         MOP_NOT,                /* NOT */
 470         MOP_AND,                /* AND */
 471         MOP_OR,                 /* OR */
 472         MOP_XOR,                /* XOR */
 473
 474         /* {}. */
 475         MOP_PASTE_HORZ,         /* a, b, c, ... */
 476         MOP_PASTE_VERT,         /* a; b; c; ... */
 477         MOP_EMPTY,              /* {} */
 478
 479         /* Sub-matrices. */
 480         MOP_VEC_INDEX,          /* x(y) */
 481         MOP_VEC_ALL,            /* x(:) */
 482         MOP_MAT_INDEX,          /* x(y,z) */
 483         MOP_ROW_INDEX,          /* x(y,:) */
 484         MOP_COL_INDEX,          /* x(:,z) */
 485
 486         /* Literals. */
 487         MOP_NUMBER,
 488         MOP_VARIABLE,
 489
 490         /* Oddball stuff. */
 491         MOP_EOF,                /* EOF('file') */
 492       }
 493     op;
 494
 495     union
 496       {
 497         struct
 498           {
 499             struct matrix_expr **subs;
 500             size_t n_subs;
 501           };
 502
 503         double number;
 504         struct matrix_var *variable;
 505         struct read_file *eof;
 506       };
 507
 508     struct msg_location *location;
 509   };
 510
 511 static void
 512 matrix_expr_destroy (struct matrix_expr *e)
 513 {
 514   if (!e)
 515     return;
 516
 517   switch (e->op)
 518     {
 519 #define F(ENUM, STRING, PROTO, CONSTRAINTS) case MOP_F_##ENUM:
 520 MATRIX_FUNCTIONS
 521 #undef F
 522     case MOP_NEGATE:
 523     case MOP_ADD_ELEMS:
 524     case MOP_SUB_ELEMS:
 525     case MOP_MUL_ELEMS:
 526     case MOP_DIV_ELEMS:
 527     case MOP_EXP_ELEMS:
 528     case MOP_SEQ:
 529     case MOP_SEQ_BY:
 530     case MOP_MUL_MAT:
 531     case MOP_EXP_MAT:
 532     case MOP_GT:
 533     case MOP_GE:
 534     case MOP_LT:
 535     case MOP_LE:
 536     case MOP_EQ:
 537     case MOP_NE:
 538     case MOP_NOT:
 539     case MOP_AND:
 540     case MOP_OR:
 541     case MOP_XOR:
 542     case MOP_EMPTY:
 543     case MOP_PASTE_HORZ:
 544     case MOP_PASTE_VERT:
 545     case MOP_VEC_INDEX:
 546     case MOP_VEC_ALL:
 547     case MOP_MAT_INDEX:
 548     case MOP_ROW_INDEX:
 549     case MOP_COL_INDEX:
 550       for (size_t i = 0; i < e->n_subs; i++)
 551         matrix_expr_destroy (e->subs[i]);
 552       free (e->subs);
 553       break;
 554
 555     case MOP_NUMBER:
 556     case MOP_VARIABLE:
 557     case MOP_EOF:
 558       break;
 559     }
 560   msg_location_destroy (e->location);
 561   free (e);
 562 }
 563
 564 static struct matrix_expr *
 565 matrix_expr_create_subs (enum matrix_op op, struct matrix_expr **subs,
 566                          size_t n_subs)
 567 {
 568   struct matrix_expr *e = xmalloc (sizeof *e);
 569   *e = (struct matrix_expr) {
 570     .op = op,
 571     .subs = xmemdup (subs, n_subs * sizeof *subs),
 572     .n_subs = n_subs
 573   };
 574
 575   return e;
 576 }
 577
 578 static struct matrix_expr *
 579 matrix_expr_create_0 (enum matrix_op op)
 580 {
 581   struct matrix_expr *sub;
 582   return matrix_expr_create_subs (op, &sub, 0);
 583 }
 584
 585 static struct matrix_expr *
 586 matrix_expr_create_1 (enum matrix_op op, struct matrix_expr *sub)
 587 {
 588   return matrix_expr_create_subs (op, &sub, 1);
 589 }
 590
 591 static struct matrix_expr *
 592 matrix_expr_create_2 (enum matrix_op op,
 593                       struct matrix_expr *sub0, struct matrix_expr *sub1)
 594 {
 595   struct matrix_expr *subs[] = { sub0, sub1 };
 596   return matrix_expr_create_subs (op, subs, sizeof subs / sizeof *subs);
 597 }
 598
 599 static struct matrix_expr *
 600 matrix_expr_create_3 (enum matrix_op op, struct matrix_expr *sub0,
 601                       struct matrix_expr *sub1, struct matrix_expr *sub2)
 602 {
 603   struct matrix_expr *subs[] = { sub0, sub1, sub2 };
 604   return matrix_expr_create_subs (op, subs, sizeof subs / sizeof *subs);
 605 }
 606
 607 static struct matrix_expr *
 608 matrix_expr_create_number (struct lexer *lexer, double number)
 609 {
 610   struct matrix_expr *e = xmalloc (sizeof *e);
 611   *e = (struct matrix_expr) {
 612     .op = MOP_NUMBER,
 613     .number = number,
 614     .location = lex_get_location (lexer, 0, 0),
 615   };
 616   lex_get (lexer);
 617   return e;
 618 }
 619
 620 static struct matrix_expr *matrix_parse_or_xor (struct matrix_state *);
 621
 622 static struct matrix_expr *
 623 matrix_parse_curly_comma (struct matrix_state *s)
 624 {
 625   struct matrix_expr *lhs = matrix_parse_or_xor (s);
 626   if (!lhs)
 627     return NULL;
 628
 629   while (lex_match (s->lexer, T_COMMA))
 630     {
 631       struct matrix_expr *rhs = matrix_parse_or_xor (s);
 632       if (!rhs)
 633         {
 634           matrix_expr_destroy (lhs);
 635           return NULL;
 636         }
 637       lhs = matrix_expr_create_2 (MOP_PASTE_HORZ, lhs, rhs);
 638     }
 639   return lhs;
 640 }
 641
 642 static struct matrix_expr *
 643 matrix_parse_curly_semi (struct matrix_state *s)
 644 {
 645   if (lex_token (s->lexer) == T_RCURLY)
 646     {
 647       struct matrix_expr *e = matrix_expr_create_0 (MOP_EMPTY);
 648       e->location = lex_get_location (s->lexer, -1, 0);
 649       return e;
 650     }
 651
 652   struct matrix_expr *lhs = matrix_parse_curly_comma (s);
 653   if (!lhs)
 654     return NULL;
 655
 656   while (lex_match (s->lexer, T_SEMICOLON))
 657     {
 658       struct matrix_expr *rhs = matrix_parse_curly_comma (s);
 659       if (!rhs)
 660         {
 661           matrix_expr_destroy (lhs);
 662           return NULL;
 663         }
 664       lhs = matrix_expr_create_2 (MOP_PASTE_VERT, lhs, rhs);
 665     }
 666   return lhs;
 667 }
 668
 669 #define MATRIX_FOR_ALL_ELEMENTS(D, Y, X, M)                     \
 670   for (size_t Y = 0; Y < (M)->size1; Y++)                       \
 671     for (size_t X = 0; X < (M)->size2; X++)                     \
 672       for (double *D = gsl_matrix_ptr ((M), Y, X); D; D = NULL)
 673
 674 static bool
 675 is_vector (const gsl_matrix *m)
 676 {
 677   return m->size1 <= 1 || m->size2 <= 1;
 678 }
 679
 680 static gsl_vector
 681 to_vector (gsl_matrix *m)
 682 {
 683   return (m->size1 == 1
 684           ? gsl_matrix_row (m, 0).vector
 685           : gsl_matrix_column (m, 0).vector);
 686 }
 687
 688
 689 static double
 690 matrix_eval_ABS (double d)
 691 {
 692   return fabs (d);
 693 }
 694
 695 static double
 696 matrix_eval_ALL (gsl_matrix *m)
 697 {
 698   MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
 699     if (*d == 0.0)
 700       return 0.0;
 701   return 1.0;
 702 }
 703
 704 static double
 705 matrix_eval_ANY (gsl_matrix *m)
 706 {
 707   MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
 708     if (*d != 0.0)
 709       return !.0;
 710   return 0.0;
 711 }
 712
 713 static double
 714 matrix_eval_ARSIN (double d)
 715 {
 716   return asin (d);
 717 }
 718
 719 static double
 720 matrix_eval_ARTAN (double d)
 721 {
 722   return atan (d);
 723 }
 724
 725 static gsl_matrix *
 726 matrix_eval_BLOCK (gsl_matrix *m[], size_t n)
 727 {
 728   size_t r = 0;
 729   size_t c = 0;
 730   for (size_t i = 0; i < n; i++)
 731     {
 732       r += m[i]->size1;
 733       c += m[i]->size2;
 734     }
 735   gsl_matrix *block = gsl_matrix_calloc (r, c);
 736   r = c = 0;
 737   for (size_t i = 0; i < n; i++)
 738     {
 739       for (size_t y = 0; y < m[i]->size1; y++)
 740         for (size_t x = 0; x < m[i]->size2; x++)
 741           gsl_matrix_set (block, r + y, c + x, gsl_matrix_get (m[i], y, x));
 742       r += m[i]->size1;
 743       c += m[i]->size2;
 744     }
 745   return block;
 746 }
 747
 748 static gsl_matrix *
 749 matrix_eval_CHOL (gsl_matrix *m, const struct matrix_expr *e)
 750 {
 751   if (!gsl_linalg_cholesky_decomp1 (m))
 752     {
 753       for (size_t y = 0; y < m->size1; y++)
 754         for (size_t x = y + 1; x < m->size2; x++)
 755           gsl_matrix_set (m, y, x, gsl_matrix_get (m, x, y));
 756
 757       for (size_t y = 0; y < m->size1; y++)
 758         for (size_t x = 0; x < y; x++)
 759           gsl_matrix_set (m, y, x, 0);
 760       return m;
 761     }
 762   else
 763     {
 764       msg_at (SE, e->location,
 765               _("Input to CHOL function is not positive-definite."));
 766       return NULL;
 767     }
 768 }
 769
 770 static gsl_matrix *
 771 matrix_eval_col_extremum (gsl_matrix *m, bool min)
 772 {
 773   if (m->size1 <= 1)
 774     return m;
 775   else if (!m->size2)
 776     return gsl_matrix_alloc (1, 0);
 777
 778   gsl_matrix *cext = gsl_matrix_alloc (1, m->size2);
 779   for (size_t x = 0; x < m->size2; x++)
 780     {
 781       double ext = gsl_matrix_get (m, 0, x);
 782       for (size_t y = 1; y < m->size1; y++)
 783         {
 784           double value = gsl_matrix_get (m, y, x);
 785           if (min ? value < ext : value > ext)
 786             ext = value;
 787         }
 788       gsl_matrix_set (cext, 0, x, ext);
 789     }
 790   return cext;
 791 }
 792
 793 static gsl_matrix *
 794 matrix_eval_CMAX (gsl_matrix *m)
 795 {
 796   return matrix_eval_col_extremum (m, false);
 797 }
 798
 799 static gsl_matrix *
 800 matrix_eval_CMIN (gsl_matrix *m)
 801 {
 802   return matrix_eval_col_extremum (m, true);
 803 }
 804
 805 static double
 806 matrix_eval_COS (double d)
 807 {
 808   return cos (d);
 809 }
 810
 811 static gsl_matrix *
 812 matrix_eval_col_sum (gsl_matrix *m, bool square)
 813 {
 814   if (m->size1 == 0)
 815     return m;
 816   else if (!m->size2)
 817     return gsl_matrix_alloc (1, 0);
 818
 819   gsl_matrix *result = gsl_matrix_alloc (1, m->size2);
 820   for (size_t x = 0; x < m->size2; x++)
 821     {
 822       double sum = 0;
 823       for (size_t y = 0; y < m->size1; y++)
 824         {
 825           double d = gsl_matrix_get (m, y, x);
 826           sum += square ? pow2 (d) : d;
 827         }
 828       gsl_matrix_set (result, 0, x, sum);
 829     }
 830   return result;
 831 }
 832
 833 static gsl_matrix *
 834 matrix_eval_CSSQ (gsl_matrix *m)
 835 {
 836   return matrix_eval_col_sum (m, true);
 837 }
 838
 839 static gsl_matrix *
 840 matrix_eval_CSUM (gsl_matrix *m)
 841 {
 842   return matrix_eval_col_sum (m, false);
 843 }
 844
 845 static int
 846 compare_double_3way (const void *a_, const void *b_)
 847 {
 848   const double *a = a_;
 849   const double *b = b_;
 850   return *a < *b ? -1 : *a > *b;
 851 }
 852
 853 static gsl_matrix *
 854 matrix_eval_DESIGN (gsl_matrix *m)
 855 {
 856   double *tmp = xmalloc (m->size1 * m->size2 * sizeof *tmp);
 857   gsl_matrix m2 = gsl_matrix_view_array (tmp, m->size2, m->size1).matrix;
 858   gsl_matrix_transpose_memcpy (&m2, m);
 859
 860   for (size_t y = 0; y < m2.size1; y++)
 861     qsort (tmp + y * m2.size2, m2.size2, sizeof *tmp, compare_double_3way);
 862
 863   size_t *n = xcalloc (m2.size1, sizeof *n);
 864   size_t n_total = 0;
 865   for (size_t i = 0; i < m2.size1; i++)
 866     {
 867       double *row = tmp + m2.size2 * i;
 868       for (size_t j = 0; j < m2.size2; )
 869         {
 870           size_t k;
 871           for (k = j + 1; k < m2.size2; k++)
 872             if (row[j] != row[k])
 873               break;
 874           row[n[i]++] = row[j];
 875           j = k;
 876         }
 877
 878       if (n[i] <= 1)
 879         msg (MW, _("Column %zu in DESIGN argument has constant value."), i + 1);
 880       else
 881         n_total += n[i];
 882     }
 883
 884   gsl_matrix *result = gsl_matrix_alloc (m->size1, n_total);
 885   size_t x = 0;
 886   for (size_t i = 0; i < m->size2; i++)
 887     {
 888       if (n[i] <= 1)
 889         continue;
 890
 891       const double *unique = tmp + m2.size2 * i;
 892       for (size_t j = 0; j < n[i]; j++, x++)
 893         {
 894           double value = unique[j];
 895           for (size_t y = 0; y < m->size1; y++)
 896             gsl_matrix_set (result, y, x, gsl_matrix_get (m, y, i) == value);
 897         }
 898     }
 899
 900   free (n);
 901   free (tmp);
 902
 903   return result;
 904 }
 905
 906 static double
 907 matrix_eval_DET (gsl_matrix *m)
 908 {
 909   gsl_permutation *p = gsl_permutation_alloc (m->size1);
 910   int signum;
 911   gsl_linalg_LU_decomp (m, p, &signum);
 912   gsl_permutation_free (p);
 913   return gsl_linalg_LU_det (m, signum);
 914 }
 915
 916 static gsl_matrix *
 917 matrix_eval_DIAG (gsl_matrix *m)
 918 {
 919   gsl_matrix *diag = gsl_matrix_alloc (MIN (m->size1, m->size2), 1);
 920   for (size_t i = 0; i < diag->size1; i++)
 921     gsl_matrix_set (diag, i, 0, gsl_matrix_get (m, i, i));
 922   return diag;
 923 }
 924
 925 static bool
 926 is_symmetric (const gsl_matrix *m)
 927 {
 928   if (m->size1 != m->size2)
 929     return false;
 930
 931   for (size_t y = 0; y < m->size1; y++)
 932     for (size_t x = 0; x < y; x++)
 933       if (gsl_matrix_get (m, y, x) != gsl_matrix_get (m, x, y))
 934         return false;
 935
 936   return true;
 937 }
 938
 939 static int
 940 compare_double_desc (const void *a_, const void *b_)
 941 {
 942   const double *a = a_;
 943   const double *b = b_;
 944   return *a > *b ? -1 : *a < *b;
 945 }
 946
 947 static gsl_matrix *
 948 matrix_eval_EVAL (gsl_matrix *m)
 949 {
 950   if (!is_symmetric (m))
 951     {
 952       msg (SE, _("Argument of EVAL must be symmetric."));
 953       return NULL;
 954     }
 955
 956   gsl_eigen_symm_workspace *w = gsl_eigen_symm_alloc (m->size1);
 957   gsl_matrix *eval = gsl_matrix_alloc (m->size1, 1);
 958   gsl_vector v_eval = to_vector (eval);
 959   gsl_eigen_symm (m, &v_eval, w);
 960   gsl_eigen_symm_free (w);
 961
 962   assert (v_eval.stride == 1);
 963   qsort (v_eval.data, v_eval.size, sizeof *v_eval.data, compare_double_desc);
 964
 965   return eval;
 966 }
 967
 968 static double
 969 matrix_eval_EXP (double d)
 970 {
 971   return exp (d);
 972 }
 973
 974 /* From https://gist.github.com/turingbirds/5e99656e08dbe1324c99, where it was
 975    marked as:
 976
 977    Charl Linssen <charl@itfromb.it>
 978    Feb 2016
 979    PUBLIC DOMAIN */
 980 static gsl_matrix *
 981 matrix_eval_GINV (gsl_matrix *A)
 982 {
 983   size_t n = A->size1;
 984   size_t m = A->size2;
 985   bool swap = m > n;
 986   gsl_matrix *tmp_mat = NULL;
 987   if (swap)
 988     {
 989       /* libgsl SVD can only handle the case m <= n, so transpose matrix. */
 990       tmp_mat = gsl_matrix_alloc (m, n);
 991       gsl_matrix_transpose_memcpy (tmp_mat, A);
 992       A = tmp_mat;
 993       size_t i = m;
 994       m = n;
 995       n = i;
 996     }
 997
 998   /* Do SVD. */
 999   gsl_matrix *V = gsl_matrix_alloc (m, m);
1000   gsl_vector *u = gsl_vector_alloc (m);
1001
1002   gsl_vector *tmp_vec = gsl_vector_alloc (m);
1003   gsl_linalg_SV_decomp (A, V, u, tmp_vec);
1004   gsl_vector_free (tmp_vec);
1005
1006   /* Compute Σ⁻¹. */
1007   gsl_matrix *Sigma_pinv = gsl_matrix_alloc (m, n);
1008   gsl_matrix_set_zero (Sigma_pinv);
1009   double cutoff = 1e-15 * gsl_vector_max (u);
1010
1011   for (size_t i = 0; i < m; ++i)
1012     {
1013       double x = gsl_vector_get (u, i);
1014       gsl_matrix_set (Sigma_pinv, i, i, x > cutoff ? 1.0 / x : 0);
1015     }
1016
1017   /* libgsl SVD yields "thin" SVD - pad to full matrix by adding zeros */
1018   gsl_matrix *U = gsl_matrix_calloc (n, n);
1019   for (size_t i = 0; i < n; i++)
1020     for (size_t j = 0; j < m; j++)
1021       gsl_matrix_set (U, i, j, gsl_matrix_get (A, i, j));
1022
1023   /* two dot products to obtain pseudoinverse */
1024   gsl_matrix *tmp_mat2 = gsl_matrix_alloc (m, n);
1025   gsl_blas_dgemm (CblasNoTrans, CblasNoTrans, 1., V, Sigma_pinv, 0., tmp_mat2);
1026
1027   gsl_matrix *A_pinv;
1028   if (swap)
1029     {
1030       A_pinv = gsl_matrix_alloc (n, m);
1031       gsl_blas_dgemm (CblasNoTrans, CblasTrans, 1., U, tmp_mat2, 0., A_pinv);
1032     }
1033   else
1034     {
1035       A_pinv = gsl_matrix_alloc (m, n);
1036       gsl_blas_dgemm (CblasNoTrans, CblasTrans, 1., tmp_mat2, U, 0., A_pinv);
1037     }
1038
1039   gsl_matrix_free (tmp_mat);
1040   gsl_matrix_free (tmp_mat2);
1041   gsl_matrix_free (U);
1042   gsl_matrix_free (Sigma_pinv);
1043   gsl_vector_free (u);
1044   gsl_matrix_free (V);
1045
1046   return A_pinv;
1047 }
1048
1049 struct grade
1050   {
1051     size_t y, x;
1052     double value;
1053   };
1054
1055 static int
1056 grade_compare_3way (const void *a_, const void *b_)
1057 {
1058   const struct grade *a = a_;
1059   const struct grade *b = b_;
1060
1061   return (a->value < b->value ? -1
1062           : a->value > b->value ? 1
1063           : a->y < b->y ? -1
1064           : a->y > b->y ? 1
1065           : a->x < b->x ? -1
1066           : a->x > b->x);
1067 }
1068
1069 static gsl_matrix *
1070 matrix_eval_GRADE (gsl_matrix *m)
1071 {
1072   size_t n = m->size1 * m->size2;
1073   struct grade *grades = xmalloc (n * sizeof *grades);
1074
1075   size_t i = 0;
1076   MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
1077     grades[i++] = (struct grade) { .y = y, .x = x, .value = *d };
1078   qsort (grades, n, sizeof *grades, grade_compare_3way);
1079
1080   for (size_t i = 0; i < n; i++)
1081     gsl_matrix_set (m, grades[i].y, grades[i].x, i + 1);
1082
1083   free (grades);
1084
1085   return m;
1086 }
1087
1088 static double
1089 dot (gsl_vector *a, gsl_vector *b)
1090 {
1091   double result = 0.0;
1092   for (size_t i = 0; i < a->size; i++)
1093     result += gsl_vector_get (a, i) * gsl_vector_get (b, i);
1094   return result;
1095 }
1096
1097 static double
1098 norm2 (gsl_vector *v)
1099 {
1100   double result = 0.0;
1101   for (size_t i = 0; i < v->size; i++)
1102     result += pow2 (gsl_vector_get (v, i));
1103   return result;
1104 }
1105
1106 static double
1107 norm (gsl_vector *v)
1108 {
1109   return sqrt (norm2 (v));
1110 }
1111
1112 static gsl_matrix *
1113 matrix_eval_GSCH (gsl_matrix *v)
1114 {
1115   if (v->size2 < v->size1)
1116     {
1117       msg (SE, _("GSCH requires its argument to have at least as many columns "
1118                  "as rows, but it has dimensions %zu×%zu."),
1119            v->size1, v->size2);
1120       return NULL;
1121     }
1122   if (!v->size1 || !v->size2)
1123     return v;
1124
1125   gsl_matrix *u = gsl_matrix_calloc (v->size1, v->size2);
1126   size_t ux = 0;
1127   for (size_t vx = 0; vx < v->size2; vx++)
1128     {
1129       gsl_vector u_i = gsl_matrix_column (u, ux).vector;
1130       gsl_vector v_i = gsl_matrix_column (v, vx).vector;
1131
1132       gsl_vector_memcpy (&u_i, &v_i);
1133       for (size_t j = 0; j < ux; j++)
1134         {
1135           gsl_vector u_j = gsl_matrix_column (u, j).vector;
1136           double scale = dot (&u_j, &u_i) / norm2 (&u_j);
1137           for (size_t k = 0; k < u_i.size; k++)
1138             gsl_vector_set (&u_i, k, (gsl_vector_get (&u_i, k)
1139                                       - scale * gsl_vector_get (&u_j, k)));
1140         }
1141
1142       double len = norm (&u_i);
1143       if (len > 1e-15)
1144         {
1145           gsl_vector_scale (&u_i, 1.0 / len);
1146           if (++ux >= v->size1)
1147             break;
1148         }
1149     }
1150
1151   if (ux < v->size1)
1152     {
1153       msg (SE, _("%zu×%zu argument to GSCH contains only "
1154                  "%zu linearly independent columns."),
1155            v->size1, v->size2, ux);
1156       gsl_matrix_free (u);
1157       return NULL;
1158     }
1159
1160   u->size2 = v->size1;
1161   return u;
1162 }
1163
1164 static gsl_matrix *
1165 matrix_eval_IDENT (double s1, double s2)
1166 {
1167   gsl_matrix *m = gsl_matrix_alloc (s1, s2);
1168   MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
1169     *d = x == y;
1170   return m;
1171 }
1172
1173 static void
1174 invert_matrix (gsl_matrix *x)
1175 {
1176   gsl_permutation *p = gsl_permutation_alloc (x->size1);
1177   int signum;
1178   gsl_linalg_LU_decomp (x, p, &signum);
1179   gsl_linalg_LU_invx (x, p);
1180   gsl_permutation_free (p);
1181 }
1182
1183 static gsl_matrix *
1184 matrix_eval_INV (gsl_matrix *m)
1185 {
1186   invert_matrix (m);
1187   return m;
1188 }
1189
1190 static gsl_matrix *
1191 matrix_eval_KRONEKER (gsl_matrix *a, gsl_matrix *b)
1192 {
1193   gsl_matrix *k = gsl_matrix_alloc (a->size1 * b->size1,
1194                                     a->size2 * b->size2);
1195   size_t y = 0;
1196   for (size_t ar = 0; ar < a->size1; ar++)
1197     for (size_t br = 0; br < b->size1; br++, y++)
1198       {
1199         size_t x = 0;
1200         for (size_t ac = 0; ac < a->size2; ac++)
1201           for (size_t bc = 0; bc < b->size2; bc++, x++)
1202             {
1203               double av = gsl_matrix_get (a, ar, ac);
1204               double bv = gsl_matrix_get (b, br, bc);
1205               gsl_matrix_set (k, y, x, av * bv);
1206             }
1207       }
1208   return k;
1209 }
1210
1211 static double
1212 matrix_eval_LG10 (double d)
1213 {
1214   return log10 (d);
1215 }
1216
1217 static double
1218 matrix_eval_LN (double d)
1219 {
1220   return log (d);
1221 }
1222
1223 static void
1224 matrix_eval_MAGIC_odd (gsl_matrix *m, size_t n)
1225 {
1226   /* Siamese method: https://en.wikipedia.org/wiki/Siamese_method. */
1227   size_t y = 0;
1228   size_t x = n / 2;
1229   for (size_t i = 1; i <= n * n; i++)
1230     {
1231       gsl_matrix_set (m, y, x, i);
1232
1233       size_t y1 = !y ? n - 1 : y - 1;
1234       size_t x1 = x + 1 >= n ? 0 : x + 1;
1235       if (gsl_matrix_get (m, y1, x1) == 0)
1236         {
1237           y = y1;
1238           x = x1;
1239         }
1240       else
1241         y = y + 1 >= n ? 0 : y + 1;
1242     }
1243 }
1244
1245 static void
1246 magic_exchange (gsl_matrix *m, size_t y1, size_t x1, size_t y2, size_t x2)
1247 {
1248   double a = gsl_matrix_get (m, y1, x1);
1249   double b = gsl_matrix_get (m, y2, x2);
1250   gsl_matrix_set (m, y1, x1, b);
1251   gsl_matrix_set (m, y2, x2, a);
1252 }
1253
1254 static void
1255 matrix_eval_MAGIC_doubly_even (gsl_matrix *m, size_t n)
1256 {
1257   size_t x, y;
1258
1259   /* A. Umar, "On the Construction of Even Order Magic Squares",
1260      https://arxiv.org/ftp/arxiv/papers/1202/1202.0948.pdf. */
1261   x = y = 0;
1262   for (size_t i = 1; i <= n * n / 2; i++)
1263     {
1264       gsl_matrix_set (m, y, x, i);
1265       if (++y >= n)
1266         {
1267           y = 0;
1268           x++;
1269         }
1270     }
1271
1272   x = n - 1;
1273   y = 0;
1274   for (size_t i = n * n; i > n * n / 2; i--)
1275     {
1276       gsl_matrix_set (m, y, x, i);
1277       if (++y >= n)
1278         {
1279           y = 0;
1280           x--;
1281         }
1282     }
1283
1284   for (size_t y = 0; y < n; y++)
1285     for (size_t x = 0; x < n / 2; x++)
1286       {
1287         unsigned int d = gsl_matrix_get (m, y, x);
1288         if (d % 2 != (y < n / 2))
1289           magic_exchange (m, y, x, y, n - x - 1);
1290       }
1291
1292   size_t y1 = n / 2;
1293   size_t y2 = n - 1;
1294   size_t x1 = n / 2 - 1;
1295   size_t x2 = n / 2;
1296   magic_exchange (m, y1, x1, y2, x1);
1297   magic_exchange (m, y1, x2, y2, x2);
1298 }
1299
1300 static void
1301 matrix_eval_MAGIC_singly_even (gsl_matrix *m, size_t n)
1302 {
1303   /* A. Umar, "On the Construction of Even Order Magic Squares",
1304      https://arxiv.org/ftp/arxiv/papers/1202/1202.0948.pdf. */
1305   size_t x, y;
1306
1307   x = y = 0;
1308   for (size_t i = 1; ; i++)
1309     {
1310       gsl_matrix_set (m, y, x, i);
1311       if (++y == n / 2 - 1)
1312         y += 2;
1313       else if (y >= n)
1314         {
1315           y = 0;
1316           if (++x >= n / 2)
1317             break;
1318         }
1319     }
1320
1321   x = n - 1;
1322   y = 0;
1323   for (size_t i = n * n; ; i--)
1324     {
1325       gsl_matrix_set (m, y, x, i);
1326       if (++y == n / 2 - 1)
1327         y += 2;
1328       else if (y >= n)
1329         {
1330           y = 0;
1331           if (--x < n / 2)
1332             break;
1333         }
1334     }
1335   for (size_t y = 0; y < n; y++)
1336     if (y != n / 2 - 1 && y != n / 2)
1337       for (size_t x = 0; x < n / 2; x++)
1338         {
1339           unsigned int d = gsl_matrix_get (m, y, x);
1340           if (d % 2 != (y < n / 2))
1341             magic_exchange (m, y, x, y, n - x - 1);
1342         }
1343
1344   size_t a0 = (n * n - 2 * n) / 2 + 1;
1345   for (size_t i = 0; i < n / 2; i++)
1346     {
1347       size_t a = a0 + i;
1348       gsl_matrix_set (m, n / 2, i, a);
1349       gsl_matrix_set (m, n / 2 - 1, i, (n * n + 1) - a);
1350     }
1351   for (size_t i = 0; i < n / 2; i++)
1352     {
1353       size_t a = a0 + i + n / 2;
1354       gsl_matrix_set (m, n / 2 - 1, n - i - 1, a);
1355       gsl_matrix_set (m, n / 2, n - i - 1, (n * n + 1) - a);
1356     }
1357   for (size_t x = 1; x < n / 2; x += 2)
1358     magic_exchange (m, n / 2, x, n / 2 - 1, x);
1359   for (size_t x = n / 2 + 2; x <= n - 3; x += 2)
1360     magic_exchange (m, n / 2, x, n / 2 - 1, x);
1361   size_t x1 = n / 2 - 2;
1362   size_t x2 = n / 2 + 1;
1363   size_t y1 = n / 2 - 2;
1364   size_t y2 = n / 2 + 1;
1365   magic_exchange (m, y1, x1, y2, x1);
1366   magic_exchange (m, y1, x2, y2, x2);
1367 }
1368
1369 static gsl_matrix *
1370 matrix_eval_MAGIC (double n_)
1371 {
1372   size_t n = n_;
1373
1374   gsl_matrix *m = gsl_matrix_calloc (n, n);
1375   if (n % 2)
1376     matrix_eval_MAGIC_odd (m, n);
1377   else if (n % 4)
1378     matrix_eval_MAGIC_singly_even (m, n);
1379   else
1380     matrix_eval_MAGIC_doubly_even (m, n);
1381   return m;
1382 }
1383
1384 static gsl_matrix *
1385 matrix_eval_MAKE (double r, double c, double value)
1386 {
1387   gsl_matrix *m = gsl_matrix_alloc (r, c);
1388   MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
1389     *d = value;
1390   return m;
1391 }
1392
1393 static gsl_matrix *
1394 matrix_eval_MDIAG (gsl_vector *v)
1395 {
1396   gsl_matrix *m = gsl_matrix_calloc (v->size, v->size);
1397   gsl_vector diagonal = gsl_matrix_diagonal (m).vector;
1398   gsl_vector_memcpy (&diagonal, v);
1399   return m;
1400 }
1401
1402 static double
1403 matrix_eval_MMAX (gsl_matrix *m)
1404 {
1405   return gsl_matrix_max (m);
1406 }
1407
1408 static double
1409 matrix_eval_MMIN (gsl_matrix *m)
1410 {
1411   return gsl_matrix_min (m);
1412 }
1413
1414 static gsl_matrix *
1415 matrix_eval_MOD (gsl_matrix *m, double divisor)
1416 {
1417   MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
1418     *d = fmod (*d, divisor);
1419   return m;
1420 }
1421
1422 static double
1423 matrix_eval_MSSQ (gsl_matrix *m)
1424 {
1425   double mssq = 0.0;
1426   MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
1427     mssq += *d * *d;
1428   return mssq;
1429 }
1430
1431 static double
1432 matrix_eval_MSUM (gsl_matrix *m)
1433 {
1434   double msum = 0.0;
1435   MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
1436     msum += *d;
1437   return msum;
1438 }
1439
1440 static double
1441 matrix_eval_NCOL (gsl_matrix *m)
1442 {
1443   return m->size2;
1444 }
1445
1446 static double
1447 matrix_eval_NROW (gsl_matrix *m)
1448 {
1449   return m->size1;
1450 }
1451
1452 static double
1453 matrix_eval_RANK (gsl_matrix *m)
1454 {
1455   gsl_vector *tau = gsl_vector_alloc (MIN (m->size1, m->size2));
1456   gsl_linalg_QR_decomp (m, tau);
1457   gsl_vector_free (tau);
1458
1459   return gsl_linalg_QRPT_rank (m, -1);
1460 }
1461
1462 static gsl_matrix *
1463 matrix_eval_RESHAPE (gsl_matrix *m, double r_, double c_)
1464 {
1465   if (r_ < 0 || r_ >= SIZE_MAX || c_ < 0 || c_ >= SIZE_MAX)
1466     {
1467       msg (SE, _("Arguments 2 and 3 to RESHAPE must be integers."));
1468       return NULL;
1469     }
1470   size_t r = r_;
1471   size_t c = c_;
1472   if (size_overflow_p (xtimes (r, xmax (c, 1))) || c * r != m->size1 * m->size2)
1473     {
1474       msg (SE, _("Product of RESHAPE arguments 2 and 3 differ from "
1475                  "product of matrix dimensions."));
1476       return NULL;
1477     }
1478
1479   gsl_matrix *dst = gsl_matrix_alloc (r, c);
1480   size_t y1 = 0;
1481   size_t x1 = 0;
1482   MATRIX_FOR_ALL_ELEMENTS (d, y2, x2, m)
1483     {
1484       gsl_matrix_set (dst, y1, x1, *d);
1485       if (++x1 >= c)
1486         {
1487           x1 = 0;
1488           y1++;
1489         }
1490     }
1491   return dst;
1492 }
1493
1494 static gsl_matrix *
1495 matrix_eval_row_extremum (gsl_matrix *m, bool min)
1496 {
1497   if (m->size2 <= 1)
1498     return m;
1499   else if (!m->size1)
1500     return gsl_matrix_alloc (0, 1);
1501
1502   gsl_matrix *rext = gsl_matrix_alloc (m->size1, 1);
1503   for (size_t y = 0; y < m->size1; y++)
1504     {
1505       double ext = gsl_matrix_get (m, y, 0);
1506       for (size_t x = 1; x < m->size2; x++)
1507         {
1508           double value = gsl_matrix_get (m, y, x);
1509           if (min ? value < ext : value > ext)
1510             ext = value;
1511         }
1512       gsl_matrix_set (rext, y, 0, ext);
1513     }
1514   return rext;
1515 }
1516
1517 static gsl_matrix *
1518 matrix_eval_RMAX (gsl_matrix *m)
1519 {
1520   return matrix_eval_row_extremum (m, false);
1521 }
1522
1523 static gsl_matrix *
1524 matrix_eval_RMIN (gsl_matrix *m)
1525 {
1526   return matrix_eval_row_extremum (m, true);
1527 }
1528
1529 static double
1530 matrix_eval_RND (double d)
1531 {
1532   return rint (d);
1533 }
1534
1535 struct rank
1536   {
1537     size_t y, x;
1538     double value;
1539   };
1540
1541 static int
1542 rank_compare_3way (const void *a_, const void *b_)
1543 {
1544   const struct rank *a = a_;
1545   const struct rank *b = b_;
1546
1547   return a->value < b->value ? -1 : a->value > b->value;
1548 }
1549
1550 static gsl_matrix *
1551 matrix_eval_RNKORDER (gsl_matrix *m)
1552 {
1553   size_t n = m->size1 * m->size2;
1554   struct rank *ranks = xmalloc (n * sizeof *ranks);
1555   size_t i = 0;
1556   MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
1557     ranks[i++] = (struct rank) { .y = y, .x = x, .value = *d };
1558   qsort (ranks, n, sizeof *ranks, rank_compare_3way);
1559
1560   for (size_t i = 0; i < n; )
1561     {
1562       size_t j;
1563       for (j = i + 1; j < n; j++)
1564         if (ranks[i].value != ranks[j].value)
1565           break;
1566
1567       double rank = (i + j + 1.0) / 2.0;
1568       for (size_t k = i; k < j; k++)
1569         gsl_matrix_set (m, ranks[k].y, ranks[k].x, rank);
1570
1571       i = j;
1572     }
1573
1574   free (ranks);
1575
1576   return m;
1577 }
1578
1579 static gsl_matrix *
1580 matrix_eval_row_sum (gsl_matrix *m, bool square)
1581 {
1582   if (m->size1 == 0)
1583     return m;
1584   else if (!m->size1)
1585     return gsl_matrix_alloc (0, 1);
1586
1587   gsl_matrix *result = gsl_matrix_alloc (m->size1, 1);
1588   for (size_t y = 0; y < m->size1; y++)
1589     {
1590       double sum = 0;
1591       for (size_t x = 0; x < m->size2; x++)
1592         {
1593           double d = gsl_matrix_get (m, y, x);
1594           sum += square ? pow2 (d) : d;
1595         }
1596       gsl_matrix_set (result, y, 0, sum);
1597     }
1598   return result;
1599 }
1600
1601 static gsl_matrix *
1602 matrix_eval_RSSQ (gsl_matrix *m)
1603 {
1604   return matrix_eval_row_sum (m, true);
1605 }
1606
1607 static gsl_matrix *
1608 matrix_eval_RSUM (gsl_matrix *m)
1609 {
1610   return matrix_eval_row_sum (m, false);
1611 }
1612
1613 static double
1614 matrix_eval_SIN (double d)
1615 {
1616   return sin (d);
1617 }
1618
1619 static gsl_matrix *
1620 matrix_eval_SOLVE (gsl_matrix *m1, gsl_matrix *m2)
1621 {
1622   if (m1->size1 != m2->size1)
1623     {
1624       msg (SE, _("SOLVE requires its arguments to have the same number of "
1625                  "rows, but the first argument has dimensions %zu×%zu and "
1626                  "the second %zu×%zu."),
1627            m1->size1, m1->size2,
1628            m2->size1, m2->size2);
1629       return NULL;
1630     }
1631
1632   gsl_matrix *x = gsl_matrix_alloc (m2->size1, m2->size2);
1633   gsl_permutation *p = gsl_permutation_alloc (m1->size1);
1634   int signum;
1635   gsl_linalg_LU_decomp (m1, p, &signum);
1636   for (size_t i = 0; i < m2->size2; i++)
1637     {
1638       gsl_vector bi = gsl_matrix_column (m2, i).vector;
1639       gsl_vector xi = gsl_matrix_column (x, i).vector;
1640       gsl_linalg_LU_solve (m1, p, &bi, &xi);
1641     }
1642   gsl_permutation_free (p);
1643   return x;
1644 }
1645
1646 static double
1647 matrix_eval_SQRT (double d)
1648 {
1649   return sqrt (d);
1650 }
1651
1652 static gsl_matrix *
1653 matrix_eval_SSCP (gsl_matrix *m)
1654 {
1655   gsl_matrix *sscp = gsl_matrix_alloc (m->size2, m->size2);
1656   gsl_blas_dgemm (CblasTrans, CblasNoTrans, 1.0, m, m, 0.0, sscp);
1657   return sscp;
1658 }
1659
1660 static gsl_matrix *
1661 matrix_eval_SVAL (gsl_matrix *m)
1662 {
1663   gsl_matrix *tmp_mat = NULL;
1664   if (m->size2 > m->size1)
1665     {
1666       tmp_mat = gsl_matrix_alloc (m->size2, m->size1);
1667       gsl_matrix_transpose_memcpy (tmp_mat, m);
1668       m = tmp_mat;
1669     }
1670
1671   /* Do SVD. */
1672   gsl_matrix *V = gsl_matrix_alloc (m->size2, m->size2);
1673   gsl_vector *S = gsl_vector_alloc (m->size2);
1674   gsl_vector *work = gsl_vector_alloc (m->size2);
1675   gsl_linalg_SV_decomp (m, V, S, work);
1676
1677   gsl_matrix *vals = gsl_matrix_alloc (m->size2, 1);
1678   for (size_t i = 0; i < m->size2; i++)
1679     gsl_matrix_set (vals, i, 0, gsl_vector_get (S, i));
1680
1681   gsl_matrix_free (V);
1682   gsl_vector_free (S);
1683   gsl_vector_free (work);
1684   gsl_matrix_free (tmp_mat);
1685
1686   return vals;
1687 }
1688
1689 static gsl_matrix *
1690 matrix_eval_SWEEP (gsl_matrix *m, double d)
1691 {
1692   if (d < 1 || d > SIZE_MAX)
1693     {
1694       msg (SE, _("Scalar argument to SWEEP must be integer."));
1695       return NULL;
1696     }
1697   size_t k = d - 1;
1698   if (k >= MIN (m->size1, m->size2))
1699     {
1700       msg (SE, _("Scalar argument to SWEEP must be integer less than or "
1701                  "equal to the smaller of the matrix argument's rows and "
1702                  "columns."));
1703       return NULL;
1704     }
1705
1706   double m_kk = gsl_matrix_get (m, k, k);
1707   if (fabs (m_kk) > 1e-19)
1708     {
1709       gsl_matrix *a = gsl_matrix_alloc (m->size1, m->size2);
1710       MATRIX_FOR_ALL_ELEMENTS (a_ij, i, j, a)
1711         {
1712           double m_ij = gsl_matrix_get (m, i, j);
1713           double m_ik = gsl_matrix_get (m, i, k);
1714           double m_kj = gsl_matrix_get (m, k, j);
1715           *a_ij = (i != k && j != k ? m_ij * m_kk - m_ik * m_kj
1716                    : i != k ? -m_ik
1717                    : j != k ? m_kj
1718                    : 1.0) / m_kk;
1719         }
1720       return a;
1721     }
1722   else
1723     {
1724       for (size_t i = 0; i < m->size1; i++)
1725         {
1726           gsl_matrix_set (m, i, k, 0);
1727           gsl_matrix_set (m, k, i, 0);
1728         }
1729       return m;
1730     }
1731 }
1732
1733 static double
1734 matrix_eval_TRACE (gsl_matrix *m)
1735 {
1736   double sum = 0;
1737   size_t n = MIN (m->size1, m->size2);
1738   for (size_t i = 0; i < n; i++)
1739     sum += gsl_matrix_get (m, i, i);
1740   return sum;
1741 }
1742
1743 static gsl_matrix *
1744 matrix_eval_T (gsl_matrix *m)
1745 {
1746   return matrix_eval_TRANSPOS (m);
1747 }
1748
1749 static gsl_matrix *
1750 matrix_eval_TRANSPOS (gsl_matrix *m)
1751 {
1752   if (m->size1 == m->size2)
1753     {
1754       gsl_matrix_transpose (m);
1755       return m;
1756     }
1757   else
1758     {
1759       gsl_matrix *t = gsl_matrix_alloc (m->size2, m->size1);
1760       gsl_matrix_transpose_memcpy (t, m);
1761       return t;
1762     }
1763 }
1764
1765 static double
1766 matrix_eval_TRUNC (double d)
1767 {
1768   return trunc (d);
1769 }
1770
1771 static gsl_matrix *
1772 matrix_eval_UNIFORM (double r_, double c_)
1773 {
1774   size_t r = r_;
1775   size_t c = c_;
1776   if (size_overflow_p (xtimes (r, xmax (c, 1))))
1777     {
1778       msg (SE, _("Product of arguments to UNIFORM exceeds memory size."));
1779       return NULL;
1780     }
1781
1782   gsl_matrix *m = gsl_matrix_alloc (r, c);
1783   MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
1784     *d = gsl_ran_flat (get_rng (), 0, 1);
1785   return m;
1786 }
1787
1788 static double
1789 matrix_eval_PDF_BETA (double x, double a, double b)
1790 {
1791   return gsl_ran_beta_pdf (x, a, b);
1792 }
1793
1794 static double
1795 matrix_eval_CDF_BETA (double x, double a, double b)
1796 {
1797   return gsl_cdf_beta_P (x, a, b);
1798 }
1799
1800 static double
1801 matrix_eval_IDF_BETA (double P, double a, double b)
1802 {
1803   return gsl_cdf_beta_Pinv (P, a, b);
1804 }
1805
1806 static double
1807 matrix_eval_RV_BETA (double a, double b)
1808 {
1809   return gsl_ran_beta (get_rng (), a, b);
1810 }
1811
1812 static double
1813 matrix_eval_NCDF_BETA (double x, double a, double b, double lambda)
1814 {
1815   return ncdf_beta (x, a, b, lambda);
1816 }
1817
1818 static double
1819 matrix_eval_NPDF_BETA (double x, double a, double b, double lambda)
1820 {
1821   return npdf_beta (x, a, b, lambda);
1822 }
1823
1824 static double
1825 matrix_eval_CDF_BVNOR (double x0, double x1, double r)
1826 {
1827   return cdf_bvnor (x0, x1, r);
1828 }
1829
1830 static double
1831 matrix_eval_PDF_BVNOR (double x0, double x1, double r)
1832 {
1833   return gsl_ran_bivariate_gaussian_pdf (x0, x1, 1, 1, r);
1834 }
1835
1836 static double
1837 matrix_eval_CDF_CAUCHY (double x, double a, double b)
1838 {
1839   return gsl_cdf_cauchy_P ((x - a) / b, 1);
1840 }
1841
1842 static double
1843 matrix_eval_IDF_CAUCHY (double P, double a, double b)
1844 {
1845   return a + b * gsl_cdf_cauchy_Pinv (P, 1);
1846 }
1847
1848 static double
1849 matrix_eval_PDF_CAUCHY (double x, double a, double b)
1850 {
1851   return gsl_ran_cauchy_pdf ((x - a) / b, 1) / b;
1852 }
1853
1854 static double
1855 matrix_eval_RV_CAUCHY (double a, double b)
1856 {
1857   return a + b * gsl_ran_cauchy (get_rng (), 1);
1858 }
1859
1860 static double
1861 matrix_eval_CDF_CHISQ (double x, double df)
1862 {
1863   return gsl_cdf_chisq_P (x, df);
1864 }
1865
1866 static double
1867 matrix_eval_CHICDF (double x, double df)
1868 {
1869   return matrix_eval_CDF_CHISQ (x, df);
1870 }
1871
1872 static double
1873 matrix_eval_IDF_CHISQ (double P, double df)
1874 {
1875   return gsl_cdf_chisq_Pinv (P, df);
1876 }
1877
1878 static double
1879 matrix_eval_PDF_CHISQ (double x, double df)
1880 {
1881   return gsl_ran_chisq_pdf (x, df);
1882 }
1883
1884 static double
1885 matrix_eval_RV_CHISQ (double df)
1886 {
1887   return gsl_ran_chisq (get_rng (), df);
1888 }
1889
1890 static double
1891 matrix_eval_SIG_CHISQ (double x, double df)
1892 {
1893   return gsl_cdf_chisq_Q (x, df);
1894 }
1895
1896 static double
1897 matrix_eval_CDF_EXP (double x, double a)
1898 {
1899   return gsl_cdf_exponential_P (x, 1. / a);
1900 }
1901
1902 static double
1903 matrix_eval_IDF_EXP (double P, double a)
1904 {
1905   return gsl_cdf_exponential_Pinv (P, 1. / a);
1906 }
1907
1908 static double
1909 matrix_eval_PDF_EXP (double x, double a)
1910 {
1911   return gsl_ran_exponential_pdf (x, 1. / a);
1912 }
1913
1914 static double
1915 matrix_eval_RV_EXP (double a)
1916 {
1917   return gsl_ran_exponential (get_rng (), 1. / a);
1918 }
1919
1920 static double
1921 matrix_eval_PDF_XPOWER (double x, double a, double b)
1922 {
1923   return gsl_ran_exppow_pdf (x, a, b);
1924 }
1925
1926 static double
1927 matrix_eval_RV_XPOWER (double a, double b)
1928 {
1929   return gsl_ran_exppow (get_rng (), a, b);
1930 }
1931
1932 static double
1933 matrix_eval_CDF_F (double x, double df1, double df2)
1934 {
1935   return gsl_cdf_fdist_P (x, df1, df2);
1936 }
1937
1938 static double
1939 matrix_eval_FCDF (double x, double df1, double df2)
1940 {
1941   return matrix_eval_CDF_F (x, df1, df2);
1942 }
1943
1944 static double
1945 matrix_eval_IDF_F (double P, double df1, double df2)
1946 {
1947   return idf_fdist (P, df1, df2);
1948 }
1949
1950 static double
1951 matrix_eval_RV_F (double df1, double df2)
1952 {
1953   return gsl_ran_fdist (get_rng (), df1, df2);
1954 }
1955
1956 static double
1957 matrix_eval_PDF_F (double x, double df1, double df2)
1958 {
1959   return gsl_ran_fdist_pdf (x, df1, df2);
1960 }
1961
1962 static double
1963 matrix_eval_SIG_F (double x, double df1, double df2)
1964 {
1965   return gsl_cdf_fdist_Q (x, df1, df2);
1966 }
1967
1968 static double
1969 matrix_eval_CDF_GAMMA (double x, double a, double b)
1970 {
1971   return gsl_cdf_gamma_P (x, a, 1. / b);
1972 }
1973
1974 static double
1975 matrix_eval_IDF_GAMMA (double P, double a, double b)
1976 {
1977   return gsl_cdf_gamma_Pinv (P, a, 1. / b);
1978 }
1979
1980 static double
1981 matrix_eval_PDF_GAMMA (double x, double a, double b)
1982 {
1983   return gsl_ran_gamma_pdf (x, a, 1. / b);
1984 }
1985
1986 static double
1987 matrix_eval_RV_GAMMA (double a, double b)
1988 {
1989   return gsl_ran_gamma (get_rng (), a, 1. / b);
1990 }
1991
1992 static double
1993 matrix_eval_PDF_LANDAU (double x)
1994 {
1995   return gsl_ran_landau_pdf (x);
1996 }
1997
1998 static double
1999 matrix_eval_RV_LANDAU (void)
2000 {
2001   return gsl_ran_landau (get_rng ());
2002 }
2003
2004 static double
2005 matrix_eval_CDF_LAPLACE (double x, double a, double b)
2006 {
2007   return gsl_cdf_laplace_P ((x - a) / b, 1);
2008 }
2009
2010 static double
2011 matrix_eval_IDF_LAPLACE (double P, double a, double b)
2012 {
2013   return a + b * gsl_cdf_laplace_Pinv (P, 1);
2014 }
2015
2016 static double
2017 matrix_eval_PDF_LAPLACE (double x, double a, double b)
2018 {
2019   return gsl_ran_laplace_pdf ((x - a) / b, 1);
2020 }
2021
2022 static double
2023 matrix_eval_RV_LAPLACE (double a, double b)
2024 {
2025   return a + b * gsl_ran_laplace (get_rng (), 1);
2026 }
2027
2028 static double
2029 matrix_eval_RV_LEVY (double c, double alpha)
2030 {
2031   return gsl_ran_levy (get_rng (), c, alpha);
2032 }
2033
2034 static double
2035 matrix_eval_RV_LVSKEW (double c, double alpha, double beta)
2036 {
2037   return gsl_ran_levy_skew (get_rng (), c, alpha, beta);
2038 }
2039
2040 static double
2041 matrix_eval_CDF_LOGISTIC (double x, double a, double b)
2042 {
2043   return gsl_cdf_logistic_P ((x - a) / b, 1);
2044 }
2045
2046 static double
2047 matrix_eval_IDF_LOGISTIC (double P, double a, double b)
2048 {
2049   return a + b * gsl_cdf_logistic_Pinv (P, 1);
2050 }
2051
2052 static double
2053 matrix_eval_PDF_LOGISTIC (double x, double a, double b)
2054 {
2055   return gsl_ran_logistic_pdf ((x - a) / b, 1) / b;
2056 }
2057
2058 static double
2059 matrix_eval_RV_LOGISTIC (double a, double b)
2060 {
2061   return a + b * gsl_ran_logistic (get_rng (), 1);
2062 }
2063
2064 static double
2065 matrix_eval_CDF_LNORMAL (double x, double m, double s)
2066 {
2067   return gsl_cdf_lognormal_P (x, log (m), s);
2068 }
2069
2070 static double
2071 matrix_eval_IDF_LNORMAL (double P, double m, double s)
2072 {
2073   return gsl_cdf_lognormal_Pinv (P, log (m), s);;
2074 }
2075
2076 static double
2077 matrix_eval_PDF_LNORMAL (double x, double m, double s)
2078 {
2079   return gsl_ran_lognormal_pdf (x, log (m), s);
2080 }
2081
2082 static double
2083 matrix_eval_RV_LNORMAL (double m, double s)
2084 {
2085   return gsl_ran_lognormal (get_rng (), log (m), s);
2086 }
2087
2088 static double
2089 matrix_eval_CDF_NORMAL (double x, double u, double s)
2090 {
2091   return gsl_cdf_gaussian_P (x - u, s);
2092 }
2093
2094 static double
2095 matrix_eval_IDF_NORMAL (double P, double u, double s)
2096 {
2097   return u + gsl_cdf_gaussian_Pinv (P, s);
2098 }
2099
2100 static double
2101 matrix_eval_PDF_NORMAL (double x, double u, double s)
2102 {
2103   return gsl_ran_gaussian_pdf ((x - u) / s, 1) / s;
2104 }
2105
2106 static double
2107 matrix_eval_RV_NORMAL (double u, double s)
2108 {
2109   return u + gsl_ran_gaussian (get_rng (), s);
2110 }
2111
2112 static double
2113 matrix_eval_CDFNORM (double x)
2114 {
2115   return gsl_cdf_ugaussian_P (x);
2116 }
2117
2118 static double
2119 matrix_eval_PROBIT (double P)
2120 {
2121   return gsl_cdf_ugaussian_Pinv (P);
2122 }
2123
2124 static double
2125 matrix_eval_NORMAL (double s)
2126 {
2127   return gsl_ran_gaussian (get_rng (), s);
2128 }
2129
2130 static double
2131 matrix_eval_PDF_NTAIL (double x, double a, double sigma)
2132 {
2133   return gsl_ran_gaussian_tail_pdf (x, a, sigma);;
2134 }
2135
2136 static double
2137 matrix_eval_RV_NTAIL (double a, double sigma)
2138 {
2139   return gsl_ran_gaussian_tail (get_rng (), a, sigma);
2140 }
2141
2142 static double
2143 matrix_eval_CDF_PARETO (double x, double a, double b)
2144 {
2145   return gsl_cdf_pareto_P (x, b, a);
2146 }
2147
2148 static double
2149 matrix_eval_IDF_PARETO (double P, double a, double b)
2150 {
2151   return gsl_cdf_pareto_Pinv (P, b, a);
2152 }
2153
2154 static double
2155 matrix_eval_PDF_PARETO (double x, double a, double b)
2156 {
2157   return gsl_ran_pareto_pdf (x, b, a);
2158 }
2159
2160 static double
2161 matrix_eval_RV_PARETO (double a, double b)
2162 {
2163   return gsl_ran_pareto (get_rng (), b, a);
2164 }
2165
2166 static double
2167 matrix_eval_CDF_RAYLEIGH (double x, double sigma)
2168 {
2169   return gsl_cdf_rayleigh_P (x, sigma);
2170 }
2171
2172 static double
2173 matrix_eval_IDF_RAYLEIGH (double P, double sigma)
2174 {
2175   return gsl_cdf_rayleigh_Pinv (P, sigma);
2176 }
2177
2178 static double
2179 matrix_eval_PDF_RAYLEIGH (double x, double sigma)
2180 {
2181   return gsl_ran_rayleigh_pdf (x, sigma);
2182 }
2183
2184 static double
2185 matrix_eval_RV_RAYLEIGH (double sigma)
2186 {
2187   return gsl_ran_rayleigh (get_rng (), sigma);
2188 }
2189
2190 static double
2191 matrix_eval_PDF_RTAIL (double x, double a, double sigma)
2192 {
2193   return gsl_ran_rayleigh_tail_pdf (x, a, sigma);
2194 }
2195
2196 static double
2197 matrix_eval_RV_RTAIL (double a, double sigma)
2198 {
2199   return gsl_ran_rayleigh_tail (get_rng (), a, sigma);
2200 }
2201
2202 static double
2203 matrix_eval_CDF_T (double x, double df)
2204 {
2205   return gsl_cdf_tdist_P (x, df);
2206 }
2207
2208 static double
2209 matrix_eval_TCDF (double x, double df)
2210 {
2211   return matrix_eval_CDF_T (x, df);
2212 }
2213
2214 static double
2215 matrix_eval_IDF_T (double P, double df)
2216 {
2217   return gsl_cdf_tdist_Pinv (P, df);
2218 }
2219
2220 static double
2221 matrix_eval_PDF_T (double x, double df)
2222 {
2223   return gsl_ran_tdist_pdf (x, df);
2224 }
2225
2226 static double
2227 matrix_eval_RV_T (double df)
2228 {
2229   return gsl_ran_tdist (get_rng (), df);
2230 }
2231
2232 static double
2233 matrix_eval_CDF_T1G (double x, double a, double b)
2234 {
2235   return gsl_cdf_gumbel1_P (x, a, b);
2236 }
2237
2238 static double
2239 matrix_eval_IDF_T1G (double P, double a, double b)
2240 {
2241   return gsl_cdf_gumbel1_Pinv (P, a, b);
2242 }
2243
2244 static double
2245 matrix_eval_PDF_T1G (double x, double a, double b)
2246 {
2247   return gsl_ran_gumbel1_pdf (x, a, b);
2248 }
2249
2250 static double
2251 matrix_eval_RV_T1G (double a, double b)
2252 {
2253   return gsl_ran_gumbel1 (get_rng (), a, b);
2254 }
2255
2256 static double
2257 matrix_eval_CDF_T2G (double x, double a, double b)
2258 {
2259   return gsl_cdf_gumbel1_P (x, a, b);
2260 }
2261
2262 static double
2263 matrix_eval_IDF_T2G (double P, double a, double b)
2264 {
2265   return gsl_cdf_gumbel1_Pinv (P, a, b);
2266 }
2267
2268 static double
2269 matrix_eval_PDF_T2G (double x, double a, double b)
2270 {
2271   return gsl_ran_gumbel1_pdf (x, a, b);
2272 }
2273
2274 static double
2275 matrix_eval_RV_T2G (double a, double b)
2276 {
2277   return gsl_ran_gumbel1 (get_rng (), a, b);
2278 }
2279
2280 static double
2281 matrix_eval_CDF_UNIFORM (double x, double a, double b)
2282 {
2283   return gsl_cdf_flat_P (x, a, b);
2284 }
2285
2286 static double
2287 matrix_eval_IDF_UNIFORM (double P, double a, double b)
2288 {
2289   return gsl_cdf_flat_Pinv (P, a, b);
2290 }
2291
2292 static double
2293 matrix_eval_PDF_UNIFORM (double x, double a, double b)
2294 {
2295   return gsl_ran_flat_pdf (x, a, b);
2296 }
2297
2298 static double
2299 matrix_eval_RV_UNIFORM (double a, double b)
2300 {
2301   return gsl_ran_flat (get_rng (), a, b);
2302 }
2303
2304 static double
2305 matrix_eval_CDF_WEIBULL (double x, double a, double b)
2306 {
2307   return gsl_cdf_weibull_P (x, a, b);
2308 }
2309
2310 static double
2311 matrix_eval_IDF_WEIBULL (double P, double a, double b)
2312 {
2313   return gsl_cdf_weibull_Pinv (P, a, b);
2314 }
2315
2316 static double
2317 matrix_eval_PDF_WEIBULL (double x, double a, double b)
2318 {
2319   return gsl_ran_weibull_pdf (x, a, b);
2320 }
2321
2322 static double
2323 matrix_eval_RV_WEIBULL (double a, double b)
2324 {
2325   return gsl_ran_weibull (get_rng (), a, b);
2326 }
2327
2328 static double
2329 matrix_eval_CDF_BERNOULLI (double k, double p)
2330 {
2331   return k ? 1 : 1 - p;
2332 }
2333
2334 static double
2335 matrix_eval_PDF_BERNOULLI (double k, double p)
2336 {
2337   return gsl_ran_bernoulli_pdf (k, p);
2338 }
2339
2340 static double
2341 matrix_eval_RV_BERNOULLI (double p)
2342 {
2343   return gsl_ran_bernoulli (get_rng (), p);
2344 }
2345
2346 static double
2347 matrix_eval_CDF_BINOM (double k, double n, double p)
2348 {
2349   return gsl_cdf_binomial_P (k, p, n);
2350 }
2351
2352 static double
2353 matrix_eval_PDF_BINOM (double k, double n, double p)
2354 {
2355   return gsl_ran_binomial_pdf (k, p, n);
2356 }
2357
2358 static double
2359 matrix_eval_RV_BINOM (double n, double p)
2360 {
2361   return gsl_ran_binomial (get_rng (), p, n);
2362 }
2363
2364 static double
2365 matrix_eval_CDF_GEOM (double k, double p)
2366 {
2367   return gsl_cdf_geometric_P (k, p);
2368 }
2369
2370 static double
2371 matrix_eval_PDF_GEOM (double k, double p)
2372 {
2373   return gsl_ran_geometric_pdf (k, p);
2374 }
2375
2376 static double
2377 matrix_eval_RV_GEOM (double p)
2378 {
2379   return gsl_ran_geometric (get_rng (), p);
2380 }
2381
2382 static double
2383 matrix_eval_CDF_HYPER (double k, double a, double b, double c)
2384 {
2385   return gsl_cdf_hypergeometric_P (k, c, a - c, b);
2386 }
2387
2388 static double
2389 matrix_eval_PDF_HYPER (double k, double a, double b, double c)
2390 {
2391   return gsl_ran_hypergeometric_pdf (k, c, a - c, b);
2392 }
2393
2394 static double
2395 matrix_eval_RV_HYPER (double a, double b, double c)
2396 {
2397   return gsl_ran_hypergeometric (get_rng (), c, a - c, b);
2398 }
2399
2400 static double
2401 matrix_eval_PDF_LOG (double k, double p)
2402 {
2403   return gsl_ran_logarithmic_pdf (k, p);
2404 }
2405
2406 static double
2407 matrix_eval_RV_LOG (double p)
2408 {
2409   return gsl_ran_logarithmic (get_rng (), p);
2410 }
2411
2412 static double
2413 matrix_eval_CDF_NEGBIN (double k, double n, double p)
2414 {
2415   return gsl_cdf_negative_binomial_P (k, p, n);
2416 }
2417
2418 static double
2419 matrix_eval_PDF_NEGBIN (double k, double n, double p)
2420 {
2421   return gsl_ran_negative_binomial_pdf (k, p, n);
2422 }
2423
2424 static double
2425 matrix_eval_RV_NEGBIN (double n, double p)
2426 {
2427   return gsl_ran_negative_binomial (get_rng (), p, n);
2428 }
2429
2430 static double
2431 matrix_eval_CDF_POISSON (double k, double mu)
2432 {
2433   return gsl_cdf_poisson_P (k, mu);
2434 }
2435
2436 static double
2437 matrix_eval_PDF_POISSON (double k, double mu)
2438 {
2439   return gsl_ran_poisson_pdf (k, mu);
2440 }
2441
2442 static double
2443 matrix_eval_RV_POISSON (double mu)
2444 {
2445   return gsl_ran_poisson (get_rng (), mu);
2446 }
2447
2448 struct matrix_function
2449   {
2450     const char *name;
2451     enum matrix_op op;
2452     size_t min_args, max_args;
2453   };
2454
2455 static struct matrix_expr *matrix_parse_expr (struct matrix_state *);
2456
2457 static bool
2458 word_matches (const char **test, const char **name)
2459 {
2460   size_t test_len = strcspn (*test, ".");
2461   size_t name_len = strcspn (*name, ".");
2462   if (test_len == name_len)
2463     {
2464       if (buf_compare_case (*test, *name, test_len))
2465         return false;
2466     }
2467   else if (test_len < 3 || test_len > name_len)
2468     return false;
2469   else
2470     {
2471       if (buf_compare_case (*test, *name, test_len))
2472         return false;
2473     }
2474
2475   *test += test_len;
2476   *name += name_len;
2477   if (**test != **name)
2478     return false;
2479
2480   if (**test == '.')
2481     {
2482       (*test)++;
2483       (*name)++;
2484     }
2485   return true;
2486 }
2487
2488 /* Returns 0 if TOKEN and FUNC do not match,
2489    1 if TOKEN is an acceptable abbreviation for FUNC,
2490    2 if TOKEN equals FUNC. */
2491 static int
2492 compare_function_names (const char *token_, const char *func_)
2493 {
2494   const char *token = token_;
2495   const char *func = func_;
2496   while (*token || *func)
2497     if (!word_matches (&token, &func))
2498       return 0;
2499   return !c_strcasecmp (token_, func_) ? 2 : 1;
2500 }
2501
2502 static const struct matrix_function *
2503 matrix_parse_function_name (const char *token)
2504 {
2505   static const struct matrix_function functions[] =
2506     {
2507 #define F(ENUM, STRING, PROTO, CONSTRAINTS)                             \
2508       { STRING, MOP_F_##ENUM, PROTO##_MIN_ARGS, PROTO##_MAX_ARGS },
2509       MATRIX_FUNCTIONS
2510 #undef F
2511     };
2512   enum { N_FUNCTIONS = sizeof functions / sizeof *functions };
2513
2514   for (size_t i = 0; i < N_FUNCTIONS; i++)
2515     {
2516       if (compare_function_names (token, functions[i].name) > 0)
2517         return &functions[i];
2518     }
2519   return NULL;
2520 }
2521
2522 static struct read_file *
2523 read_file_create (struct matrix_state *s, struct file_handle *fh)
2524 {
2525   for (size_t i = 0; i < s->n_read_files; i++)
2526     {
2527       struct read_file *rf = s->read_files[i];
2528       if (rf->file == fh)
2529         {
2530           fh_unref (fh);
2531           return rf;
2532         }
2533     }
2534
2535   struct read_file *rf = xmalloc (sizeof *rf);
2536   *rf = (struct read_file) { .file = fh };
2537
2538   s->read_files = xrealloc (s->read_files,
2539                             (s->n_read_files + 1) * sizeof *s->read_files);
2540   s->read_files[s->n_read_files++] = rf;
2541   return rf;
2542 }
2543
2544 static struct dfm_reader *
2545 read_file_open (struct read_file *rf)
2546 {
2547   if (!rf->reader)
2548     rf->reader = dfm_open_reader (rf->file, NULL, rf->encoding);
2549   return rf->reader;
2550 }
2551
2552 static void
2553 read_file_destroy (struct read_file *rf)
2554 {
2555   if (rf)
2556     {
2557       fh_unref (rf->file);
2558       dfm_close_reader (rf->reader);
2559       free (rf->encoding);
2560       free (rf);
2561     }
2562 }
2563
2564 static struct write_file *
2565 write_file_create (struct matrix_state *s, struct file_handle *fh)
2566 {
2567   for (size_t i = 0; i < s->n_write_files; i++)
2568     {
2569       struct write_file *wf = s->write_files[i];
2570       if (wf->file == fh)
2571         {
2572           fh_unref (fh);
2573           return wf;
2574         }
2575     }
2576
2577   struct write_file *wf = xmalloc (sizeof *wf);
2578   *wf = (struct write_file) { .file = fh };
2579
2580   s->write_files = xrealloc (s->write_files,
2581                              (s->n_write_files + 1) * sizeof *s->write_files);
2582   s->write_files[s->n_write_files++] = wf;
2583   return wf;
2584 }
2585
2586 static struct dfm_writer *
2587 write_file_open (struct write_file *wf)
2588 {
2589   if (!wf->writer)
2590     wf->writer = dfm_open_writer (wf->file, wf->encoding);
2591   return wf->writer;
2592 }
2593
2594 static void
2595 write_file_destroy (struct write_file *wf)
2596 {
2597   if (wf)
2598     {
2599       if (wf->held)
2600         {
2601           dfm_put_record_utf8 (wf->writer, wf->held->s.ss.string,
2602                                wf->held->s.ss.length);
2603           u8_line_destroy (wf->held);
2604           free (wf->held);
2605         }
2606
2607       fh_unref (wf->file);
2608       dfm_close_writer (wf->writer);
2609       free (wf->encoding);
2610       free (wf);
2611     }
2612 }
2613
2614 static bool
2615 matrix_parse_function (struct matrix_state *s, const char *token,
2616                        struct matrix_expr **exprp)
2617 {
2618   *exprp = NULL;
2619   if (lex_next_token (s->lexer, 1) != T_LPAREN)
2620     return false;
2621
2622   if (lex_match_id (s->lexer, "EOF"))
2623     {
2624       lex_get (s->lexer);
2625       struct file_handle *fh = fh_parse (s->lexer, FH_REF_FILE, s->session);
2626       if (!fh)
2627         return true;
2628
2629       if (!lex_force_match (s->lexer, T_RPAREN))
2630         {
2631           fh_unref (fh);
2632           return true;
2633         }
2634
2635       struct read_file *rf = read_file_create (s, fh);
2636
2637       struct matrix_expr *e = xmalloc (sizeof *e);
2638       *e = (struct matrix_expr) { .op = MOP_EOF, .eof = rf };
2639       *exprp = e;
2640       return true;
2641     }
2642
2643   const struct matrix_function *f = matrix_parse_function_name (token);
2644   if (!f)
2645     return false;
2646
2647   struct matrix_expr *e = xmalloc (sizeof *e);
2648   *e = (struct matrix_expr) {
2649     .op = f->op,
2650     .location = lex_get_location (s->lexer, 0, 0)
2651   };
2652
2653   lex_get_n (s->lexer, 2);
2654   if (lex_token (s->lexer) != T_RPAREN)
2655     {
2656       size_t allocated_subs = 0;
2657       do
2658         {
2659           struct msg_location *arg_location = lex_get_location (s->lexer, 0, 0);
2660           struct matrix_expr *sub = matrix_parse_expr (s);
2661           if (!sub)
2662             {
2663               msg_location_destroy (arg_location);
2664               goto error;
2665             }
2666           if (!sub->location)
2667             {
2668               //lex_extend_location (s->lexer, 0, arg_location);
2669               sub->location = arg_location;
2670             }
2671           else
2672             msg_location_destroy (arg_location);
2673
2674           if (e->n_subs >= allocated_subs)
2675             e->subs = x2nrealloc (e->subs, &allocated_subs, sizeof *e->subs);
2676           e->subs[e->n_subs++] = sub;
2677         }
2678       while (lex_match (s->lexer, T_COMMA));
2679     }
2680   if (!lex_force_match (s->lexer, T_RPAREN))
2681     goto error;
2682
2683   if (e->n_subs < f->min_args || e->n_subs > f->max_args)
2684     {
2685       if (f->min_args == f->max_args)
2686         msg (SE, ngettext ("Matrix function %s requires %zu argument.",
2687                            "Matrix function %s requires %zu arguments.",
2688                            f->min_args),
2689              f->name, f->min_args);
2690       else if (f->min_args == 1 && f->max_args == 2)
2691         msg (SE, ngettext ("Matrix function %s requires 1 or 2 arguments, "
2692                            "but %zu was provided.",
2693                            "Matrix function %s requires 1 or 2 arguments, "
2694                            "but %zu were provided.",
2695                            e->n_subs),
2696              f->name, e->n_subs);
2697       else if (f->min_args == 1 && f->max_args == INT_MAX)
2698         msg (SE, _("Matrix function %s requires at least one argument."),
2699              f->name);
2700       else
2701         NOT_REACHED ();
2702
2703       goto error;
2704     }
2705
2706   *exprp = e;
2707   return true;
2708
2709 error:
2710   matrix_expr_destroy (e);
2711   return true;
2712 }
2713
2714 static struct matrix_expr *
2715 matrix_parse_primary (struct matrix_state *s)
2716 {
2717   if (lex_is_number (s->lexer))
2718     {
2719       double number = lex_number (s->lexer);
2720       return matrix_expr_create_number (s->lexer, number);
2721     }
2722   else if (lex_is_string (s->lexer))
2723     {
2724       char string[sizeof (double)];
2725       buf_copy_str_rpad (string, sizeof string, lex_tokcstr (s->lexer), ' ');
2726
2727       double number;
2728       memcpy (&number, string, sizeof number);
2729       return matrix_expr_create_number (s->lexer, number);
2730     }
2731   else if (lex_match (s->lexer, T_LPAREN))
2732     {
2733       struct matrix_expr *e = matrix_parse_or_xor (s);
2734       if (!e || !lex_force_match (s->lexer, T_RPAREN))
2735         {
2736           matrix_expr_destroy (e);
2737           return NULL;
2738         }
2739       return e;
2740     }
2741   else if (lex_match (s->lexer, T_LCURLY))
2742     {
2743       struct matrix_expr *e = matrix_parse_curly_semi (s);
2744       if (!e || !lex_force_match (s->lexer, T_RCURLY))
2745         {
2746           matrix_expr_destroy (e);
2747           return NULL;
2748         }
2749       return e;
2750     }
2751   else if (lex_token (s->lexer) == T_ID)
2752     {
2753       struct matrix_expr *retval;
2754       if (matrix_parse_function (s, lex_tokcstr (s->lexer), &retval))
2755         return retval;
2756
2757       struct matrix_var *var = matrix_var_lookup (s, lex_tokss (s->lexer));
2758       if (!var)
2759         {
2760           lex_error (s->lexer, _("Unknown variable %s."),
2761                      lex_tokcstr (s->lexer));
2762           return NULL;
2763         }
2764       lex_get (s->lexer);
2765
2766       struct matrix_expr *e = xmalloc (sizeof *e);
2767       *e = (struct matrix_expr) { .op = MOP_VARIABLE, .variable = var };
2768       return e;
2769     }
2770   else if (lex_token (s->lexer) == T_ALL)
2771     {
2772       struct matrix_expr *retval;
2773       if (matrix_parse_function (s, "ALL", &retval))
2774         return retval;
2775     }
2776
2777   lex_error (s->lexer, NULL);
2778   return NULL;
2779 }
2780
2781 static struct matrix_expr *matrix_parse_postfix (struct matrix_state *);
2782
2783 static bool
2784 matrix_parse_index_expr (struct matrix_state *s, struct matrix_expr **indexp)
2785 {
2786   if (lex_match (s->lexer, T_COLON))
2787     {
2788       *indexp = NULL;
2789       return true;
2790     }
2791   else
2792     {
2793       *indexp = matrix_parse_expr (s);
2794       return *indexp != NULL;
2795     }
2796 }
2797
2798 static struct matrix_expr *
2799 matrix_parse_postfix (struct matrix_state *s)
2800 {
2801   struct matrix_expr *lhs = matrix_parse_primary (s);
2802   if (!lhs || !lex_match (s->lexer, T_LPAREN))
2803     return lhs;
2804
2805   struct matrix_expr *i0;
2806   if (!matrix_parse_index_expr (s, &i0))
2807     {
2808       matrix_expr_destroy (lhs);
2809       return NULL;
2810     }
2811   if (lex_match (s->lexer, T_RPAREN))
2812     return (i0
2813             ? matrix_expr_create_2 (MOP_VEC_INDEX, lhs, i0)
2814             : matrix_expr_create_1 (MOP_VEC_ALL, lhs));
2815   else if (lex_match (s->lexer, T_COMMA))
2816     {
2817       struct matrix_expr *i1;
2818       if (!matrix_parse_index_expr (s, &i1)
2819           || !lex_force_match (s->lexer, T_RPAREN))
2820         {
2821           matrix_expr_destroy (lhs);
2822           matrix_expr_destroy (i0);
2823           matrix_expr_destroy (i1);
2824           return NULL;
2825         }
2826       return (i0 && i1 ? matrix_expr_create_3 (MOP_MAT_INDEX, lhs, i0, i1)
2827               : i0 ? matrix_expr_create_2 (MOP_ROW_INDEX, lhs, i0)
2828               : i1 ? matrix_expr_create_2 (MOP_COL_INDEX, lhs, i1)
2829               : lhs);
2830     }
2831   else
2832     {
2833       lex_error_expecting (s->lexer, "`)'", "`,'");
2834       return NULL;
2835     }
2836 }
2837
2838 static struct matrix_expr *
2839 matrix_parse_unary (struct matrix_state *s)
2840 {
2841   if (lex_match (s->lexer, T_DASH))
2842     {
2843       struct matrix_expr *lhs = matrix_parse_unary (s);
2844       return lhs ? matrix_expr_create_1 (MOP_NEGATE, lhs) : NULL;
2845     }
2846   else if (lex_match (s->lexer, T_PLUS))
2847     return matrix_parse_unary (s);
2848   else
2849     return matrix_parse_postfix (s);
2850 }
2851
2852 static struct matrix_expr *
2853 matrix_parse_seq (struct matrix_state *s)
2854 {
2855   struct matrix_expr *start = matrix_parse_unary (s);
2856   if (!start || !lex_match (s->lexer, T_COLON))
2857     return start;
2858
2859   struct matrix_expr *end = matrix_parse_unary (s);
2860   if (!end)
2861     {
2862       matrix_expr_destroy (start);
2863       return NULL;
2864     }
2865
2866   if (lex_match (s->lexer, T_COLON))
2867     {
2868       struct matrix_expr *increment = matrix_parse_unary (s);
2869       if (!increment)
2870         {
2871           matrix_expr_destroy (start);
2872           matrix_expr_destroy (end);
2873           return NULL;
2874         }
2875       return matrix_expr_create_3 (MOP_SEQ_BY, start, end, increment);
2876     }
2877   else
2878     return matrix_expr_create_2 (MOP_SEQ, start, end);
2879 }
2880
2881 static struct matrix_expr *
2882 matrix_parse_exp (struct matrix_state *s)
2883 {
2884   struct matrix_expr *lhs = matrix_parse_seq (s);
2885   if (!lhs)
2886     return NULL;
2887
2888   for (;;)
2889     {
2890       enum matrix_op op;
2891       if (lex_match (s->lexer, T_EXP))
2892         op = MOP_EXP_MAT;
2893       else if (lex_match_phrase (s->lexer, "&**"))
2894         op = MOP_EXP_ELEMS;
2895       else
2896         return lhs;
2897
2898       struct matrix_expr *rhs = matrix_parse_seq (s);
2899       if (!rhs)
2900         {
2901           matrix_expr_destroy (lhs);
2902           return NULL;
2903         }
2904       lhs = matrix_expr_create_2 (op, lhs, rhs);
2905     }
2906 }
2907
2908 static struct matrix_expr *
2909 matrix_parse_mul_div (struct matrix_state *s)
2910 {
2911   struct matrix_expr *lhs = matrix_parse_exp (s);
2912   if (!lhs)
2913     return NULL;
2914
2915   for (;;)
2916     {
2917       enum matrix_op op;
2918       if (lex_match (s->lexer, T_ASTERISK))
2919         op = MOP_MUL_MAT;
2920       else if (lex_match (s->lexer, T_SLASH))
2921         op = MOP_DIV_ELEMS;
2922       else if (lex_match_phrase (s->lexer, "&*"))
2923         op = MOP_MUL_ELEMS;
2924       else if (lex_match_phrase (s->lexer, "&/"))
2925         op = MOP_DIV_ELEMS;
2926       else
2927         return lhs;
2928
2929       struct matrix_expr *rhs = matrix_parse_exp (s);
2930       if (!rhs)
2931         {
2932           matrix_expr_destroy (lhs);
2933           return NULL;
2934         }
2935       lhs = matrix_expr_create_2 (op, lhs, rhs);
2936     }
2937 }
2938
2939 static struct matrix_expr *
2940 matrix_parse_add_sub (struct matrix_state *s)
2941 {
2942   struct matrix_expr *lhs = matrix_parse_mul_div (s);
2943   if (!lhs)
2944     return NULL;
2945
2946   for (;;)
2947     {
2948       enum matrix_op op;
2949       if (lex_match (s->lexer, T_PLUS))
2950         op = MOP_ADD_ELEMS;
2951       else if (lex_match (s->lexer, T_DASH))
2952         op = MOP_SUB_ELEMS;
2953       else if (lex_token (s->lexer) == T_NEG_NUM)
2954         op = MOP_ADD_ELEMS;
2955       else
2956         return lhs;
2957
2958       struct matrix_expr *rhs = matrix_parse_mul_div (s);
2959       if (!rhs)
2960         {
2961           matrix_expr_destroy (lhs);
2962           return NULL;
2963         }
2964       lhs = matrix_expr_create_2 (op, lhs, rhs);
2965     }
2966 }
2967
2968 static struct matrix_expr *
2969 matrix_parse_relational (struct matrix_state *s)
2970 {
2971   struct matrix_expr *lhs = matrix_parse_add_sub (s);
2972   if (!lhs)
2973     return NULL;
2974
2975   for (;;)
2976     {
2977       enum matrix_op op;
2978       if (lex_match (s->lexer, T_GT))
2979         op = MOP_GT;
2980       else if (lex_match (s->lexer, T_GE))
2981         op = MOP_GE;
2982       else if (lex_match (s->lexer, T_LT))
2983         op = MOP_LT;
2984       else if (lex_match (s->lexer, T_LE))
2985         op = MOP_LE;
2986       else if (lex_match (s->lexer, T_EQUALS) || lex_match (s->lexer, T_EQ))
2987         op = MOP_EQ;
2988       else if (lex_match (s->lexer, T_NE))
2989         op = MOP_NE;
2990       else
2991         return lhs;
2992
2993       struct matrix_expr *rhs = matrix_parse_add_sub (s);
2994       if (!rhs)
2995         {
2996           matrix_expr_destroy (lhs);
2997           return NULL;
2998         }
2999       lhs = matrix_expr_create_2 (op, lhs, rhs);
3000     }
3001 }
3002
3003 static struct matrix_expr *
3004 matrix_parse_not (struct matrix_state *s)
3005 {
3006   if (lex_match (s->lexer, T_NOT))
3007     {
3008       struct matrix_expr *lhs = matrix_parse_not (s);
3009       return lhs ? matrix_expr_create_1 (MOP_NOT, lhs) : NULL;
3010     }
3011   else
3012     return matrix_parse_relational (s);
3013 }
3014
3015 static struct matrix_expr *
3016 matrix_parse_and (struct matrix_state *s)
3017 {
3018   struct matrix_expr *lhs = matrix_parse_not (s);
3019   if (!lhs)
3020     return NULL;
3021
3022   while (lex_match (s->lexer, T_AND))
3023     {
3024       struct matrix_expr *rhs = matrix_parse_not (s);
3025       if (!rhs)
3026         {
3027           matrix_expr_destroy (lhs);
3028           return NULL;
3029         }
3030       lhs = matrix_expr_create_2 (MOP_AND, lhs, rhs);
3031     }
3032   return lhs;
3033 }
3034
3035 static struct matrix_expr *
3036 matrix_parse_or_xor (struct matrix_state *s)
3037 {
3038   struct matrix_expr *lhs = matrix_parse_and (s);
3039   if (!lhs)
3040     return NULL;
3041
3042   for (;;)
3043     {
3044       enum matrix_op op;
3045       if (lex_match (s->lexer, T_OR))
3046         op = MOP_OR;
3047       else if (lex_match_id (s->lexer, "XOR"))
3048         op = MOP_XOR;
3049       else
3050         return lhs;
3051
3052       struct matrix_expr *rhs = matrix_parse_and (s);
3053       if (!rhs)
3054         {
3055           matrix_expr_destroy (lhs);
3056           return NULL;
3057         }
3058       lhs = matrix_expr_create_2 (op, lhs, rhs);
3059     }
3060 }
3061
3062 static struct matrix_expr *
3063 matrix_parse_expr (struct matrix_state *s)
3064 {
3065   return matrix_parse_or_xor (s);
3066 }
3067 \f
3068 /* Expression evaluation. */
3069
3070 static double
3071 matrix_op_eval (enum matrix_op op, double a, double b)
3072 {
3073   switch (op)
3074     {
3075     case MOP_ADD_ELEMS: return a + b;
3076     case MOP_SUB_ELEMS: return a - b;
3077     case MOP_MUL_ELEMS: return a * b;
3078     case MOP_DIV_ELEMS: return a / b;
3079     case MOP_EXP_ELEMS: return pow (a, b);
3080     case MOP_GT: return a > b;
3081     case MOP_GE: return a >= b;
3082     case MOP_LT: return a < b;
3083     case MOP_LE: return a <= b;
3084     case MOP_EQ: return a == b;
3085     case MOP_NE: return a != b;
3086     case MOP_AND: return (a > 0) && (b > 0);
3087     case MOP_OR: return (a > 0) || (b > 0);
3088     case MOP_XOR: return (a > 0) != (b > 0);
3089
3090 #define F(ENUM, STRING, PROTO, CONSTRAINTS) case MOP_F_##ENUM:
3091       MATRIX_FUNCTIONS
3092 #undef F
3093     case MOP_NEGATE:
3094     case MOP_SEQ:
3095     case MOP_SEQ_BY:
3096     case MOP_MUL_MAT:
3097     case MOP_EXP_MAT:
3098     case MOP_NOT:
3099     case MOP_PASTE_HORZ:
3100     case MOP_PASTE_VERT:
3101     case MOP_EMPTY:
3102     case MOP_VEC_INDEX:
3103     case MOP_VEC_ALL:
3104     case MOP_MAT_INDEX:
3105     case MOP_ROW_INDEX:
3106     case MOP_COL_INDEX:
3107     case MOP_NUMBER:
3108     case MOP_VARIABLE:
3109     case MOP_EOF:
3110       NOT_REACHED ();
3111     }
3112   NOT_REACHED ();
3113 }
3114
3115 static const char *
3116 matrix_op_name (enum matrix_op op)
3117 {
3118   switch (op)
3119     {
3120     case MOP_ADD_ELEMS: return "+";
3121     case MOP_SUB_ELEMS: return "-";
3122     case MOP_MUL_ELEMS: return "&*";
3123     case MOP_DIV_ELEMS: return "&/";
3124     case MOP_EXP_ELEMS: return "&**";
3125     case MOP_GT: return ">";
3126     case MOP_GE: return ">=";
3127     case MOP_LT: return "<";
3128     case MOP_LE: return "<=";
3129     case MOP_EQ: return "=";
3130     case MOP_NE: return "<>";
3131     case MOP_AND: return "AND";
3132     case MOP_OR: return "OR";
3133     case MOP_XOR: return "XOR";
3134
3135 #define F(ENUM, STRING, PROTO, CONSTRAINTS) case MOP_F_##ENUM:
3136       MATRIX_FUNCTIONS
3137 #undef F
3138     case MOP_NEGATE:
3139     case MOP_SEQ:
3140     case MOP_SEQ_BY:
3141     case MOP_MUL_MAT:
3142     case MOP_EXP_MAT:
3143     case MOP_NOT:
3144     case MOP_PASTE_HORZ:
3145     case MOP_PASTE_VERT:
3146     case MOP_EMPTY:
3147     case MOP_VEC_INDEX:
3148     case MOP_VEC_ALL:
3149     case MOP_MAT_INDEX:
3150     case MOP_ROW_INDEX:
3151     case MOP_COL_INDEX:
3152     case MOP_NUMBER:
3153     case MOP_VARIABLE:
3154     case MOP_EOF:
3155       NOT_REACHED ();
3156     }
3157   NOT_REACHED ();
3158 }
3159
3160 static bool
3161 is_scalar (const gsl_matrix *m)
3162 {
3163   return m->size1 == 1 && m->size2 == 1;
3164 }
3165
3166 static double
3167 to_scalar (const gsl_matrix *m)
3168 {
3169   assert (is_scalar (m));
3170   return gsl_matrix_get (m, 0, 0);
3171 }
3172
3173 static gsl_matrix *
3174 matrix_expr_evaluate_elementwise (enum matrix_op op,
3175                                   gsl_matrix *a, gsl_matrix *b)
3176 {
3177   if (is_scalar (b))
3178     {
3179       double be = to_scalar (b);
3180       for (size_t r = 0; r < a->size1; r++)
3181         for (size_t c = 0; c < a->size2; c++)
3182           {
3183             double *ae = gsl_matrix_ptr (a, r, c);
3184             *ae = matrix_op_eval (op, *ae, be);
3185           }
3186       return a;
3187     }
3188   else if (is_scalar (a))
3189     {
3190       double ae = to_scalar (a);
3191       for (size_t r = 0; r < b->size1; r++)
3192         for (size_t c = 0; c < b->size2; c++)
3193           {
3194             double *be = gsl_matrix_ptr (b, r, c);
3195             *be = matrix_op_eval (op, ae, *be);
3196           }
3197       return b;
3198     }
3199   else if (a->size1 == b->size1 && a->size2 == b->size2)
3200     {
3201       for (size_t r = 0; r < a->size1; r++)
3202         for (size_t c = 0; c < a->size2; c++)
3203           {
3204             double *ae = gsl_matrix_ptr (a, r, c);
3205             double be = gsl_matrix_get (b, r, c);
3206             *ae = matrix_op_eval (op, *ae, be);
3207           }
3208       return a;
3209     }
3210   else
3211     {
3212       msg (SE, _("Operands to %s must have the same dimensions or one "
3213                  "must be a scalar, not %zu×%zu and %zu×%zu matrices."),
3214            matrix_op_name (op), a->size1, a->size2, b->size1, b->size2);
3215       return NULL;
3216     }
3217 }
3218
3219 static gsl_matrix *
3220 matrix_expr_evaluate_mul_mat (gsl_matrix *a, gsl_matrix *b)
3221 {
3222   if (is_scalar (a) || is_scalar (b))
3223     return matrix_expr_evaluate_elementwise (MOP_MUL_ELEMS, a, b);
3224
3225   if (a->size2 != b->size1)
3226     {
3227       msg (SE, _("Matrices with dimensions %zu×%zu and %zu×%zu are "
3228                  "not conformable for multiplication."),
3229            a->size1, a->size2, b->size1, b->size2);
3230       return NULL;
3231     }
3232
3233   gsl_matrix *c = gsl_matrix_alloc (a->size1, b->size2);
3234   gsl_blas_dgemm (CblasNoTrans, CblasNoTrans, 1.0, a, b, 0.0, c);
3235   return c;
3236 }
3237
3238 static void
3239 swap_matrix (gsl_matrix **a, gsl_matrix **b)
3240 {
3241   gsl_matrix *tmp = *a;
3242   *a = *b;
3243   *b = tmp;
3244 }
3245
3246 static void
3247 mul_matrix (gsl_matrix **z, const gsl_matrix *x, const gsl_matrix *y,
3248             gsl_matrix **tmp)
3249 {
3250   gsl_blas_dgemm (CblasNoTrans, CblasNoTrans, 1.0, x, y, 0.0, *tmp);
3251   swap_matrix (z, tmp);
3252 }
3253
3254 static void
3255 square_matrix (gsl_matrix **x, gsl_matrix **tmp)
3256 {
3257   mul_matrix (x, *x, *x, tmp);
3258 }
3259
3260 static gsl_matrix *
3261 matrix_expr_evaluate_exp_mat (gsl_matrix *x_, gsl_matrix *b)
3262 {
3263   gsl_matrix *x = x_;
3264   if (x->size1 != x->size2)
3265     {
3266       msg (SE, _("Matrix exponentation with ** requires a square matrix on "
3267                  "the left-hand size, not one with dimensions %zu×%zu."),
3268            x->size1, x->size2);
3269       return NULL;
3270     }
3271   if (!is_scalar (b))
3272     {
3273       msg (SE, _("Matrix exponentiation with ** requires a scalar on the "
3274                  "right-hand side, not a matrix with dimensions %zu×%zu."),
3275            b->size1, b->size2);
3276       return NULL;
3277     }
3278   double bf = to_scalar (b);
3279   if (bf != floor (bf) || bf <= LONG_MIN || bf > LONG_MAX)
3280     {
3281       msg (SE, _("Exponent %.1f in matrix multiplication is non-integer "
3282                  "or outside the valid range."), bf);
3283       return NULL;
3284     }
3285   long int bl = bf;
3286
3287   gsl_matrix *y_ = gsl_matrix_alloc (x->size1, x->size2);
3288   gsl_matrix *y = y_;
3289   gsl_matrix_set_identity (y);
3290   if (bl == 0)
3291     return y;
3292
3293   gsl_matrix *t_ = gsl_matrix_alloc (x->size1, x->size2);
3294   gsl_matrix *t = t_;
3295   for (unsigned long int n = labs (bl); n > 1; n /= 2)
3296     if (n & 1)
3297       {
3298         mul_matrix (&y, x, y, &t);
3299         square_matrix (&x, &t);
3300       }
3301     else
3302       square_matrix (&x, &t);
3303
3304   mul_matrix (&y, x, y, &t);
3305   if (bf < 0)
3306     invert_matrix (y);
3307
3308   /* Garbage collection.
3309
3310      There are three matrices: 'x_', 'y_', and 't_', and 'x', 'y', and 't' are
3311      a permutation of them.  We are returning one of them; that one must not be
3312      destroyed.  We must not destroy 'x_' because the caller owns it. */
3313   if (y != y_)
3314     gsl_matrix_free (y_);
3315   if (y != t_)
3316     gsl_matrix_free (t_);
3317
3318   return y;
3319 }
3320
3321 static gsl_matrix *
3322 matrix_expr_evaluate_seq (gsl_matrix *start_, gsl_matrix *end_,
3323                           gsl_matrix *by_)
3324 {
3325   if (!is_scalar (start_) || !is_scalar (end_) || (by_ && !is_scalar (by_)))
3326     {
3327       msg (SE, _("All operands of : operator must be scalars."));
3328       return NULL;
3329     }
3330
3331   long int start = to_scalar (start_);
3332   long int end = to_scalar (end_);
3333   long int by = by_ ? to_scalar (by_) : 1;
3334
3335   if (!by)
3336     {
3337       msg (SE, _("The increment operand to : must be nonzero."));
3338       return NULL;
3339     }
3340
3341   long int n = (end >= start && by > 0 ? (end - start + by) / by
3342                 : end <= start && by < 0 ? (start - end - by) / -by
3343                 : 0);
3344   gsl_matrix *m = gsl_matrix_alloc (1, n);
3345   for (long int i = 0; i < n; i++)
3346     gsl_matrix_set (m, 0, i, start + i * by);
3347   return m;
3348 }
3349
3350 static gsl_matrix *
3351 matrix_expr_evaluate_not (gsl_matrix *a)
3352 {
3353   for (size_t r = 0; r < a->size1; r++)
3354     for (size_t c = 0; c < a->size2; c++)
3355       {
3356         double *ae = gsl_matrix_ptr (a, r, c);
3357         *ae = !(*ae > 0);
3358       }
3359   return a;
3360 }
3361
3362 static gsl_matrix *
3363 matrix_expr_evaluate_paste_horz (gsl_matrix *a, gsl_matrix *b)
3364 {
3365   if (a->size1 != b->size1)
3366     {
3367       if (!a->size1 || !a->size2)
3368         return b;
3369       else if (!b->size1 || !b->size2)
3370         return a;
3371
3372       msg (SE, _("All columns in a matrix must have the same number of rows, "
3373                  "but this tries to paste matrices with %zu and %zu rows."),
3374            a->size1, b->size1);
3375       return NULL;
3376     }
3377
3378   gsl_matrix *c = gsl_matrix_alloc (a->size1, a->size2 + b->size2);
3379   for (size_t y = 0; y < a->size1; y++)
3380     {
3381       for (size_t x = 0; x < a->size2; x++)
3382         gsl_matrix_set (c, y, x, gsl_matrix_get (a, y, x));
3383       for (size_t x = 0; x < b->size2; x++)
3384         gsl_matrix_set (c, y, x + a->size2, gsl_matrix_get (b, y, x));
3385     }
3386   return c;
3387 }
3388
3389 static gsl_matrix *
3390 matrix_expr_evaluate_paste_vert (gsl_matrix *a, gsl_matrix *b)
3391 {
3392   if (a->size2 != b->size2)
3393     {
3394       if (!a->size1 || !a->size2)
3395         return b;
3396       else if (!b->size1 || !b->size2)
3397         return a;
3398
3399       msg (SE, _("All rows in a matrix must have the same number of columns, "
3400                  "but this tries to stack matrices with %zu and %zu columns."),
3401            a->size2, b->size2);
3402       return NULL;
3403     }
3404
3405   gsl_matrix *c = gsl_matrix_alloc (a->size1 + b->size1, a->size2);
3406   for (size_t x = 0; x < a->size2; x++)
3407     {
3408       for (size_t y = 0; y < a->size1; y++)
3409         gsl_matrix_set (c, y, x, gsl_matrix_get (a, y, x));
3410       for (size_t y = 0; y < b->size1; y++)
3411         gsl_matrix_set (c, y + a->size1, x, gsl_matrix_get (b, y, x));
3412     }
3413   return c;
3414 }
3415
3416 static gsl_vector *
3417 matrix_to_vector (gsl_matrix *m)
3418 {
3419   assert (m->owner);
3420   gsl_vector v = to_vector (m);
3421   assert (v.block == m->block || !v.block);
3422   assert (!v.owner);
3423   v.owner = 1;
3424   m->owner = 0;
3425   gsl_matrix_free (m);
3426   return xmemdup (&v, sizeof v);
3427 }
3428
3429 enum index_type {
3430   IV_ROW,
3431   IV_COLUMN,
3432   IV_VECTOR
3433 };
3434
3435 struct index_vector
3436   {
3437     size_t *indexes;
3438     size_t n;
3439   };
3440 #define INDEX_VECTOR_INIT (struct index_vector) { .n = 0 }
3441
3442 static bool
3443 matrix_normalize_index_vector (const gsl_matrix *m, size_t size,
3444                                enum index_type index_type, size_t other_size,
3445                                struct index_vector *iv)
3446 {
3447   if (m)
3448     {
3449       if (!is_vector (m))
3450         {
3451           switch (index_type)
3452             {
3453             case IV_VECTOR:
3454               msg (SE, _("Vector index must be scalar or vector, not a "
3455                          "%zu×%zu matrix."),
3456                    m->size1, m->size2);
3457               break;
3458
3459             case IV_ROW:
3460               msg (SE, _("Matrix row index must be scalar or vector, not a "
3461                          "%zu×%zu matrix."),
3462                    m->size1, m->size2);
3463               break;
3464
3465             case IV_COLUMN:
3466               msg (SE, _("Matrix column index must be scalar or vector, not a "
3467                          "%zu×%zu matrix."),
3468                    m->size1, m->size2);
3469               break;
3470             }
3471           return false;
3472         }
3473
3474       gsl_vector v = to_vector (CONST_CAST (gsl_matrix *, m));
3475       *iv = (struct index_vector) {
3476         .indexes = xnmalloc (v.size, sizeof *iv->indexes),
3477         .n = v.size,
3478       };
3479       for (size_t i = 0; i < v.size; i++)
3480         {
3481           double index = gsl_vector_get (&v, i);
3482           if (index < 1 || index >= size + 1)
3483             {
3484               switch (index_type)
3485                 {
3486                 case IV_VECTOR:
3487                   msg (SE, _("Index %g is out of range for vector "
3488                              "with %zu elements."), index, size);
3489                   break;
3490
3491                 case IV_ROW:
3492                   msg (SE, _("%g is not a valid row index for "
3493                              "a %zu×%zu matrix."),
3494                        index, size, other_size);
3495                   break;
3496
3497                 case IV_COLUMN:
3498                   msg (SE, _("%g is not a valid column index for "
3499                              "a %zu×%zu matrix."),
3500                        index, other_size, size);
3501                   break;
3502                 }
3503
3504               free (iv->indexes);
3505               return false;
3506             }
3507           iv->indexes[i] = index - 1;
3508         }
3509       return true;
3510     }
3511   else
3512     {
3513       *iv = (struct index_vector) {
3514         .indexes = xnmalloc (size, sizeof *iv->indexes),
3515         .n = size,
3516       };
3517       for (size_t i = 0; i < size; i++)
3518         iv->indexes[i] = i;
3519       return true;
3520     }
3521 }
3522
3523 static gsl_matrix *
3524 matrix_expr_evaluate_vec_all (gsl_matrix *sm)
3525 {
3526   if (!is_vector (sm))
3527     {
3528       msg (SE, _("Vector index operator may not be applied to "
3529                  "a %zu×%zu matrix."),
3530            sm->size1, sm->size2);
3531       return NULL;
3532     }
3533
3534   return sm;
3535 }
3536
3537 static gsl_matrix *
3538 matrix_expr_evaluate_vec_index (gsl_matrix *sm, gsl_matrix *im)
3539 {
3540   if (!matrix_expr_evaluate_vec_all (sm))
3541     return NULL;
3542
3543   gsl_vector sv = to_vector (sm);
3544   struct index_vector iv;
3545   if (!matrix_normalize_index_vector (im, sv.size, IV_VECTOR, 0, &iv))
3546     return NULL;
3547
3548   gsl_matrix *dm = gsl_matrix_alloc (sm->size1 == 1 ? 1 : iv.n,
3549                                      sm->size1 == 1 ? iv.n : 1);
3550   gsl_vector dv = to_vector (dm);
3551   for (size_t dx = 0; dx < iv.n; dx++)
3552     {
3553       size_t sx = iv.indexes[dx];
3554       gsl_vector_set (&dv, dx, gsl_vector_get (&sv, sx));
3555     }
3556   free (iv.indexes);
3557
3558   return dm;
3559 }
3560
3561 static gsl_matrix *
3562 matrix_expr_evaluate_mat_index (gsl_matrix *sm, gsl_matrix *im0,
3563                                 gsl_matrix *im1)
3564 {
3565   struct index_vector iv0;
3566   if (!matrix_normalize_index_vector (im0, sm->size1, IV_ROW, sm->size2, &iv0))
3567     return NULL;
3568
3569   struct index_vector iv1;
3570   if (!matrix_normalize_index_vector (im1, sm->size2, IV_COLUMN, sm->size1,
3571                                       &iv1))
3572     {
3573       free (iv0.indexes);
3574       return NULL;
3575     }
3576
3577   gsl_matrix *dm = gsl_matrix_alloc (iv0.n, iv1.n);
3578   for (size_t dy = 0; dy < iv0.n; dy++)
3579     {
3580       size_t sy = iv0.indexes[dy];
3581
3582       for (size_t dx = 0; dx < iv1.n; dx++)
3583         {
3584           size_t sx = iv1.indexes[dx];
3585           gsl_matrix_set (dm, dy, dx, gsl_matrix_get (sm, sy, sx));
3586         }
3587     }
3588   free (iv0.indexes);
3589   free (iv1.indexes);
3590   return dm;
3591 }
3592
3593 #define F(ENUM, STRING, PROTO, CONSTRAINTS)                     \
3594   static gsl_matrix *matrix_expr_evaluate_##PROTO (             \
3595     const struct matrix_function_properties *, gsl_matrix *[],  \
3596     const struct matrix_expr *, matrix_proto_##PROTO *);
3597 MATRIX_FUNCTIONS
3598 #undef F
3599
3600 static bool
3601 check_scalar_arg (const char *name, gsl_matrix *subs[], size_t index)
3602 {
3603   if (!is_scalar (subs[index]))
3604     {
3605       msg (SE, _("Function %s argument %zu must be a scalar, "
3606                  "not a %zu×%zu matrix."),
3607            name, index + 1, subs[index]->size1, subs[index]->size2);
3608       return false;
3609     }
3610   return true;
3611 }
3612
3613 static bool
3614 check_vector_arg (const char *name, gsl_matrix *subs[], size_t index)
3615 {
3616   if (!is_vector (subs[index]))
3617     {
3618       msg (SE, _("Function %s argument %zu must be a vector, "
3619                  "not a %zu×%zu matrix."),
3620            name, index + 1, subs[index]->size1, subs[index]->size2);
3621       return false;
3622     }
3623   return true;
3624 }
3625
3626 static bool
3627 to_scalar_args (const char *name, gsl_matrix *subs[], size_t n_subs, double d[])
3628 {
3629   for (size_t i = 0; i < n_subs; i++)
3630     {
3631       if (!check_scalar_arg (name, subs, i))
3632         return false;
3633       d[i] = to_scalar (subs[i]);
3634     }
3635   return true;
3636 }
3637
3638 static int
3639 parse_constraint_value (const char **constraintsp)
3640 {
3641   char *tail;
3642   long retval = strtol (*constraintsp, &tail, 10);
3643   assert (tail > *constraintsp);
3644   *constraintsp = tail;
3645   return retval;
3646 }
3647
3648 static void
3649 argument_invalid (const struct matrix_function_properties *props,
3650                   size_t arg_index, gsl_matrix *a, size_t y, size_t x,
3651                   struct string *out)
3652 {
3653   if (is_scalar (a))
3654     ds_put_format (out, _("Argument %zu to matrix function %s "
3655                           "has invalid value %g."),
3656                    arg_index, props->name, gsl_matrix_get (a, y, x));
3657   else
3658     ds_put_format (out, _("Row %zu, column %zu of argument %zu "
3659                           "to matrix function %s has "
3660                           "invalid value %g."),
3661                    y + 1, x + 1, arg_index, props->name,
3662                    gsl_matrix_get (a, y, x));
3663 }
3664
3665 enum matrix_argument_relop
3666   {
3667     MRR_GT,                 /* > */
3668     MRR_GE,                 /* >= */
3669     MRR_LT,                 /* < */
3670     MRR_LE,                 /* <= */
3671     MRR_NE,                 /* <> */
3672   };
3673
3674 static void
3675 argument_inequality_error (const struct matrix_function_properties *props,
3676                            size_t a_index, gsl_matrix *a, size_t y, size_t x,
3677                            size_t b_index, double b,
3678                            enum matrix_argument_relop relop)
3679 {
3680   struct string s = DS_EMPTY_INITIALIZER;
3681
3682   argument_invalid (props, a_index, a, y, x, &s);
3683   ds_put_cstr (&s, "  ");
3684   switch (relop)
3685     {
3686     case MRR_GE:
3687       ds_put_format (&s, _("This argument must be greater than or "
3688                            "equal to argument %zu, but that has value %g."),
3689                      b_index, b);
3690       break;
3691
3692     case MRR_GT:
3693       ds_put_format (&s, _("This argument must be greater than argument %zu, "
3694                            "but that has value %g."),
3695                      b_index, b);
3696       break;
3697
3698     case MRR_LE:
3699       ds_put_format (&s, _("This argument must be less than or "
3700                            "equal to argument %zu, but that has value %g."),
3701                      b_index, b);
3702       break;
3703
3704     case MRR_LT:
3705       ds_put_format (&s, _("This argument must be less than argument %zu, "
3706                            "but that has value %g."),
3707                      b_index, b);
3708       break;
3709
3710     case MRR_NE:
3711       ds_put_format (&s,
3712                      _("This argument must not be the same as argument %zu."),
3713                      b_index);
3714       break;
3715     }
3716
3717   msg (ME, ds_cstr (&s));
3718   ds_destroy (&s);
3719 }
3720
3721 static void
3722 argument_value_error (const struct matrix_function_properties *props,
3723                       size_t a_index, gsl_matrix *a, size_t y, size_t x,
3724                       double b,
3725                       enum matrix_argument_relop relop)
3726 {
3727   struct string s = DS_EMPTY_INITIALIZER;
3728   argument_invalid (props, a_index, a, y, x, &s);
3729   ds_put_cstr (&s, "  ");
3730   switch (relop)
3731     {
3732     case MRR_GE:
3733       ds_put_format (&s,
3734                      _("This argument must be greater than or equal to %g."),
3735                      b);
3736       break;
3737
3738     case MRR_GT:
3739       ds_put_format (&s, _("This argument must be greater than %g."), b);
3740       break;
3741
3742     case MRR_LE:
3743       ds_put_format (&s, _("This argument must be less than or equal to %g."),
3744                      b);
3745       break;
3746
3747     case MRR_LT:
3748       ds_put_format (&s, _("This argument must be less than %g."), b);
3749       break;
3750
3751     case MRR_NE:
3752       ds_put_format (&s, _("This argument may not be %g."), b);
3753       break;
3754     }
3755
3756   msg (ME, ds_cstr (&s));
3757   ds_destroy (&s);
3758 }
3759
3760 static bool
3761 matrix_argument_relop_is_satisfied (double a, double b,
3762                                     enum matrix_argument_relop relop)
3763 {
3764   switch (relop)
3765     {
3766     case MRR_GE: return a >= b;
3767     case MRR_GT: return a > b;
3768     case MRR_LE: return a <= b;
3769     case MRR_LT: return a < b;
3770     case MRR_NE: return a != b;
3771     }
3772
3773   NOT_REACHED ();
3774 }
3775
3776 static enum matrix_argument_relop
3777 matrix_argument_relop_flip (enum matrix_argument_relop relop)
3778 {
3779   switch (relop)
3780     {
3781     case MRR_GE: return MRR_LE;
3782     case MRR_GT: return MRR_LT;
3783     case MRR_LE: return MRR_GE;
3784     case MRR_LT: return MRR_GT;
3785     case MRR_NE: return MRR_NE;
3786     }
3787
3788   NOT_REACHED ();
3789 }
3790
3791 static bool
3792 check_constraints (const struct matrix_function_properties *props,
3793                    gsl_matrix *args[], size_t n_args)
3794 {
3795   const char *constraints = props->constraints;
3796   if (!constraints)
3797     return true;
3798
3799   size_t arg_index = SIZE_MAX;
3800   while (*constraints)
3801     {
3802       if (*constraints >= 'a' && *constraints <= 'd')
3803         {
3804           arg_index = *constraints++ - 'a';
3805           assert (arg_index < n_args);
3806         }
3807       else if (*constraints == '[' || *constraints == '(')
3808         {
3809           assert (arg_index < n_args);
3810           bool open_lower = *constraints++ == '(';
3811           int minimum = parse_constraint_value (&constraints);
3812           assert (*constraints == ',');
3813           constraints++;
3814           int maximum = parse_constraint_value (&constraints);
3815           assert (*constraints == ']' || *constraints == ')');
3816           bool open_upper = *constraints++ == ')';
3817
3818           MATRIX_FOR_ALL_ELEMENTS (d, y, x, args[arg_index])
3819             if ((open_lower ? *d <= minimum : *d < minimum)
3820                 || (open_upper ? *d >= maximum : *d > maximum))
3821               {
3822                 if (!is_scalar (args[arg_index]))
3823                   msg (ME, _("Row %zu, column %zu of argument %zu to matrix "
3824                              "function %s has value %g, which is outside "
3825                              "the valid range %c%d,%d%c."),
3826                        y + 1, x + 1, arg_index + 1, props->name, *d,
3827                        open_lower ? '(' : '[',
3828                        minimum, maximum,
3829                        open_upper ? ')' : ']');
3830                 else
3831                   msg (ME, _("Argument %zu to matrix function %s has value %g, "
3832                              "which is outside the valid range %c%d,%d%c."),
3833                        arg_index + 1, props->name, *d,
3834                        open_lower ? '(' : '[',
3835                        minimum, maximum,
3836                        open_upper ? ')' : ']');
3837                 return false;
3838               }
3839         }
3840       else if (*constraints == '>'
3841                || *constraints == '<'
3842                || *constraints == '!')
3843         {
3844           enum matrix_argument_relop relop;
3845           switch (*constraints++)
3846             {
3847             case '>':
3848               if (*constraints == '=')
3849                 {
3850                   constraints++;
3851                   relop = MRR_GE;
3852                 }
3853               else
3854                 relop = MRR_GT;
3855               break;
3856
3857             case '<':
3858               if (*constraints == '=')
3859                 {
3860                   constraints++;
3861                   relop = MRR_LE;
3862                 }
3863               else
3864                 relop = MRR_LT;
3865               break;
3866
3867             case '!':
3868               assert (*constraints == '=');
3869               constraints++;
3870               relop = MRR_NE;
3871             }
3872
3873           if (*constraints >= 'a' && *constraints <= 'd')
3874             {
3875               size_t a_index = arg_index;
3876               size_t b_index = *constraints - 'a';
3877               assert (a_index < n_args);
3878               assert (b_index < n_args);
3879
3880               /* We only support one of the two arguments being non-scalar.
3881                  It's easier to support only the first one being non-scalar, so
3882                  flip things around if it's the other way. */
3883               if (!is_scalar (args[b_index]))
3884                 {
3885                   assert (is_scalar (args[a_index]));
3886                   size_t tmp_index = a_index;
3887                   a_index = b_index;
3888                   b_index = tmp_index;
3889                   relop = matrix_argument_relop_flip (relop);
3890                 }
3891
3892               double b = to_scalar (args[b_index]);
3893               MATRIX_FOR_ALL_ELEMENTS (a, y, x, args[a_index])
3894                 if (!matrix_argument_relop_is_satisfied (*a, b, relop))
3895                   {
3896                     argument_inequality_error (props,
3897                                                a_index + 1, args[a_index], y, x,
3898                                                b_index + 1, b,
3899                                                relop);
3900                     return false;
3901                   }
3902             }
3903           else
3904             {
3905               int comparand = parse_constraint_value (&constraints);
3906
3907               MATRIX_FOR_ALL_ELEMENTS (d, y, x, args[arg_index])
3908                 if (!matrix_argument_relop_is_satisfied (*d, comparand, relop))
3909                   {
3910                     argument_value_error (props,
3911                                           arg_index + 1, args[arg_index], y, x,
3912                                           comparand,
3913                                           relop);
3914                     return false;
3915                   }
3916             }
3917         }
3918       else
3919         {
3920           assert (*constraints == ' ');
3921           constraints++;
3922           arg_index = SIZE_MAX;
3923         }
3924     }
3925   return true;
3926 }
3927
3928 static gsl_matrix *
3929 matrix_expr_evaluate_d_none (
3930   const struct matrix_function_properties *props UNUSED,
3931   gsl_matrix *subs[] UNUSED, const struct matrix_expr *e,
3932   matrix_proto_d_none *f)
3933 {
3934   assert (e->n_subs == 0);
3935
3936   gsl_matrix *m = gsl_matrix_alloc (1, 1);
3937   gsl_matrix_set (m, 0, 0, f ());
3938   return m;
3939 }
3940
3941 static gsl_matrix *
3942 matrix_expr_evaluate_d_d (const struct matrix_function_properties *props,
3943                           gsl_matrix *subs[], const struct matrix_expr *e,
3944                           matrix_proto_d_d *f)
3945 {
3946   assert (e->n_subs == 1);
3947
3948   double d;
3949   if (!to_scalar_args (props->name, subs, e->n_subs, &d))
3950     return NULL;
3951
3952   if (!check_constraints (props, subs, e->n_subs))
3953     return NULL;
3954
3955   gsl_matrix *m = gsl_matrix_alloc (1, 1);
3956   gsl_matrix_set (m, 0, 0, f (d));
3957   return m;
3958 }
3959
3960 static gsl_matrix *
3961 matrix_expr_evaluate_d_dd (const struct matrix_function_properties *props,
3962                            gsl_matrix *subs[], const struct matrix_expr *e,
3963                            matrix_proto_d_dd *f)
3964 {
3965   assert (e->n_subs == 2);
3966
3967   double d[2];
3968   if (!to_scalar_args (props->name, subs, e->n_subs, d))
3969     return NULL;
3970
3971   if (!check_constraints (props, subs, e->n_subs))
3972     return NULL;
3973
3974   gsl_matrix *m = gsl_matrix_alloc (1, 1);
3975   gsl_matrix_set (m, 0, 0, f (d[0], d[1]));
3976   return m;
3977 }
3978
3979 static gsl_matrix *
3980 matrix_expr_evaluate_d_ddd (const struct matrix_function_properties *props,
3981                             gsl_matrix *subs[], const struct matrix_expr *e,
3982                             matrix_proto_d_ddd *f)
3983 {
3984   assert (e->n_subs == 3);
3985
3986   double d[3];
3987   if (!to_scalar_args (props->name, subs, e->n_subs, d))
3988     return NULL;
3989
3990   if (!check_constraints (props, subs, e->n_subs))
3991     return NULL;
3992
3993   gsl_matrix *m = gsl_matrix_alloc (1, 1);
3994   gsl_matrix_set (m, 0, 0, f (d[0], d[1], d[2]));
3995   return m;
3996 }
3997
3998 static gsl_matrix *
3999 matrix_expr_evaluate_m_d (const struct matrix_function_properties *props,
4000                           gsl_matrix *subs[], const struct matrix_expr *e,
4001                           matrix_proto_m_d *f)
4002 {
4003   assert (e->n_subs == 1);
4004
4005   double d;
4006   return to_scalar_args (props->name, subs, e->n_subs, &d) ? f (d) : NULL;
4007 }
4008
4009 static gsl_matrix *
4010 matrix_expr_evaluate_m_dd (const struct matrix_function_properties *props,
4011                            gsl_matrix *subs[], const struct matrix_expr *e,
4012                            matrix_proto_m_dd *f)
4013 {
4014   assert (e->n_subs == 2);
4015
4016   double d[2];
4017   return to_scalar_args (props->name, subs, e->n_subs, d) ? f(d[0], d[1]) : NULL;
4018 }
4019
4020 static gsl_matrix *
4021 matrix_expr_evaluate_m_ddd (const struct matrix_function_properties *props,
4022                             gsl_matrix *subs[], const struct matrix_expr *e,
4023                            matrix_proto_m_ddd *f)
4024 {
4025   assert (e->n_subs == 3);
4026
4027   double d[3];
4028   return to_scalar_args (props->name, subs, e->n_subs, d) ? f(d[0], d[1], d[2]) : NULL;
4029 }
4030
4031 static gsl_matrix *
4032 matrix_expr_evaluate_m_m (const struct matrix_function_properties *props UNUSED,
4033                           gsl_matrix *subs[], const struct matrix_expr *e,
4034                           matrix_proto_m_m *f)
4035 {
4036   assert (e->n_subs == 1);
4037   return f (subs[0]);
4038 }
4039
4040 static gsl_matrix *
4041 matrix_expr_evaluate_m_me (const struct matrix_function_properties *props UNUSED,
4042                            gsl_matrix *subs[], const struct matrix_expr *e,
4043                            matrix_proto_m_me *f)
4044 {
4045   assert (e->n_subs == 1);
4046   return f (subs[0], e);
4047 }
4048
4049 static gsl_matrix *
4050 matrix_expr_evaluate_m_e (const struct matrix_function_properties *props,
4051                           gsl_matrix *subs[], const struct matrix_expr *e,
4052                           matrix_proto_m_e *f)
4053 {
4054   assert (e->n_subs == 1);
4055
4056   if (!check_constraints (props, subs, e->n_subs))
4057     return NULL;
4058
4059   MATRIX_FOR_ALL_ELEMENTS (a, y, x, subs[0])
4060       *a = f (*a);
4061   return subs[0];
4062 }
4063
4064 static gsl_matrix *
4065 matrix_expr_evaluate_m_md (const struct matrix_function_properties *props UNUSED,
4066                            gsl_matrix *subs[], const struct matrix_expr *e,
4067                            matrix_proto_m_md *f)
4068 {
4069   assert (e->n_subs == 2);
4070   if (!check_scalar_arg (props->name, subs, 1))
4071     return NULL;
4072   return f (subs[0], to_scalar (subs[1]));
4073 }
4074
4075 static gsl_matrix *
4076 matrix_expr_evaluate_m_ed (const struct matrix_function_properties *props,
4077                            gsl_matrix *subs[], const struct matrix_expr *e,
4078                            matrix_proto_m_ed *f)
4079 {
4080   assert (e->n_subs == 2);
4081   if (!check_scalar_arg (props->name, subs, 1))
4082     return NULL;
4083
4084   if (!check_constraints (props, subs, e->n_subs))
4085     return NULL;
4086
4087   double b = to_scalar (subs[1]);
4088   MATRIX_FOR_ALL_ELEMENTS (a, y, x, subs[0])
4089     *a = f (*a, b);
4090   return subs[0];
4091 }
4092
4093 static gsl_matrix *
4094 matrix_expr_evaluate_m_mdd (const struct matrix_function_properties *props UNUSED,
4095                             gsl_matrix *subs[], const struct matrix_expr *e,
4096                             matrix_proto_m_mdd *f)
4097 {
4098   assert (e->n_subs == 3);
4099   if (!check_scalar_arg (props->name, subs, 1) || !check_scalar_arg (props->name, subs, 2))
4100     return NULL;
4101   return f (subs[0], to_scalar (subs[1]), to_scalar (subs[2]));
4102 }
4103
4104 static gsl_matrix *
4105 matrix_expr_evaluate_m_edd (const struct matrix_function_properties *props,
4106                             gsl_matrix *subs[], const struct matrix_expr *e,
4107                             matrix_proto_m_edd *f)
4108 {
4109   assert (e->n_subs == 3);
4110   if (!check_scalar_arg (props->name, subs, 1) || !check_scalar_arg (props->name, subs, 2))
4111     return NULL;
4112
4113   if (!check_constraints (props, subs, e->n_subs))
4114     return NULL;
4115
4116   double b = to_scalar (subs[1]);
4117   double c = to_scalar (subs[2]);
4118   MATRIX_FOR_ALL_ELEMENTS (a, y, x, subs[0])
4119     *a = f (*a, b, c);
4120   return subs[0];
4121 }
4122
4123 static gsl_matrix *
4124 matrix_expr_evaluate_m_eddd (const struct matrix_function_properties *props,
4125                              gsl_matrix *subs[], const struct matrix_expr *e,
4126                              matrix_proto_m_eddd *f)
4127 {
4128   assert (e->n_subs == 4);
4129   for (size_t i = 1; i < 4; i++)
4130     if (!check_scalar_arg (props->name, subs, i))
4131     return NULL;
4132
4133   if (!check_constraints (props, subs, e->n_subs))
4134     return NULL;
4135
4136   double b = to_scalar (subs[1]);
4137   double c = to_scalar (subs[2]);
4138   double d = to_scalar (subs[3]);
4139   MATRIX_FOR_ALL_ELEMENTS (a, y, x, subs[0])
4140     *a = f (*a, b, c, d);
4141   return subs[0];
4142 }
4143
4144 static gsl_matrix *
4145 matrix_expr_evaluate_m_eed (const struct matrix_function_properties *props,
4146                             gsl_matrix *subs[], const struct matrix_expr *e,
4147                             matrix_proto_m_eed *f)
4148 {
4149   assert (e->n_subs == 3);
4150   if (!check_scalar_arg (props->name, subs, 2))
4151     return NULL;
4152
4153   if (!is_scalar (subs[0]) && !is_scalar (subs[1])
4154       && (subs[0]->size1 != subs[1]->size1 || subs[0]->size2 != subs[1]->size2))
4155     {
4156       msg (ME, _("Arguments 1 and 2 to %s have dimensions %zu×%zu and "
4157                  "%zu×%zu, but %s requires these arguments either to have "
4158                  "the same dimensions or for one of them to be a scalar."),
4159            props->name,
4160            subs[0]->size1, subs[0]->size2,
4161            subs[1]->size1, subs[1]->size2,
4162            props->name);
4163       return NULL;
4164     }
4165
4166   if (!check_constraints (props, subs, e->n_subs))
4167     return NULL;
4168
4169   double c = to_scalar (subs[2]);
4170
4171   if (is_scalar (subs[0]))
4172     {
4173       double a = to_scalar (subs[0]);
4174       MATRIX_FOR_ALL_ELEMENTS (b, y, x, subs[1])
4175         *b = f (a, *b, c);
4176       return subs[1];
4177     }
4178   else
4179     {
4180       double b = to_scalar (subs[1]);
4181       MATRIX_FOR_ALL_ELEMENTS (a, y, x, subs[0])
4182         *a = f (*a, b, c);
4183       return subs[0];
4184     }
4185 }
4186
4187 static gsl_matrix *
4188 matrix_expr_evaluate_m_mm (const struct matrix_function_properties *props UNUSED,
4189                            gsl_matrix *subs[], const struct matrix_expr *e,
4190                            matrix_proto_m_mm *f)
4191 {
4192   assert (e->n_subs == 2);
4193   return f (subs[0], subs[1]);
4194 }
4195
4196 static gsl_matrix *
4197 matrix_expr_evaluate_m_v (const struct matrix_function_properties *props,
4198                           gsl_matrix *subs[], const struct matrix_expr *e,
4199                           matrix_proto_m_v *f)
4200 {
4201   assert (e->n_subs == 1);
4202   if (!check_vector_arg (props->name, subs, 0))
4203     return NULL;
4204   gsl_vector v = to_vector (subs[0]);
4205   return f (&v);
4206 }
4207
4208 static gsl_matrix *
4209 matrix_expr_evaluate_d_m (const struct matrix_function_properties *props UNUSED,
4210                           gsl_matrix *subs[], const struct matrix_expr *e,
4211                           matrix_proto_d_m *f)
4212 {
4213   assert (e->n_subs == 1);
4214
4215   gsl_matrix *m = gsl_matrix_alloc (1, 1);
4216   gsl_matrix_set (m, 0, 0, f (subs[0]));
4217   return m;
4218 }
4219
4220 static gsl_matrix *
4221 matrix_expr_evaluate_m_any (const struct matrix_function_properties *props UNUSED,
4222                             gsl_matrix *subs[], const struct matrix_expr *e,
4223                             matrix_proto_m_any *f)
4224 {
4225   return f (subs, e->n_subs);
4226 }
4227
4228 static gsl_matrix *
4229 matrix_expr_evaluate_IDENT (const struct matrix_function_properties *props,
4230                             gsl_matrix *subs[], const struct matrix_expr *e,
4231                             matrix_proto_IDENT *f)
4232 {
4233   assert (e->n_subs <= 2);
4234
4235   double d[2];
4236   if (!to_scalar_args (props->name, subs, e->n_subs, d))
4237     return NULL;
4238
4239   return f (d[0], d[e->n_subs - 1]);
4240 }
4241
4242 static gsl_matrix *
4243 matrix_expr_evaluate (const struct matrix_expr *e)
4244 {
4245   if (e->op == MOP_NUMBER)
4246     {
4247       gsl_matrix *m = gsl_matrix_alloc (1, 1);
4248       gsl_matrix_set (m, 0, 0, e->number);
4249       return m;
4250     }
4251   else if (e->op == MOP_VARIABLE)
4252     {
4253       const gsl_matrix *src = e->variable->value;
4254       if (!src)
4255         {
4256           msg (SE, _("Uninitialized variable %s used in expression."),
4257                e->variable->name);
4258           return NULL;
4259         }
4260
4261       gsl_matrix *dst = gsl_matrix_alloc (src->size1, src->size2);
4262       gsl_matrix_memcpy (dst, src);
4263       return dst;
4264     }
4265   else if (e->op == MOP_EOF)
4266     {
4267       struct dfm_reader *reader = read_file_open (e->eof);
4268       gsl_matrix *m = gsl_matrix_alloc (1, 1);
4269       gsl_matrix_set (m, 0, 0, !reader || dfm_eof (reader));
4270       return m;
4271     }
4272
4273   enum { N_LOCAL = 3 };
4274   gsl_matrix *local_subs[N_LOCAL];
4275   gsl_matrix **subs = (e->n_subs < N_LOCAL
4276                        ? local_subs
4277                        : xmalloc (e->n_subs * sizeof *subs));
4278
4279   for (size_t i = 0; i < e->n_subs; i++)
4280     {
4281       subs[i] = matrix_expr_evaluate (e->subs[i]);
4282       if (!subs[i])
4283         {
4284           for (size_t j = 0; j < i; j++)
4285             gsl_matrix_free (subs[j]);
4286           if (subs != local_subs)
4287             free (subs);
4288           return NULL;
4289         }
4290     }
4291
4292   gsl_matrix *result = NULL;
4293   switch (e->op)
4294     {
4295 #define F(ENUM, STRING, PROTO, CONSTRAINTS)                             \
4296       case MOP_F_##ENUM:                                                \
4297         {                                                               \
4298           static const struct matrix_function_properties props = {      \
4299             .name = STRING,                                             \
4300             .constraints = CONSTRAINTS,                                 \
4301           };                                                            \
4302           result = matrix_expr_evaluate_##PROTO (&props, subs, e,       \
4303                                                  matrix_eval_##ENUM);   \
4304         }                                                               \
4305       break;
4306       MATRIX_FUNCTIONS
4307 #undef F
4308
4309     case MOP_NEGATE:
4310       gsl_matrix_scale (subs[0], -1.0);
4311       result = subs[0];
4312       break;
4313
4314     case MOP_ADD_ELEMS:
4315     case MOP_SUB_ELEMS:
4316     case MOP_MUL_ELEMS:
4317     case MOP_DIV_ELEMS:
4318     case MOP_EXP_ELEMS:
4319     case MOP_GT:
4320     case MOP_GE:
4321     case MOP_LT:
4322     case MOP_LE:
4323     case MOP_EQ:
4324     case MOP_NE:
4325     case MOP_AND:
4326     case MOP_OR:
4327     case MOP_XOR:
4328       result = matrix_expr_evaluate_elementwise (e->op, subs[0], subs[1]);
4329       break;
4330
4331     case MOP_NOT:
4332       result = matrix_expr_evaluate_not (subs[0]);
4333       break;
4334
4335     case MOP_SEQ:
4336       result = matrix_expr_evaluate_seq (subs[0], subs[1], NULL);
4337       break;
4338
4339     case MOP_SEQ_BY:
4340       result = matrix_expr_evaluate_seq (subs[0], subs[1], subs[2]);
4341       break;
4342
4343     case MOP_MUL_MAT:
4344       result = matrix_expr_evaluate_mul_mat (subs[0], subs[1]);
4345       break;
4346
4347     case MOP_EXP_MAT:
4348       result = matrix_expr_evaluate_exp_mat (subs[0], subs[1]);
4349       break;
4350
4351     case MOP_PASTE_HORZ:
4352       result = matrix_expr_evaluate_paste_horz (subs[0], subs[1]);
4353       break;
4354
4355     case MOP_PASTE_VERT:
4356       result = matrix_expr_evaluate_paste_vert (subs[0], subs[1]);
4357       break;
4358
4359     case MOP_EMPTY:
4360       result = gsl_matrix_alloc (0, 0);
4361       break;
4362
4363     case MOP_VEC_INDEX:
4364       result = matrix_expr_evaluate_vec_index (subs[0], subs[1]);
4365       break;
4366
4367     case MOP_VEC_ALL:
4368       result = matrix_expr_evaluate_vec_all (subs[0]);
4369       break;
4370
4371     case MOP_MAT_INDEX:
4372       result = matrix_expr_evaluate_mat_index (subs[0], subs[1], subs[2]);
4373       break;
4374
4375     case MOP_ROW_INDEX:
4376       result = matrix_expr_evaluate_mat_index (subs[0], subs[1], NULL);
4377       break;
4378
4379     case MOP_COL_INDEX:
4380       result = matrix_expr_evaluate_mat_index (subs[0], NULL, subs[1]);
4381       break;
4382
4383     case MOP_NUMBER:
4384     case MOP_VARIABLE:
4385     case MOP_EOF:
4386       NOT_REACHED ();
4387     }
4388
4389   for (size_t i = 0; i < e->n_subs; i++)
4390     if (subs[i] != result)
4391       gsl_matrix_free (subs[i]);
4392   if (subs != local_subs)
4393     free (subs);
4394   return result;
4395 }
4396
4397 static bool
4398 matrix_expr_evaluate_scalar (const struct matrix_expr *e, const char *context,
4399                              double *d)
4400 {
4401   gsl_matrix *m = matrix_expr_evaluate (e);
4402   if (!m)
4403     return false;
4404
4405   if (!is_scalar (m))
4406     {
4407       msg (SE, _("Expression for %s must evaluate to scalar, "
4408                  "not a %zu×%zu matrix."),
4409            context, m->size1, m->size2);
4410       gsl_matrix_free (m);
4411       return false;
4412     }
4413
4414   *d = to_scalar (m);
4415   gsl_matrix_free (m);
4416   return true;
4417 }
4418
4419 static bool
4420 matrix_expr_evaluate_integer (const struct matrix_expr *e, const char *context,
4421                               long int *integer)
4422 {
4423   double d;
4424   if (!matrix_expr_evaluate_scalar (e, context, &d))
4425     return false;
4426
4427   d = trunc (d);
4428   if (d < LONG_MIN || d > LONG_MAX)
4429     {
4430       msg (SE, _("Expression for %s is outside the integer range."), context);
4431       return false;
4432     }
4433   *integer = d;
4434   return true;
4435 }
4436 \f
4437 struct matrix_lvalue
4438   {
4439     struct matrix_var *var;
4440     struct matrix_expr *indexes[2];
4441     size_t n_indexes;
4442
4443     struct msg_location *var_location; /* Variable name. */
4444     struct msg_location *index_location; /* Variable name plus indexing. */
4445   };
4446
4447 static void
4448 matrix_lvalue_destroy (struct matrix_lvalue *lvalue)
4449 {
4450   if (lvalue)
4451     {
4452       msg_location_destroy (lvalue->var_location);
4453       msg_location_destroy (lvalue->index_location);
4454       for (size_t i = 0; i < lvalue->n_indexes; i++)
4455         matrix_expr_destroy (lvalue->indexes[i]);
4456       free (lvalue);
4457     }
4458 }
4459
4460 static struct matrix_lvalue *
4461 matrix_lvalue_parse (struct matrix_state *s)
4462 {
4463   struct matrix_lvalue *lvalue = xzalloc (sizeof *lvalue);
4464   if (!lex_force_id (s->lexer))
4465     goto error;
4466   int start_ofs = lex_ofs (s->lexer);
4467   lvalue->var_location = lex_get_location (s->lexer, 0, 0);
4468   lvalue->var = matrix_var_lookup (s, lex_tokss (s->lexer));
4469   if (lex_next_token (s->lexer, 1) == T_LPAREN)
4470     {
4471       if (!lvalue->var)
4472         {
4473           msg (SE, _("Undefined variable %s."), lex_tokcstr (s->lexer));
4474           goto error;
4475         }
4476
4477       lex_get_n (s->lexer, 2);
4478
4479       if (!matrix_parse_index_expr (s, &lvalue->indexes[0]))
4480         goto error;
4481       lvalue->n_indexes++;
4482
4483       if (lex_match (s->lexer, T_COMMA))
4484         {
4485           if (!matrix_parse_index_expr (s, &lvalue->indexes[1]))
4486             goto error;
4487           lvalue->n_indexes++;
4488         }
4489       if (!lex_force_match (s->lexer, T_RPAREN))
4490         goto error;
4491
4492       lvalue->index_location = lex_ofs_location (s->lexer, start_ofs,
4493                                                  lex_ofs (s->lexer) - 1);
4494     }
4495   else
4496     {
4497       if (!lvalue->var)
4498         lvalue->var = matrix_var_create (s, lex_tokss (s->lexer));
4499       lex_get (s->lexer);
4500     }
4501   return lvalue;
4502
4503 error:
4504   matrix_lvalue_destroy (lvalue);
4505   return NULL;
4506 }
4507
4508 static bool
4509 matrix_lvalue_evaluate_vector (struct matrix_expr *e, size_t size,
4510                                enum index_type index_type, size_t other_size,
4511                                struct index_vector *iv)
4512 {
4513   gsl_matrix *m;
4514   if (e)
4515     {
4516       m = matrix_expr_evaluate (e);
4517       if (!m)
4518         return false;
4519     }
4520   else
4521     m = NULL;
4522
4523   bool ok = matrix_normalize_index_vector (m, size, index_type,
4524                                            other_size, iv);
4525   gsl_matrix_free (m);
4526   return ok;
4527 }
4528
4529 static bool
4530 matrix_lvalue_assign_vector (struct matrix_lvalue *lvalue,
4531                              struct index_vector *iv, gsl_matrix *sm)
4532 {
4533   gsl_vector dv = to_vector (lvalue->var->value);
4534
4535   /* Convert source matrix 'sm' to source vector 'sv'. */
4536   if (!is_vector (sm))
4537     {
4538       msg (SE, _("Can't assign %zu×%zu matrix to subvector."),
4539            sm->size1, sm->size2);
4540       return false;
4541     }
4542   gsl_vector sv = to_vector (sm);
4543   if (iv->n != sv.size)
4544     {
4545       msg (SE, _("Can't assign %zu-element vector "
4546                  "to %zu-element subvector."), sv.size, iv->n);
4547       return false;
4548     }
4549
4550   /* Assign elements. */
4551   for (size_t x = 0; x < iv->n; x++)
4552     gsl_vector_set (&dv, iv->indexes[x], gsl_vector_get (&sv, x));
4553   return true;
4554 }
4555
4556 static bool
4557 matrix_lvalue_assign_matrix (struct matrix_lvalue *lvalue,
4558                              struct index_vector *iv0,
4559                              struct index_vector *iv1, gsl_matrix *sm)
4560 {
4561   gsl_matrix *dm = lvalue->var->value;
4562
4563   /* Convert source matrix 'sm' to source vector 'sv'. */
4564   if (iv0->n != sm->size1)
4565     {
4566       msg (SE, _("Row index vector for assignment to %s has %zu elements "
4567                  "but source matrix has %zu rows."),
4568            lvalue->var->name, iv0->n, sm->size1);
4569       return false;
4570     }
4571   if (iv1->n != sm->size2)
4572     {
4573       msg (SE, _("Column index vector for assignment to %s has %zu elements "
4574                  "but source matrix has %zu columns."),
4575            lvalue->var->name, iv1->n, sm->size2);
4576       return false;
4577     }
4578
4579   /* Assign elements. */
4580   for (size_t y = 0; y < iv0->n; y++)
4581     {
4582       size_t f0 = iv0->indexes[y];
4583       for (size_t x = 0; x < iv1->n; x++)
4584         {
4585           size_t f1 = iv1->indexes[x];
4586           gsl_matrix_set (dm, f0, f1, gsl_matrix_get (sm, y, x));
4587         }
4588     }
4589   return true;
4590 }
4591
4592 /* Takes ownership of M. */
4593 static bool
4594 matrix_lvalue_assign (struct matrix_lvalue *lvalue,
4595                       struct index_vector *iv0, struct index_vector *iv1,
4596                       gsl_matrix *sm)
4597 {
4598   if (!lvalue->n_indexes)
4599     {
4600       gsl_matrix_free (lvalue->var->value);
4601       lvalue->var->value = sm;
4602       return true;
4603     }
4604   else
4605     {
4606       bool ok = (lvalue->n_indexes == 1
4607                  ? matrix_lvalue_assign_vector (lvalue, iv0, sm)
4608                  : matrix_lvalue_assign_matrix (lvalue, iv0, iv1, sm));
4609       free (iv0->indexes);
4610       free (iv1->indexes);
4611       gsl_matrix_free (sm);
4612       return ok;
4613     }
4614 }
4615
4616 static bool
4617 matrix_lvalue_evaluate (struct matrix_lvalue *lvalue,
4618                         struct index_vector *iv0,
4619                         struct index_vector *iv1)
4620 {
4621   *iv0 = INDEX_VECTOR_INIT;
4622   *iv1 = INDEX_VECTOR_INIT;
4623   if (!lvalue->n_indexes)
4624     return true;
4625
4626   /* Validate destination matrix exists and has the right shape. */
4627   gsl_matrix *dm = lvalue->var->value;
4628   if (!dm)
4629     {
4630       msg_at (SE, lvalue->var_location,
4631               _("Undefined variable %s."), lvalue->var->name);
4632       return false;
4633     }
4634   else if (dm->size1 == 0 || dm->size2 == 0)
4635     {
4636       msg_at (SE, lvalue->index_location,
4637               _("Cannot index %zu×%zu matrix."), dm->size1, dm->size2);
4638       return false;
4639     }
4640   else if (lvalue->n_indexes == 1)
4641     {
4642       if (!is_vector (dm))
4643         {
4644           msg_at (SE, lvalue->index_location,
4645                   _("Can't use vector indexing on %zu×%zu matrix %s."),
4646                   dm->size1, dm->size2, lvalue->var->name);
4647           return false;
4648         }
4649       return matrix_lvalue_evaluate_vector (lvalue->indexes[0],
4650                                             MAX (dm->size1, dm->size2),
4651                                             IV_VECTOR, 0, iv0);
4652     }
4653   else
4654     {
4655       assert (lvalue->n_indexes == 2);
4656       if (!matrix_lvalue_evaluate_vector (lvalue->indexes[0], dm->size1,
4657                                           IV_ROW, dm->size2, iv0))
4658         return false;
4659
4660       if (!matrix_lvalue_evaluate_vector (lvalue->indexes[1], dm->size2,
4661                                           IV_COLUMN, dm->size1, iv1))
4662         {
4663           free (iv0->indexes);
4664           return false;
4665         }
4666       return true;
4667     }
4668 }
4669
4670 /* Takes ownership of M. */
4671 static bool
4672 matrix_lvalue_evaluate_and_assign (struct matrix_lvalue *lvalue, gsl_matrix *sm)
4673 {
4674   struct index_vector iv0, iv1;
4675   if (!matrix_lvalue_evaluate (lvalue, &iv0, &iv1))
4676     {
4677       gsl_matrix_free (sm);
4678       return false;
4679     }
4680
4681   return matrix_lvalue_assign (lvalue, &iv0, &iv1, sm);
4682 }
4683
4684 \f
4685 /* Matrix command. */
4686
4687 struct matrix_cmds
4688   {
4689     struct matrix_cmd **commands;
4690     size_t n;
4691   };
4692
4693 static void matrix_cmds_uninit (struct matrix_cmds *);
4694
4695 struct matrix_cmd
4696   {
4697     enum matrix_cmd_type
4698       {
4699         MCMD_COMPUTE,
4700         MCMD_PRINT,
4701         MCMD_DO_IF,
4702         MCMD_LOOP,
4703         MCMD_BREAK,
4704         MCMD_DISPLAY,
4705         MCMD_RELEASE,
4706         MCMD_SAVE,
4707         MCMD_READ,
4708         MCMD_WRITE,
4709         MCMD_GET,
4710         MCMD_MSAVE,
4711         MCMD_MGET,
4712         MCMD_EIGEN,
4713         MCMD_SETDIAG,
4714         MCMD_SVD,
4715       }
4716     type;
4717
4718     union
4719       {
4720         struct compute_command
4721           {
4722             struct matrix_lvalue *lvalue;
4723             struct matrix_expr *rvalue;
4724           }
4725         compute;
4726
4727         struct print_command
4728           {
4729             struct matrix_expr *expression;
4730             bool use_default_format;
4731             struct fmt_spec format;
4732             char *title;
4733             int space;          /* -1 means NEWPAGE. */
4734
4735             struct print_labels
4736               {
4737                 struct string_array literals; /* CLABELS/RLABELS. */
4738                 struct matrix_expr *expr;     /* CNAMES/RNAMES. */
4739               }
4740             *rlabels, *clabels;
4741           }
4742         print;
4743
4744         struct do_if_command
4745           {
4746             struct do_if_clause
4747               {
4748                 struct matrix_expr *condition;
4749                 struct matrix_cmds commands;
4750               }
4751             *clauses;
4752             size_t n_clauses;
4753           }
4754         do_if;
4755
4756         struct loop_command
4757           {
4758             /* Index. */
4759             struct matrix_var *var;
4760             struct matrix_expr *start;
4761             struct matrix_expr *end;
4762             struct matrix_expr *increment;
4763
4764             /* Loop conditions. */
4765             struct matrix_expr *top_condition;
4766             struct matrix_expr *bottom_condition;
4767
4768             /* Commands. */
4769             struct matrix_cmds commands;
4770           }
4771         loop;
4772
4773         struct display_command
4774           {
4775             struct matrix_state *state;
4776           }
4777         display;
4778
4779         struct release_command
4780           {
4781             struct matrix_var **vars;
4782             size_t n_vars;
4783           }
4784         release;
4785
4786         struct save_command
4787           {
4788             struct matrix_expr *expression;
4789             struct save_file *sf;
4790           }
4791         save;
4792
4793         struct read_command
4794           {
4795             struct read_file *rf;
4796             struct matrix_lvalue *dst;
4797             struct matrix_expr *size;
4798             int c1, c2;
4799             enum fmt_type format;
4800             int w;
4801             bool symmetric;
4802             bool reread;
4803           }
4804         read;
4805
4806         struct write_command
4807           {
4808             struct write_file *wf;
4809             struct matrix_expr *expression;
4810             int c1, c2;
4811
4812             /* If this is nonnull, WRITE uses this format.
4813
4814                If this is NULL, WRITE uses free-field format with as many
4815                digits of precision as needed. */
4816             struct fmt_spec *format;
4817
4818             bool triangular;
4819             bool hold;
4820           }
4821         write;
4822
4823         struct get_command
4824           {
4825             struct matrix_lvalue *dst;
4826             struct dataset *dataset;
4827             struct file_handle *file;
4828             char *encoding;
4829             struct var_syntax *vars;
4830             size_t n_vars;
4831             struct matrix_var *names;
4832
4833             /* Treatment of missing values. */
4834             struct
4835               {
4836                 enum
4837                   {
4838                     MGET_ERROR,  /* Flag error on command. */
4839                     MGET_ACCEPT, /* Accept without change, user-missing only. */
4840                     MGET_OMIT,   /* Drop this case. */
4841                     MGET_RECODE  /* Recode to 'substitute'. */
4842                   }
4843                 treatment;
4844                 double substitute; /* MGET_RECODE only. */
4845               }
4846             user, system;
4847           }
4848         get;
4849
4850         struct msave_command
4851           {
4852             struct msave_common *common;
4853             struct matrix_expr *expr;
4854             const char *rowtype;
4855             const struct matrix_expr *factors;
4856             const struct matrix_expr *splits;
4857           }
4858          msave;
4859
4860         struct mget_command
4861           {
4862             struct matrix_state *state;
4863             struct file_handle *file;
4864             char *encoding;
4865             struct stringi_set rowtypes;
4866           }
4867         mget;
4868
4869         struct eigen_command
4870           {
4871             struct matrix_expr *expr;
4872             struct matrix_var *evec;
4873             struct matrix_var *eval;
4874           }
4875         eigen;
4876
4877         struct setdiag_command
4878           {
4879             struct matrix_var *dst;
4880             struct matrix_expr *expr;
4881           }
4882         setdiag;
4883
4884         struct svd_command
4885           {
4886             struct matrix_expr *expr;
4887             struct matrix_var *u;
4888             struct matrix_var *s;
4889             struct matrix_var *v;
4890           }
4891         svd;
4892       };
4893   };
4894
4895 static struct matrix_cmd *matrix_parse_command (struct matrix_state *);
4896 static bool matrix_cmd_execute (struct matrix_cmd *);
4897 static void matrix_cmd_destroy (struct matrix_cmd *);
4898
4899 \f
4900 static struct matrix_cmd *
4901 matrix_parse_compute (struct matrix_state *s)
4902 {
4903   struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
4904   *cmd = (struct matrix_cmd) {
4905     .type = MCMD_COMPUTE,
4906     .compute = { .lvalue = NULL },
4907   };
4908
4909   struct compute_command *compute = &cmd->compute;
4910   compute->lvalue = matrix_lvalue_parse (s);
4911   if (!compute->lvalue)
4912     goto error;
4913
4914   if (!lex_force_match (s->lexer, T_EQUALS))
4915     goto error;
4916
4917   compute->rvalue = matrix_parse_expr (s);
4918   if (!compute->rvalue)
4919     goto error;
4920
4921   return cmd;
4922
4923 error:
4924   matrix_cmd_destroy (cmd);
4925   return NULL;
4926 }
4927
4928 static void
4929 matrix_cmd_execute_compute (struct compute_command *compute)
4930 {
4931   gsl_matrix *value = matrix_expr_evaluate (compute->rvalue);
4932   if (!value)
4933     return;
4934
4935   matrix_lvalue_evaluate_and_assign (compute->lvalue, value);
4936 }
4937 \f
4938 static void
4939 print_labels_destroy (struct print_labels *labels)
4940 {
4941   if (labels)
4942     {
4943       string_array_destroy (&labels->literals);
4944       matrix_expr_destroy (labels->expr);
4945       free (labels);
4946     }
4947 }
4948
4949 static void
4950 parse_literal_print_labels (struct matrix_state *s,
4951                             struct print_labels **labelsp)
4952 {
4953   lex_match (s->lexer, T_EQUALS);
4954   print_labels_destroy (*labelsp);
4955   *labelsp = xzalloc (sizeof **labelsp);
4956   while (lex_token (s->lexer) != T_SLASH
4957          && lex_token (s->lexer) != T_ENDCMD
4958          && lex_token (s->lexer) != T_STOP)
4959     {
4960       struct string label = DS_EMPTY_INITIALIZER;
4961       while (lex_token (s->lexer) != T_COMMA
4962              && lex_token (s->lexer) != T_SLASH
4963              && lex_token (s->lexer) != T_ENDCMD
4964              && lex_token (s->lexer) != T_STOP)
4965         {
4966           if (!ds_is_empty (&label))
4967             ds_put_byte (&label, ' ');
4968
4969           if (lex_token (s->lexer) == T_STRING)
4970             ds_put_cstr (&label, lex_tokcstr (s->lexer));
4971           else
4972             {
4973               char *rep = lex_next_representation (s->lexer, 0, 0);
4974               ds_put_cstr (&label, rep);
4975               free (rep);
4976             }
4977           lex_get (s->lexer);
4978         }
4979       string_array_append_nocopy (&(*labelsp)->literals,
4980                                   ds_steal_cstr (&label));
4981
4982       if (!lex_match (s->lexer, T_COMMA))
4983         break;
4984     }
4985 }
4986
4987 static bool
4988 parse_expr_print_labels (struct matrix_state *s, struct print_labels **labelsp)
4989 {
4990   lex_match (s->lexer, T_EQUALS);
4991   struct matrix_expr *e = matrix_parse_exp (s);
4992   if (!e)
4993     return false;
4994
4995   print_labels_destroy (*labelsp);
4996   *labelsp = xzalloc (sizeof **labelsp);
4997   (*labelsp)->expr = e;
4998   return true;
4999 }
5000
5001 static struct matrix_cmd *
5002 matrix_parse_print (struct matrix_state *s)
5003 {
5004   struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
5005   *cmd = (struct matrix_cmd) {
5006     .type = MCMD_PRINT,
5007     .print = {
5008       .use_default_format = true,
5009     }
5010   };
5011
5012   if (lex_token (s->lexer) != T_SLASH && lex_token (s->lexer) != T_ENDCMD)
5013     {
5014       size_t depth = 0;
5015       for (size_t i = 0; ; i++)
5016         {
5017           enum token_type t = lex_next_token (s->lexer, i);
5018           if (t == T_LPAREN || t == T_LBRACK || t == T_LCURLY)
5019             depth++;
5020           else if ((t == T_RPAREN || t == T_RBRACK || t == T_RCURLY) && depth)
5021             depth--;
5022           else if ((t == T_SLASH && !depth) || t == T_ENDCMD || t == T_STOP)
5023             {
5024               if (i > 0)
5025                 cmd->print.title = lex_next_representation (s->lexer, 0, i - 1);
5026               break;
5027             }
5028         }
5029
5030       cmd->print.expression = matrix_parse_exp (s);
5031       if (!cmd->print.expression)
5032         goto error;
5033     }
5034
5035   while (lex_match (s->lexer, T_SLASH))
5036     {
5037       if (lex_match_id (s->lexer, "FORMAT"))
5038         {
5039           lex_match (s->lexer, T_EQUALS);
5040           if (!parse_format_specifier (s->lexer, &cmd->print.format))
5041             goto error;
5042           cmd->print.use_default_format = false;
5043         }
5044       else if (lex_match_id (s->lexer, "TITLE"))
5045         {
5046           lex_match (s->lexer, T_EQUALS);
5047           if (!lex_force_string (s->lexer))
5048             goto error;
5049           free (cmd->print.title);
5050           cmd->print.title = ss_xstrdup (lex_tokss (s->lexer));
5051           lex_get (s->lexer);
5052         }
5053       else if (lex_match_id (s->lexer, "SPACE"))
5054         {
5055           lex_match (s->lexer, T_EQUALS);
5056           if (lex_match_id (s->lexer, "NEWPAGE"))
5057             cmd->print.space = -1;
5058           else if (lex_force_int_range (s->lexer, "SPACE", 1, INT_MAX))
5059             {
5060               cmd->print.space = lex_integer (s->lexer);
5061               lex_get (s->lexer);
5062             }
5063           else
5064             goto error;
5065         }
5066       else if (lex_match_id (s->lexer, "RLABELS"))
5067         parse_literal_print_labels (s, &cmd->print.rlabels);
5068       else if (lex_match_id (s->lexer, "CLABELS"))
5069         parse_literal_print_labels (s, &cmd->print.clabels);
5070       else if (lex_match_id (s->lexer, "RNAMES"))
5071         {
5072           if (!parse_expr_print_labels (s, &cmd->print.rlabels))
5073             goto error;
5074         }
5075       else if (lex_match_id (s->lexer, "CNAMES"))
5076         {
5077           if (!parse_expr_print_labels (s, &cmd->print.clabels))
5078             goto error;
5079         }
5080       else
5081         {
5082           lex_error_expecting (s->lexer, "FORMAT", "TITLE", "SPACE",
5083                                "RLABELS", "CLABELS", "RNAMES", "CNAMES");
5084           goto error;
5085         }
5086
5087     }
5088   return cmd;
5089
5090 error:
5091   matrix_cmd_destroy (cmd);
5092   return NULL;
5093 }
5094
5095 static bool
5096 matrix_is_integer (const gsl_matrix *m)
5097 {
5098   for (size_t y = 0; y < m->size1; y++)
5099     for (size_t x = 0; x < m->size2; x++)
5100       {
5101         double d = gsl_matrix_get (m, y, x);
5102         if (d != floor (d))
5103           return false;
5104       }
5105   return true;
5106 }
5107
5108 static double
5109 matrix_max_magnitude (const gsl_matrix *m)
5110 {
5111   double max = 0.0;
5112   for (size_t y = 0; y < m->size1; y++)
5113     for (size_t x = 0; x < m->size2; x++)
5114       {
5115         double d = fabs (gsl_matrix_get (m, y, x));
5116         if (d > max)
5117           max = d;
5118       }
5119   return max;
5120 }
5121
5122 static bool
5123 format_fits (struct fmt_spec format, double x)
5124 {
5125   char *s = data_out (&(union value) { .f = x }, NULL,
5126                       &format, settings_get_fmt_settings ());
5127   bool fits = *s != '*' && !strchr (s, 'E');
5128   free (s);
5129   return fits;
5130 }
5131
5132 static struct fmt_spec
5133 default_format (const gsl_matrix *m, int *log_scale)
5134 {
5135   *log_scale = 0;
5136
5137   double max = matrix_max_magnitude (m);
5138
5139   if (matrix_is_integer (m))
5140     for (int w = 1; w <= 12; w++)
5141       {
5142         struct fmt_spec format = { .type = FMT_F, .w = w };
5143         if (format_fits (format, -max))
5144           return format;
5145       }
5146
5147   if (max >= 1e9 || max <= 1e-4)
5148     {
5149       char s[64];
5150       snprintf (s, sizeof s, "%.1e", max);
5151
5152       const char *e = strchr (s, 'e');
5153       if (e)
5154         *log_scale = atoi (e + 1);
5155     }
5156
5157   return (struct fmt_spec) { .type = FMT_F, .w = 13, .d = 10 };
5158 }
5159
5160 static char *
5161 trimmed_string (double d)
5162 {
5163   struct substring s = ss_buffer ((char *) &d, sizeof d);
5164   ss_rtrim (&s, ss_cstr (" "));
5165   return ss_xstrdup (s);
5166 }
5167
5168 static struct string_array *
5169 print_labels_get (const struct print_labels *labels, size_t n,
5170                   const char *prefix, bool truncate)
5171 {
5172   if (!labels)
5173     return NULL;
5174
5175   struct string_array *out = xzalloc (sizeof *out);
5176   if (labels->literals.n)
5177     string_array_clone (out, &labels->literals);
5178   else if (labels->expr)
5179     {
5180       gsl_matrix *m = matrix_expr_evaluate (labels->expr);
5181       if (m && is_vector (m))
5182         {
5183           gsl_vector v = to_vector (m);
5184           for (size_t i = 0; i < v.size; i++)
5185             string_array_append_nocopy (out, trimmed_string (
5186                                           gsl_vector_get (&v, i)));
5187         }
5188       gsl_matrix_free (m);
5189     }
5190
5191   while (out->n < n)
5192     {
5193       if (labels->expr)
5194         string_array_append_nocopy (out, xasprintf ("%s%zu", prefix,
5195                                                     out->n + 1));
5196       else
5197         string_array_append (out, "");
5198     }
5199   while (out->n > n)
5200     string_array_delete (out, out->n - 1);
5201
5202   if (truncate)
5203     for (size_t i = 0; i < out->n; i++)
5204       {
5205         char *s = out->strings[i];
5206         s[strnlen (s, 8)] = '\0';
5207       }
5208
5209   return out;
5210 }
5211
5212 static void
5213 matrix_cmd_print_space (int space)
5214 {
5215   if (space < 0)
5216     output_item_submit (page_break_item_create ());
5217   for (int i = 0; i < space; i++)
5218     output_log ("%s", "");
5219 }
5220
5221 static void
5222 matrix_cmd_print_text (const struct print_command *print, const gsl_matrix *m,
5223                        struct fmt_spec format, int log_scale)
5224 {
5225   matrix_cmd_print_space (print->space);
5226   if (print->title)
5227     output_log ("%s", print->title);
5228   if (log_scale != 0)
5229     output_log ("  10 ** %d   X", log_scale);
5230
5231   struct string_array *clabels = print_labels_get (print->clabels,
5232                                                    m->size2, "col", true);
5233   if (clabels && format.w < 8)
5234     format.w = 8;
5235   struct string_array *rlabels = print_labels_get (print->rlabels,
5236                                                    m->size1, "row", true);
5237
5238   if (clabels)
5239     {
5240       struct string line = DS_EMPTY_INITIALIZER;
5241       if (rlabels)
5242         ds_put_byte_multiple (&line, ' ', 8);
5243       for (size_t x = 0; x < m->size2; x++)
5244         ds_put_format (&line, " %*s", format.w, clabels->strings[x]);
5245       output_log_nocopy (ds_steal_cstr (&line));
5246     }
5247
5248   double scale = pow (10.0, log_scale);
5249   bool numeric = fmt_is_numeric (format.type);
5250   for (size_t y = 0; y < m->size1; y++)
5251     {
5252       struct string line = DS_EMPTY_INITIALIZER;
5253       if (rlabels)
5254         ds_put_format (&line, "%-8s", rlabels->strings[y]);
5255
5256       for (size_t x = 0; x < m->size2; x++)
5257         {
5258           double f = gsl_matrix_get (m, y, x);
5259           char *s = (numeric
5260                      ? data_out (&(union value) { .f = f / scale}, NULL,
5261                                  &format, settings_get_fmt_settings ())
5262                      : trimmed_string (f));
5263           ds_put_format (&line, " %s", s);
5264           free (s);
5265         }
5266       output_log_nocopy (ds_steal_cstr (&line));
5267     }
5268
5269   string_array_destroy (rlabels);
5270   free (rlabels);
5271   string_array_destroy (clabels);
5272   free (clabels);
5273 }
5274
5275 static void
5276 create_print_dimension (struct pivot_table *table, enum pivot_axis_type axis,
5277                         const struct print_labels *print_labels, size_t n,
5278                         const char *name, const char *prefix)
5279 {
5280   struct string_array *labels = print_labels_get (print_labels, n, prefix,
5281                                                   false);
5282   struct pivot_dimension *d = pivot_dimension_create (table, axis, name);
5283   for (size_t i = 0; i < n; i++)
5284     pivot_category_create_leaf (
5285       d->root, (labels
5286                 ? pivot_value_new_user_text (labels->strings[i], SIZE_MAX)
5287                 : pivot_value_new_integer (i + 1)));
5288   if (!labels)
5289     d->hide_all_labels = true;
5290   string_array_destroy (labels);
5291   free (labels);
5292 }
5293
5294 static void
5295 matrix_cmd_print_tables (const struct print_command *print, const gsl_matrix *m,
5296                          struct fmt_spec format, int log_scale)
5297 {
5298   struct pivot_table *table = pivot_table_create__ (
5299     pivot_value_new_user_text (print->title ? print->title : "", SIZE_MAX),
5300     "Matrix Print");
5301
5302   create_print_dimension (table, PIVOT_AXIS_ROW, print->rlabels, m->size1,
5303                           N_("Rows"), "row");
5304   create_print_dimension (table, PIVOT_AXIS_COLUMN, print->clabels, m->size2,
5305                           N_("Columns"), "col");
5306
5307   struct pivot_footnote *footnote = NULL;
5308   if (log_scale != 0)
5309     {
5310       char *s = xasprintf ("× 10**%d", log_scale);
5311       footnote = pivot_table_create_footnote (
5312         table, pivot_value_new_user_text_nocopy (s));
5313     }
5314
5315   double scale = pow (10.0, log_scale);
5316   bool numeric = fmt_is_numeric (format.type);
5317   for (size_t y = 0; y < m->size1; y++)
5318     for (size_t x = 0; x < m->size2; x++)
5319       {
5320         double f = gsl_matrix_get (m, y, x);
5321         struct pivot_value *v;
5322         if (numeric)
5323           {
5324             v = pivot_value_new_number (f / scale);
5325             v->numeric.format = format;
5326           }
5327         else
5328           v = pivot_value_new_user_text_nocopy (trimmed_string (f));
5329         if (footnote)
5330           pivot_value_add_footnote (v, footnote);
5331         pivot_table_put2 (table, y, x, v);
5332       }
5333
5334   pivot_table_submit (table);
5335 }
5336
5337 static void
5338 matrix_cmd_execute_print (const struct print_command *print)
5339 {
5340   if (print->expression)
5341     {
5342       gsl_matrix *m = matrix_expr_evaluate (print->expression);
5343       if (!m)
5344         return;
5345
5346       int log_scale = 0;
5347       struct fmt_spec format = (print->use_default_format
5348                                 ? default_format (m, &log_scale)
5349                                 : print->format);
5350
5351       if (settings_get_mdisplay () == SETTINGS_MDISPLAY_TEXT)
5352         matrix_cmd_print_text (print, m, format, log_scale);
5353       else
5354         matrix_cmd_print_tables (print, m, format, log_scale);
5355
5356       gsl_matrix_free (m);
5357     }
5358   else
5359     {
5360       matrix_cmd_print_space (print->space);
5361       if (print->title)
5362         output_log ("%s", print->title);
5363     }
5364 }
5365 \f
5366 /* DO IF. */
5367
5368 static bool
5369 matrix_parse_commands (struct matrix_state *s, struct matrix_cmds *c,
5370                        const char *command_name,
5371                        const char *stop1, const char *stop2)
5372 {
5373   lex_end_of_command (s->lexer);
5374   lex_discard_rest_of_command (s->lexer);
5375
5376   size_t allocated = 0;
5377   for (;;)
5378     {
5379       while (lex_token (s->lexer) == T_ENDCMD)
5380         lex_get (s->lexer);
5381
5382       if (lex_at_phrase (s->lexer, stop1)
5383           || (stop2 && lex_at_phrase (s->lexer, stop2)))
5384         return true;
5385
5386       if (lex_at_phrase (s->lexer, "END MATRIX"))
5387         {
5388           msg (SE, _("Premature END MATRIX within %s."), command_name);
5389           return false;
5390         }
5391
5392       struct matrix_cmd *cmd = matrix_parse_command (s);
5393       if (!cmd)
5394         return false;
5395
5396       if (c->n >= allocated)
5397         c->commands = x2nrealloc (c->commands, &allocated, sizeof *c->commands);
5398       c->commands[c->n++] = cmd;
5399     }
5400 }
5401
5402 static bool
5403 matrix_parse_do_if_clause (struct matrix_state *s,
5404                            struct do_if_command *ifc,
5405                            bool parse_condition,
5406                            size_t *allocated_clauses)
5407 {
5408   if (ifc->n_clauses >= *allocated_clauses)
5409     ifc->clauses = x2nrealloc (ifc->clauses, allocated_clauses,
5410                                sizeof *ifc->clauses);
5411   struct do_if_clause *c = &ifc->clauses[ifc->n_clauses++];
5412   *c = (struct do_if_clause) { .condition = NULL };
5413
5414   if (parse_condition)
5415     {
5416       c->condition = matrix_parse_expr (s);
5417       if (!c->condition)
5418         return false;
5419     }
5420
5421   return matrix_parse_commands (s, &c->commands, "DO IF", "ELSE", "END IF");
5422 }
5423
5424 static struct matrix_cmd *
5425 matrix_parse_do_if (struct matrix_state *s)
5426 {
5427   struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
5428   *cmd = (struct matrix_cmd) {
5429     .type = MCMD_DO_IF,
5430     .do_if = { .n_clauses = 0 }
5431   };
5432
5433   size_t allocated_clauses = 0;
5434   do
5435     {
5436       if (!matrix_parse_do_if_clause (s, &cmd->do_if, true, &allocated_clauses))
5437         goto error;
5438     }
5439   while (lex_match_phrase (s->lexer, "ELSE IF"));
5440
5441   if (lex_match_id (s->lexer, "ELSE")
5442       && !matrix_parse_do_if_clause (s, &cmd->do_if, false, &allocated_clauses))
5443     goto error;
5444
5445   if (!lex_match_phrase (s->lexer, "END IF"))
5446     NOT_REACHED ();
5447   return cmd;
5448
5449 error:
5450   matrix_cmd_destroy (cmd);
5451   return NULL;
5452 }
5453
5454 static bool
5455 matrix_cmd_execute_do_if (struct do_if_command *cmd)
5456 {
5457   for (size_t i = 0; i < cmd->n_clauses; i++)
5458     {
5459       struct do_if_clause *c = &cmd->clauses[i];
5460       if (c->condition)
5461         {
5462           double d;
5463           if (!matrix_expr_evaluate_scalar (c->condition,
5464                                             i ? "ELSE IF" : "DO IF",
5465                                             &d) || d <= 0)
5466             continue;
5467         }
5468
5469       for (size_t j = 0; j < c->commands.n; j++)
5470         if (!matrix_cmd_execute (c->commands.commands[j]))
5471           return false;
5472       return true;
5473     }
5474   return true;
5475 }
5476 \f
5477 static struct matrix_cmd *
5478 matrix_parse_loop (struct matrix_state *s)
5479 {
5480   struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
5481   *cmd = (struct matrix_cmd) { .type = MCMD_LOOP, .loop = { .var = NULL } };
5482
5483   struct loop_command *loop = &cmd->loop;
5484   if (lex_token (s->lexer) == T_ID && lex_next_token (s->lexer, 1) == T_EQUALS)
5485     {
5486       struct substring name = lex_tokss (s->lexer);
5487       loop->var = matrix_var_lookup (s, name);
5488       if (!loop->var)
5489         loop->var = matrix_var_create (s, name);
5490
5491       lex_get (s->lexer);
5492       lex_get (s->lexer);
5493
5494       loop->start = matrix_parse_expr (s);
5495       if (!loop->start || !lex_force_match (s->lexer, T_TO))
5496         goto error;
5497
5498       loop->end = matrix_parse_expr (s);
5499       if (!loop->end)
5500         goto error;
5501
5502       if (lex_match (s->lexer, T_BY))
5503         {
5504           loop->increment = matrix_parse_expr (s);
5505           if (!loop->increment)
5506             goto error;
5507         }
5508     }
5509
5510   if (lex_match_id (s->lexer, "IF"))
5511     {
5512       loop->top_condition = matrix_parse_expr (s);
5513       if (!loop->top_condition)
5514         goto error;
5515     }
5516
5517   bool was_in_loop = s->in_loop;
5518   s->in_loop = true;
5519   bool ok = matrix_parse_commands (s, &loop->commands, "LOOP",
5520                                    "END LOOP", NULL);
5521   s->in_loop = was_in_loop;
5522   if (!ok)
5523     goto error;
5524
5525   if (!lex_match_phrase (s->lexer, "END LOOP"))
5526     NOT_REACHED ();
5527
5528   if (lex_match_id (s->lexer, "IF"))
5529     {
5530       loop->bottom_condition = matrix_parse_expr (s);
5531       if (!loop->bottom_condition)
5532         goto error;
5533     }
5534
5535   return cmd;
5536
5537 error:
5538   matrix_cmd_destroy (cmd);
5539   return NULL;
5540 }
5541
5542 static void
5543 matrix_cmd_execute_loop (struct loop_command *cmd)
5544 {
5545   long int value = 0;
5546   long int end = 0;
5547   long int increment = 1;
5548   if (cmd->var)
5549     {
5550       if (!matrix_expr_evaluate_integer (cmd->start, "LOOP", &value)
5551           || !matrix_expr_evaluate_integer (cmd->end, "TO", &end)
5552           || (cmd->increment
5553               && !matrix_expr_evaluate_integer (cmd->increment, "BY",
5554                                                 &increment)))
5555         return;
5556
5557       if (increment > 0 ? value > end
5558           : increment < 0 ? value < end
5559           : true)
5560         return;
5561     }
5562
5563   int mxloops = settings_get_mxloops ();
5564   for (int i = 0; i < mxloops; i++)
5565     {
5566       if (cmd->var)
5567         {
5568           if (cmd->var->value
5569               && (cmd->var->value->size1 != 1 || cmd->var->value->size2 != 1))
5570             {
5571               gsl_matrix_free (cmd->var->value);
5572               cmd->var->value = NULL;
5573             }
5574           if (!cmd->var->value)
5575             cmd->var->value = gsl_matrix_alloc (1, 1);
5576
5577           gsl_matrix_set (cmd->var->value, 0, 0, value);
5578         }
5579
5580       if (cmd->top_condition)
5581         {
5582           double d;
5583           if (!matrix_expr_evaluate_scalar (cmd->top_condition, "LOOP IF",
5584                                             &d) || d <= 0)
5585             return;
5586         }
5587
5588       for (size_t j = 0; j < cmd->commands.n; j++)
5589         if (!matrix_cmd_execute (cmd->commands.commands[j]))
5590           return;
5591
5592       if (cmd->bottom_condition)
5593         {
5594           double d;
5595           if (!matrix_expr_evaluate_scalar (cmd->bottom_condition,
5596                                             "END LOOP IF", &d) || d > 0)
5597             return;
5598         }
5599
5600       if (cmd->var)
5601         {
5602           value += increment;
5603           if (increment > 0 ? value > end : value < end)
5604             return;
5605         }
5606     }
5607 }
5608 \f
5609 static struct matrix_cmd *
5610 matrix_parse_break (struct matrix_state *s)
5611 {
5612   if (!s->in_loop)
5613     {
5614       msg (SE, _("BREAK not inside LOOP."));
5615       return NULL;
5616     }
5617
5618   struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
5619   *cmd = (struct matrix_cmd) { .type = MCMD_BREAK };
5620   return cmd;
5621 }
5622 \f
5623 static struct matrix_cmd *
5624 matrix_parse_display (struct matrix_state *s)
5625 {
5626   while (lex_token (s->lexer) != T_ENDCMD)
5627     {
5628       if (!lex_match_id (s->lexer, "DICTIONARY")
5629           && !lex_match_id (s->lexer, "STATUS"))
5630         {
5631           lex_error_expecting (s->lexer, "DICTIONARY", "STATUS");
5632           return NULL;
5633         }
5634     }
5635
5636   struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
5637   *cmd = (struct matrix_cmd) { .type = MCMD_DISPLAY, .display = { s } };
5638   return cmd;
5639 }
5640
5641 static int
5642 compare_matrix_var_pointers (const void *a_, const void *b_)
5643 {
5644   const struct matrix_var *const *ap = a_;
5645   const struct matrix_var *const *bp = b_;
5646   const struct matrix_var *a = *ap;
5647   const struct matrix_var *b = *bp;
5648   return strcmp (a->name, b->name);
5649 }
5650
5651 static void
5652 matrix_cmd_execute_display (struct display_command *cmd)
5653 {
5654   const struct matrix_state *s = cmd->state;
5655
5656   struct pivot_table *table = pivot_table_create (N_("Matrix Variables"));
5657   struct pivot_dimension *attr_dimension
5658     = pivot_dimension_create (table, PIVOT_AXIS_COLUMN, N_("Attribute"));
5659   pivot_category_create_group (attr_dimension->root, N_("Dimension"),
5660                                N_("Rows"), N_("Columns"));
5661   pivot_category_create_leaves (attr_dimension->root, N_("Size (kB)"));
5662
5663   const struct matrix_var **vars = xmalloc (hmap_count (&s->vars) * sizeof *vars);
5664   size_t n_vars = 0;
5665
5666   const struct matrix_var *var;
5667   HMAP_FOR_EACH (var, struct matrix_var, hmap_node, &s->vars)
5668     if (var->value)
5669       vars[n_vars++] = var;
5670   qsort (vars, n_vars, sizeof *vars, compare_matrix_var_pointers);
5671
5672   struct pivot_dimension *rows = pivot_dimension_create (
5673     table, PIVOT_AXIS_ROW, N_("Variable"));
5674   for (size_t i = 0; i < n_vars; i++)
5675     {
5676       const struct matrix_var *var = vars[i];
5677       pivot_category_create_leaf (
5678         rows->root, pivot_value_new_user_text (var->name, SIZE_MAX));
5679
5680       size_t r = var->value->size1;
5681       size_t c = var->value->size2;
5682       double values[] = { r, c, r * c * sizeof (double) / 1024 };
5683       for (size_t j = 0; j < sizeof values / sizeof *values; j++)
5684         pivot_table_put2 (table, j, i, pivot_value_new_integer (values[j]));
5685     }
5686   free (vars);
5687   pivot_table_submit (table);
5688 }
5689 \f
5690 static struct matrix_cmd *
5691 matrix_parse_release (struct matrix_state *s)
5692 {
5693   struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
5694   *cmd = (struct matrix_cmd) { .type = MCMD_RELEASE };
5695
5696   size_t allocated_vars = 0;
5697   while (lex_token (s->lexer) == T_ID)
5698     {
5699       struct matrix_var *var = matrix_var_lookup (s, lex_tokss (s->lexer));
5700       if (var)
5701         {
5702           if (cmd->release.n_vars >= allocated_vars)
5703             cmd->release.vars = x2nrealloc (cmd->release.vars, &allocated_vars,
5704                                             sizeof *cmd->release.vars);
5705           cmd->release.vars[cmd->release.n_vars++] = var;
5706         }
5707       else
5708         lex_error (s->lexer, _("Variable name expected."));
5709       lex_get (s->lexer);
5710
5711       if (!lex_match (s->lexer, T_COMMA))
5712         break;
5713     }
5714
5715   return cmd;
5716 }
5717
5718 static void
5719 matrix_cmd_execute_release (struct release_command *cmd)
5720 {
5721   for (size_t i = 0; i < cmd->n_vars; i++)
5722     {
5723       struct matrix_var *var = cmd->vars[i];
5724       gsl_matrix_free (var->value);
5725       var->value = NULL;
5726     }
5727 }
5728 \f
5729 static struct save_file *
5730 save_file_create (struct matrix_state *s, struct file_handle *fh,
5731                   struct string_array *variables,
5732                   struct matrix_expr *names,
5733                   struct stringi_set *strings)
5734 {
5735   for (size_t i = 0; i < s->n_save_files; i++)
5736     {
5737       struct save_file *sf = s->save_files[i];
5738       if (fh_equal (sf->file, fh))
5739         {
5740           fh_unref (fh);
5741
5742           string_array_destroy (variables);
5743           matrix_expr_destroy (names);
5744           stringi_set_destroy (strings);
5745
5746           return sf;
5747         }
5748     }
5749
5750   struct save_file *sf = xmalloc (sizeof *sf);
5751   *sf = (struct save_file) {
5752     .file = fh,
5753     .dataset = s->dataset,
5754     .variables = *variables,
5755     .names = names,
5756     .strings = STRINGI_SET_INITIALIZER (sf->strings),
5757   };
5758
5759   stringi_set_swap (&sf->strings, strings);
5760   stringi_set_destroy (strings);
5761
5762   s->save_files = xrealloc (s->save_files,
5763                              (s->n_save_files + 1) * sizeof *s->save_files);
5764   s->save_files[s->n_save_files++] = sf;
5765   return sf;
5766 }
5767
5768 static struct casewriter *
5769 save_file_open (struct save_file *sf, gsl_matrix *m)
5770 {
5771   if (sf->writer || sf->error)
5772     {
5773       if (sf->writer)
5774         {
5775           size_t n_variables = caseproto_get_n_widths (
5776             casewriter_get_proto (sf->writer));
5777           if (m->size2 != n_variables)
5778             {
5779               msg (ME, _("The first SAVE to %s within this matrix program "
5780                          "had %zu columns, so a %zu×%zu matrix cannot be "
5781                          "saved to it."),
5782                    sf->file == fh_inline_file () ? "*" : fh_get_name (sf->file),
5783                    n_variables, m->size1, m->size2);
5784               return NULL;
5785             }
5786         }
5787       return sf->writer;
5788     }
5789
5790   bool ok = true;
5791   struct dictionary *dict = dict_create (get_default_encoding ());
5792
5793   /* Fill 'names' with user-specified names if there were any, either from
5794      sf->variables or sf->names. */
5795   struct string_array names = { .n = 0 };
5796   if (sf->variables.n)
5797     string_array_clone (&names, &sf->variables);
5798   else if (sf->names)
5799     {
5800       gsl_matrix *nm = matrix_expr_evaluate (sf->names);
5801       if (nm && is_vector (nm))
5802         {
5803           gsl_vector nv = to_vector (nm);
5804           for (size_t i = 0; i < nv.size; i++)
5805             {
5806               char *name = trimmed_string (gsl_vector_get (&nv, i));
5807               if (dict_id_is_valid (dict, name, true))
5808                 string_array_append_nocopy (&names, name);
5809               else
5810                 ok = false;
5811             }
5812         }
5813       gsl_matrix_free (nm);
5814     }
5815
5816   struct stringi_set strings;
5817   stringi_set_clone (&strings, &sf->strings);
5818
5819   for (size_t i = 0; dict_get_var_cnt (dict) < m->size2; i++)
5820     {
5821       char tmp_name[64];
5822       const char *name;
5823       if (i < names.n)
5824         name = names.strings[i];
5825       else
5826         {
5827           snprintf (tmp_name, sizeof tmp_name, "COL%zu", i + 1);
5828           name = tmp_name;
5829         }
5830
5831       int width = stringi_set_delete (&strings, name) ? 8 : 0;
5832       struct variable *var = dict_create_var (dict, name, width);
5833       if (!var)
5834         {
5835           msg (ME, _("Duplicate variable name %s in SAVE statement."),
5836                name);
5837           ok = false;
5838         }
5839     }
5840
5841   if (!stringi_set_is_empty (&strings))
5842     {
5843       size_t count = stringi_set_count (&strings);
5844       const char *example = stringi_set_node_get_string (
5845         stringi_set_first (&strings));
5846
5847       if (count == 1)
5848         msg (ME, _("The SAVE command STRINGS subcommand specifies an unknown "
5849                    "variable %s."), example);
5850       else
5851         msg (ME, ngettext ("The SAVE command STRINGS subcommand specifies %zu "
5852                            "unknown variable: %s.",
5853                            "The SAVE command STRINGS subcommand specifies %zu "
5854                            "unknown variables, including %s.",
5855                            count),
5856              count, example);
5857       ok = false;
5858     }
5859   stringi_set_destroy (&strings);
5860   string_array_destroy (&names);
5861
5862   if (!ok)
5863     {
5864       dict_unref (dict);
5865       sf->error = true;
5866       return NULL;
5867     }
5868
5869   if (sf->file == fh_inline_file ())
5870     sf->writer = autopaging_writer_create (dict_get_proto (dict));
5871   else
5872     sf->writer = any_writer_open (sf->file, dict);
5873   if (sf->writer)
5874     sf->dict = dict;
5875   else
5876     {
5877       dict_unref (dict);
5878       sf->error = true;
5879     }
5880   return sf->writer;
5881 }
5882
5883 static void
5884 save_file_destroy (struct save_file *sf)
5885 {
5886   if (sf)
5887     {
5888       if (sf->file == fh_inline_file () && sf->writer && sf->dict)
5889         {
5890           dataset_set_dict (sf->dataset, sf->dict);
5891           dataset_set_source (sf->dataset, casewriter_make_reader (sf->writer));
5892         }
5893       else
5894         {
5895           casewriter_destroy (sf->writer);
5896           dict_unref (sf->dict);
5897         }
5898       fh_unref (sf->file);
5899       string_array_destroy (&sf->variables);
5900       matrix_expr_destroy (sf->names);
5901       stringi_set_destroy (&sf->strings);
5902       free (sf);
5903     }
5904 }
5905
5906 static struct matrix_cmd *
5907 matrix_parse_save (struct matrix_state *s)
5908 {
5909   struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
5910   *cmd = (struct matrix_cmd) {
5911     .type = MCMD_SAVE,
5912     .save = { .expression = NULL },
5913   };
5914
5915   struct file_handle *fh = NULL;
5916   struct save_command *save = &cmd->save;
5917
5918   struct string_array variables = STRING_ARRAY_INITIALIZER;
5919   struct matrix_expr *names = NULL;
5920   struct stringi_set strings = STRINGI_SET_INITIALIZER (strings);
5921
5922   save->expression = matrix_parse_exp (s);
5923   if (!save->expression)
5924     goto error;
5925
5926   while (lex_match (s->lexer, T_SLASH))
5927     {
5928       if (lex_match_id (s->lexer, "OUTFILE"))
5929         {
5930           lex_match (s->lexer, T_EQUALS);
5931
5932           fh_unref (fh);
5933           fh = (lex_match (s->lexer, T_ASTERISK)
5934                 ? fh_inline_file ()
5935                 : fh_parse (s->lexer, FH_REF_FILE, s->session));
5936           if (!fh)
5937             goto error;
5938         }
5939       else if (lex_match_id (s->lexer, "VARIABLES"))
5940         {
5941           lex_match (s->lexer, T_EQUALS);
5942
5943           char **names;
5944           size_t n;
5945           struct dictionary *d = dict_create (get_default_encoding ());
5946           bool ok = parse_DATA_LIST_vars (s->lexer, d, &names, &n,
5947                                           PV_NO_SCRATCH | PV_NO_DUPLICATE);
5948           dict_unref (d);
5949           if (!ok)
5950             goto error;
5951
5952           string_array_clear (&variables);
5953           variables = (struct string_array) {
5954             .strings = names,
5955             .n = n,
5956             .allocated = n,
5957           };
5958         }
5959       else if (lex_match_id (s->lexer, "NAMES"))
5960         {
5961           lex_match (s->lexer, T_EQUALS);
5962           matrix_expr_destroy (names);
5963           names = matrix_parse_exp (s);
5964           if (!names)
5965             goto error;
5966         }
5967       else if (lex_match_id (s->lexer, "STRINGS"))
5968         {
5969           lex_match (s->lexer, T_EQUALS);
5970           while (lex_token (s->lexer) == T_ID)
5971             {
5972               stringi_set_insert (&strings, lex_tokcstr (s->lexer));
5973               lex_get (s->lexer);
5974               if (!lex_match (s->lexer, T_COMMA))
5975                 break;
5976             }
5977         }
5978       else
5979         {
5980           lex_error_expecting (s->lexer, "OUTFILE", "VARIABLES", "NAMES",
5981                                "STRINGS");
5982           goto error;
5983         }
5984     }
5985
5986   if (!fh)
5987     {
5988       if (s->prev_save_file)
5989         fh = fh_ref (s->prev_save_file);
5990       else
5991         {
5992           lex_sbc_missing ("OUTFILE");
5993           goto error;
5994         }
5995     }
5996   fh_unref (s->prev_save_file);
5997   s->prev_save_file = fh_ref (fh);
5998
5999   if (variables.n && names)
6000     {
6001       msg (SW, _("VARIABLES and NAMES both specified; ignoring NAMES."));
6002       matrix_expr_destroy (names);
6003       names = NULL;
6004     }
6005
6006   save->sf = save_file_create (s, fh, &variables, names, &strings);
6007   return cmd;
6008
6009 error:
6010   string_array_destroy (&variables);
6011   matrix_expr_destroy (names);
6012   stringi_set_destroy (&strings);
6013   fh_unref (fh);
6014   matrix_cmd_destroy (cmd);
6015   return NULL;
6016 }
6017
6018 static void
6019 matrix_cmd_execute_save (const struct save_command *save)
6020 {
6021   gsl_matrix *m = matrix_expr_evaluate (save->expression);
6022   if (!m)
6023     return;
6024
6025   struct casewriter *writer = save_file_open (save->sf, m);
6026   if (!writer)
6027     {
6028       gsl_matrix_free (m);
6029       return;
6030     }
6031
6032   const struct caseproto *proto = casewriter_get_proto (writer);
6033   for (size_t y = 0; y < m->size1; y++)
6034     {
6035       struct ccase *c = case_create (proto);
6036       for (size_t x = 0; x < m->size2; x++)
6037         {
6038           double d = gsl_matrix_get (m, y, x);
6039           int width = caseproto_get_width (proto, x);
6040           union value *value = case_data_rw_idx (c, x);
6041           if (width == 0)
6042             value->f = d;
6043           else
6044             memcpy (value->s, &d, width);
6045         }
6046       casewriter_write (writer, c);
6047     }
6048   gsl_matrix_free (m);
6049 }
6050 \f
6051 static struct matrix_cmd *
6052 matrix_parse_read (struct matrix_state *s)
6053 {
6054   struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
6055   *cmd = (struct matrix_cmd) {
6056     .type = MCMD_READ,
6057     .read = { .format = FMT_F },
6058   };
6059
6060   struct file_handle *fh = NULL;
6061   char *encoding = NULL;
6062   struct read_command *read = &cmd->read;
6063   read->dst = matrix_lvalue_parse (s);
6064   if (!read->dst)
6065     goto error;
6066
6067   int by = 0;
6068   int repetitions = 0;
6069   int record_width = 0;
6070   bool seen_format = false;
6071   while (lex_match (s->lexer, T_SLASH))
6072     {
6073       if (lex_match_id (s->lexer, "FILE"))
6074         {
6075           lex_match (s->lexer, T_EQUALS);
6076
6077           fh_unref (fh);
6078           fh = fh_parse (s->lexer, FH_REF_FILE, NULL);
6079           if (!fh)
6080             goto error;
6081         }
6082       else if (lex_match_id (s->lexer, "ENCODING"))
6083         {
6084           lex_match (s->lexer, T_EQUALS);
6085           if (!lex_force_string (s->lexer))
6086             goto error;
6087
6088           free (encoding);
6089           encoding = ss_xstrdup (lex_tokss (s->lexer));
6090
6091           lex_get (s->lexer);
6092         }
6093       else if (lex_match_id (s->lexer, "FIELD"))
6094         {
6095           lex_match (s->lexer, T_EQUALS);
6096
6097           if (!lex_force_int_range (s->lexer, "FIELD", 1, INT_MAX))
6098             goto error;
6099           read->c1 = lex_integer (s->lexer);
6100           lex_get (s->lexer);
6101           if (!lex_force_match (s->lexer, T_TO)
6102               || !lex_force_int_range (s->lexer, "TO", read->c1, INT_MAX))
6103             goto error;
6104           read->c2 = lex_integer (s->lexer) + 1;
6105           lex_get (s->lexer);
6106
6107           record_width = read->c2 - read->c1;
6108           if (lex_match (s->lexer, T_BY))
6109             {
6110               if (!lex_force_int_range (s->lexer, "BY", 1,
6111                                         read->c2 - read->c1))
6112                 goto error;
6113               by = lex_integer (s->lexer);
6114               lex_get (s->lexer);
6115
6116               if (record_width % by)
6117                 {
6118                   msg (SE, _("BY %d does not evenly divide record width %d."),
6119                        by, record_width);
6120                   goto error;
6121                 }
6122             }
6123           else
6124             by = 0;
6125         }
6126       else if (lex_match_id (s->lexer, "SIZE"))
6127         {
6128           lex_match (s->lexer, T_EQUALS);
6129           matrix_expr_destroy (read->size);
6130           read->size = matrix_parse_exp (s);
6131           if (!read->size)
6132             goto error;
6133         }
6134       else if (lex_match_id (s->lexer, "MODE"))
6135         {
6136           lex_match (s->lexer, T_EQUALS);
6137           if (lex_match_id (s->lexer, "RECTANGULAR"))
6138             read->symmetric = false;
6139           else if (lex_match_id (s->lexer, "SYMMETRIC"))
6140             read->symmetric = true;
6141           else
6142             {
6143               lex_error_expecting (s->lexer, "RECTANGULAR", "SYMMETRIC");
6144               goto error;
6145             }
6146         }
6147       else if (lex_match_id (s->lexer, "REREAD"))
6148         read->reread = true;
6149       else if (lex_match_id (s->lexer, "FORMAT"))
6150         {
6151           if (seen_format)
6152             {
6153               lex_sbc_only_once ("FORMAT");
6154               goto error;
6155             }
6156           seen_format = true;
6157
6158           lex_match (s->lexer, T_EQUALS);
6159
6160           if (lex_token (s->lexer) != T_STRING && !lex_force_id (s->lexer))
6161             goto error;
6162
6163           const char *p = lex_tokcstr (s->lexer);
6164           if (c_isdigit (p[0]))
6165             {
6166               repetitions = atoi (p);
6167               p += strspn (p, "0123456789");
6168               if (!fmt_from_name (p, &read->format))
6169                 {
6170                   lex_error (s->lexer, _("Unknown format %s."), p);
6171                   goto error;
6172                 }
6173               lex_get (s->lexer);
6174             }
6175           else if (fmt_from_name (p, &read->format))
6176             lex_get (s->lexer);
6177           else
6178             {
6179               struct fmt_spec format;
6180               if (!parse_format_specifier (s->lexer, &format))
6181                 goto error;
6182               read->format = format.type;
6183               read->w = format.w;
6184             }
6185         }
6186       else
6187         {
6188           lex_error_expecting (s->lexer, "FILE", "FIELD", "MODE",
6189                                "REREAD", "FORMAT");
6190           goto error;
6191         }
6192     }
6193
6194   if (!read->c1)
6195     {
6196       lex_sbc_missing ("FIELD");
6197       goto error;
6198     }
6199
6200   if (!read->dst->n_indexes && !read->size)
6201     {
6202       msg (SE, _("SIZE is required for reading data into a full matrix "
6203                  "(as opposed to a submatrix)."));
6204       goto error;
6205     }
6206
6207   if (!fh)
6208     {
6209       if (s->prev_read_file)
6210         fh = fh_ref (s->prev_read_file);
6211       else
6212         {
6213           lex_sbc_missing ("FILE");
6214           goto error;
6215         }
6216     }
6217   fh_unref (s->prev_read_file);
6218   s->prev_read_file = fh_ref (fh);
6219
6220   read->rf = read_file_create (s, fh);
6221   fh = NULL;
6222   if (encoding)
6223     {
6224       free (read->rf->encoding);
6225       read->rf->encoding = encoding;
6226       encoding = NULL;
6227     }
6228
6229   /* Field width may be specified in multiple ways:
6230
6231      1. BY on FIELD.
6232      2. The format on FORMAT.
6233      3. The repetition factor on FORMAT.
6234
6235      (2) and (3) are mutually exclusive.
6236
6237      If more than one of these is present, they must agree.  If none of them is
6238      present, then free-field format is used.
6239    */
6240   if (repetitions > record_width)
6241     {
6242       msg (SE, _("%d repetitions cannot fit in record width %d."),
6243            repetitions, record_width);
6244       goto error;
6245     }
6246   int w = (repetitions ? record_width / repetitions
6247            : read->w ? read->w
6248            : by);
6249   if (by && w != by)
6250     {
6251       if (repetitions)
6252         msg (SE, _("FORMAT specifies %d repetitions with record width %d, "
6253                    "which implies field width %d, "
6254                    "but BY specifies field width %d."),
6255              repetitions, record_width, w, by);
6256       else
6257         msg (SE, _("FORMAT specifies field width %d but BY specifies %d."),
6258              w, by);
6259       goto error;
6260     }
6261   read->w = w;
6262   return cmd;
6263
6264 error:
6265   fh_unref (fh);
6266   matrix_cmd_destroy (cmd);
6267   free (encoding);
6268   return NULL;
6269 }
6270
6271 static void
6272 parse_error (const struct dfm_reader *reader, enum fmt_type format,
6273              struct substring data, size_t y, size_t x,
6274              int first_column, int last_column, char *error)
6275 {
6276   int line_number = dfm_get_line_number (reader);
6277   struct msg_location *location = xmalloc (sizeof *location);
6278   *location = (struct msg_location) {
6279     .file_name = intern_new (dfm_get_file_name (reader)),
6280     .p[0] = { .line = line_number, .column = first_column },
6281     .p[1] = { .line = line_number, .column = last_column },
6282   };
6283   struct msg *m = xmalloc (sizeof *m);
6284   *m = (struct msg) {
6285     .category = MSG_C_DATA,
6286     .severity = MSG_S_WARNING,
6287     .location = location,
6288     .text = xasprintf (_("Error reading \"%.*s\" as format %s "
6289                          "for matrix row %zu, column %zu: %s"),
6290                        (int) data.length, data.string, fmt_name (format),
6291                        y + 1, x + 1, error),
6292   };
6293   msg_emit (m);
6294
6295   free (error);
6296 }
6297
6298 static void
6299 matrix_read_set_field (struct read_command *read, struct dfm_reader *reader,
6300                        gsl_matrix *m, struct substring p, size_t y, size_t x,
6301                        const char *line_start)
6302 {
6303   const char *input_encoding = dfm_reader_get_encoding (reader);
6304   char *error;
6305   double f;
6306   if (fmt_is_numeric (read->format))
6307     {
6308       union value v;
6309       error = data_in (p, input_encoding, read->format,
6310                        settings_get_fmt_settings (), &v, 0, NULL);
6311       if (!error && v.f == SYSMIS)
6312         error = xstrdup (_("Matrix data may not contain missing value."));
6313       f = v.f;
6314     }
6315     else
6316       {
6317         uint8_t s[sizeof (double)];
6318         union value v = { .s = s };
6319         error = data_in (p, input_encoding, read->format,
6320                          settings_get_fmt_settings (), &v, sizeof s, "UTF-8");
6321         memcpy (&f, s, sizeof f);
6322       }
6323
6324   if (error)
6325     {
6326       int c1 = utf8_count_columns (line_start, p.string - line_start) + 1;
6327       int c2 = c1 + ss_utf8_count_columns (p);
6328       parse_error (reader, read->format, p, y, x, c1, c2, error);
6329     }
6330   else
6331     {
6332       gsl_matrix_set (m, y, x, f);
6333       if (read->symmetric && x != y)
6334         gsl_matrix_set (m, x, y, f);
6335     }
6336 }
6337
6338 static bool
6339 matrix_read_line (struct read_command *read, struct dfm_reader *reader,
6340                   struct substring *line, const char **startp)
6341 {
6342   if (dfm_eof (reader))
6343     {
6344       msg (SE, _("Unexpected end of file reading matrix data."));
6345       return false;
6346     }
6347   dfm_expand_tabs (reader);
6348   struct substring record = dfm_get_record (reader);
6349   /* XXX need to recode record into UTF-8 */
6350   *startp = record.string;
6351   *line = ss_utf8_columns (record, read->c1 - 1, read->c2 - read->c1);
6352   return true;
6353 }
6354
6355 static void
6356 matrix_read (struct read_command *read, struct dfm_reader *reader,
6357              gsl_matrix *m)
6358 {
6359   for (size_t y = 0; y < m->size1; y++)
6360     {
6361       size_t nx = read->symmetric ? y + 1 : m->size2;
6362
6363       struct substring line = ss_empty ();
6364       const char *line_start = line.string;
6365       for (size_t x = 0; x < nx; x++)
6366         {
6367           struct substring p;
6368           if (!read->w)
6369             {
6370               for (;;)
6371                 {
6372                   ss_ltrim (&line, ss_cstr (" ,"));
6373                   if (!ss_is_empty (line))
6374                     break;
6375                   if (!matrix_read_line (read, reader, &line, &line_start))
6376                     return;
6377                   dfm_forward_record (reader);
6378                 }
6379
6380               ss_get_bytes (&line, ss_cspan (line, ss_cstr (" ,")), &p);
6381             }
6382           else
6383             {
6384               if (!matrix_read_line (read, reader, &line, &line_start))
6385                 return;
6386               size_t fields_per_line = (read->c2 - read->c1) / read->w;
6387               int f = x % fields_per_line;
6388               if (f == fields_per_line - 1)
6389                 dfm_forward_record (reader);
6390
6391               p = ss_substr (line, read->w * f, read->w);
6392             }
6393
6394           matrix_read_set_field (read, reader, m, p, y, x, line_start);
6395         }
6396
6397       if (read->w)
6398         dfm_forward_record (reader);
6399       else
6400         {
6401           ss_ltrim (&line, ss_cstr (" ,"));
6402           if (!ss_is_empty (line))
6403             {
6404               /* XXX */
6405               msg (SW, _("Trailing garbage on line \"%.*s\""),
6406                    (int) line.length, line.string);
6407             }
6408         }
6409     }
6410 }
6411
6412 static void
6413 matrix_cmd_execute_read (struct read_command *read)
6414 {
6415   struct index_vector iv0, iv1;
6416   if (!matrix_lvalue_evaluate (read->dst, &iv0, &iv1))
6417     return;
6418
6419   size_t size[2] = { SIZE_MAX, SIZE_MAX };
6420   if (read->size)
6421     {
6422       gsl_matrix *m = matrix_expr_evaluate (read->size);
6423       if (!m)
6424         return;
6425
6426       if (!is_vector (m))
6427         {
6428           msg (SE, _("SIZE must evaluate to a scalar or a 2-element vector, "
6429                      "not a %zu×%zu matrix."), m->size1, m->size2);
6430           gsl_matrix_free (m);
6431           free (iv0.indexes);
6432           free (iv1.indexes);
6433           return;
6434         }
6435
6436       gsl_vector v = to_vector (m);
6437       double d[2];
6438       if (v.size == 1)
6439         {
6440           d[0] = gsl_vector_get (&v, 0);
6441           d[1] = 1;
6442         }
6443       else if (v.size == 2)
6444         {
6445           d[0] = gsl_vector_get (&v, 0);
6446           d[1] = gsl_vector_get (&v, 1);
6447         }
6448       else
6449         {
6450           msg (SE, _("SIZE must evaluate to a scalar or a 2-element vector, "
6451                      "not a %zu×%zu matrix."),
6452                m->size1, m->size2),
6453           gsl_matrix_free (m);
6454           free (iv0.indexes);
6455           free (iv1.indexes);
6456           return;
6457         }
6458       gsl_matrix_free (m);
6459
6460       if (d[0] < 0 || d[0] > SIZE_MAX || d[1] < 0 || d[1] > SIZE_MAX)
6461         {
6462           msg (SE, _("Matrix dimensions %g×%g specified on SIZE "
6463                      "are outside valid range."),
6464                d[0], d[1]);
6465           free (iv0.indexes);
6466           free (iv1.indexes);
6467           return;
6468         }
6469
6470       size[0] = d[0];
6471       size[1] = d[1];
6472     }
6473
6474   if (read->dst->n_indexes)
6475     {
6476       size_t submatrix_size[2];
6477       if (read->dst->n_indexes == 2)
6478         {
6479           submatrix_size[0] = iv0.n;
6480           submatrix_size[1] = iv1.n;
6481         }
6482       else if (read->dst->var->value->size1 == 1)
6483         {
6484           submatrix_size[0] = 1;
6485           submatrix_size[1] = iv0.n;
6486         }
6487       else
6488         {
6489           submatrix_size[0] = iv0.n;
6490           submatrix_size[1] = 1;
6491         }
6492
6493       if (read->size)
6494         {
6495           if (size[0] != submatrix_size[0] || size[1] != submatrix_size[1])
6496             {
6497               msg (SE, _("Matrix dimensions %zu×%zu specified on SIZE "
6498                          "differ from submatrix dimensions %zu×%zu."),
6499                    size[0], size[1],
6500                    submatrix_size[0], submatrix_size[1]);
6501               free (iv0.indexes);
6502               free (iv1.indexes);
6503               return;
6504             }
6505         }
6506       else
6507         {
6508           size[0] = submatrix_size[0];
6509           size[1] = submatrix_size[1];
6510         }
6511     }
6512
6513   struct dfm_reader *reader = read_file_open (read->rf);
6514   if (read->reread)
6515     dfm_reread_record (reader, 1);
6516
6517   if (read->symmetric && size[0] != size[1])
6518     {
6519       msg (SE, _("Cannot read non-square %zu×%zu matrix "
6520                  "using READ with MODE=SYMMETRIC."),
6521            size[0], size[1]);
6522       free (iv0.indexes);
6523       free (iv1.indexes);
6524       return;
6525     }
6526   gsl_matrix *tmp = gsl_matrix_calloc (size[0], size[1]);
6527   matrix_read (read, reader, tmp);
6528   matrix_lvalue_assign (read->dst, &iv0, &iv1, tmp);
6529 }
6530 \f
6531 static struct matrix_cmd *
6532 matrix_parse_write (struct matrix_state *s)
6533 {
6534   struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
6535   *cmd = (struct matrix_cmd) {
6536     .type = MCMD_WRITE,
6537   };
6538
6539   struct file_handle *fh = NULL;
6540   char *encoding = NULL;
6541   struct write_command *write = &cmd->write;
6542   write->expression = matrix_parse_exp (s);
6543   if (!write->expression)
6544     goto error;
6545
6546   int by = 0;
6547   int repetitions = 0;
6548   int record_width = 0;
6549   enum fmt_type format = FMT_F;
6550   bool has_format = false;
6551   while (lex_match (s->lexer, T_SLASH))
6552     {
6553       if (lex_match_id (s->lexer, "OUTFILE"))
6554         {
6555           lex_match (s->lexer, T_EQUALS);
6556
6557           fh_unref (fh);
6558           fh = fh_parse (s->lexer, FH_REF_FILE, NULL);
6559           if (!fh)
6560             goto error;
6561         }
6562       else if (lex_match_id (s->lexer, "ENCODING"))
6563         {
6564           lex_match (s->lexer, T_EQUALS);
6565           if (!lex_force_string (s->lexer))
6566             goto error;
6567
6568           free (encoding);
6569           encoding = ss_xstrdup (lex_tokss (s->lexer));
6570
6571           lex_get (s->lexer);
6572         }
6573       else if (lex_match_id (s->lexer, "FIELD"))
6574         {
6575           lex_match (s->lexer, T_EQUALS);
6576
6577           if (!lex_force_int_range (s->lexer, "FIELD", 1, INT_MAX))
6578             goto error;
6579           write->c1 = lex_integer (s->lexer);
6580           lex_get (s->lexer);
6581           if (!lex_force_match (s->lexer, T_TO)
6582               || !lex_force_int_range (s->lexer, "TO", write->c1, INT_MAX))
6583             goto error;
6584           write->c2 = lex_integer (s->lexer) + 1;
6585           lex_get (s->lexer);
6586
6587           record_width = write->c2 - write->c1;
6588           if (lex_match (s->lexer, T_BY))
6589             {
6590               if (!lex_force_int_range (s->lexer, "BY", 1,
6591                                         write->c2 - write->c1))
6592                 goto error;
6593               by = lex_integer (s->lexer);
6594               lex_get (s->lexer);
6595
6596               if (record_width % by)
6597                 {
6598                   msg (SE, _("BY %d does not evenly divide record width %d."),
6599                        by, record_width);
6600                   goto error;
6601                 }
6602             }
6603           else
6604             by = 0;
6605         }
6606       else if (lex_match_id (s->lexer, "MODE"))
6607         {
6608           lex_match (s->lexer, T_EQUALS);
6609           if (lex_match_id (s->lexer, "RECTANGULAR"))
6610             write->triangular = false;
6611           else if (lex_match_id (s->lexer, "TRIANGULAR"))
6612             write->triangular = true;
6613           else
6614             {
6615               lex_error_expecting (s->lexer, "RECTANGULAR", "TRIANGULAR");
6616               goto error;
6617             }
6618         }
6619       else if (lex_match_id (s->lexer, "HOLD"))
6620         write->hold = true;
6621       else if (lex_match_id (s->lexer, "FORMAT"))
6622         {
6623           if (has_format || write->format)
6624             {
6625               lex_sbc_only_once ("FORMAT");
6626               goto error;
6627             }
6628
6629           lex_match (s->lexer, T_EQUALS);
6630
6631           if (lex_token (s->lexer) != T_STRING && !lex_force_id (s->lexer))
6632             goto error;
6633
6634           const char *p = lex_tokcstr (s->lexer);
6635           if (c_isdigit (p[0]))
6636             {
6637               repetitions = atoi (p);
6638               p += strspn (p, "0123456789");
6639               if (!fmt_from_name (p, &format))
6640                 {
6641                   lex_error (s->lexer, _("Unknown format %s."), p);
6642                   goto error;
6643                 }
6644               has_format = true;
6645               lex_get (s->lexer);
6646             }
6647           else if (fmt_from_name (p, &format))
6648             {
6649               has_format = true;
6650               lex_get (s->lexer);
6651             }
6652           else
6653             {
6654               struct fmt_spec spec;
6655               if (!parse_format_specifier (s->lexer, &spec))
6656                 goto error;
6657               write->format = xmemdup (&spec, sizeof spec);
6658             }
6659         }
6660       else
6661         {
6662           lex_error_expecting (s->lexer, "OUTFILE", "FIELD", "MODE",
6663                                "HOLD", "FORMAT");
6664           goto error;
6665         }
6666     }
6667
6668   if (!write->c1)
6669     {
6670       lex_sbc_missing ("FIELD");
6671       goto error;
6672     }
6673
6674   if (!fh)
6675     {
6676       if (s->prev_write_file)
6677         fh = fh_ref (s->prev_write_file);
6678       else
6679         {
6680           lex_sbc_missing ("OUTFILE");
6681           goto error;
6682         }
6683     }
6684   fh_unref (s->prev_write_file);
6685   s->prev_write_file = fh_ref (fh);
6686
6687   write->wf = write_file_create (s, fh);
6688   fh = NULL;
6689   if (encoding)
6690     {
6691       free (write->wf->encoding);
6692       write->wf->encoding = encoding;
6693       encoding = NULL;
6694     }
6695
6696   /* Field width may be specified in multiple ways:
6697
6698      1. BY on FIELD.
6699      2. The format on FORMAT.
6700      3. The repetition factor on FORMAT.
6701
6702      (2) and (3) are mutually exclusive.
6703
6704      If more than one of these is present, they must agree.  If none of them is
6705      present, then free-field format is used.
6706    */
6707   if (repetitions > record_width)
6708     {
6709       msg (SE, _("%d repetitions cannot fit in record width %d."),
6710            repetitions, record_width);
6711       goto error;
6712     }
6713   int w = (repetitions ? record_width / repetitions
6714            : write->format ? write->format->w
6715            : by);
6716   if (by && w != by)
6717     {
6718       if (repetitions)
6719         msg (SE, _("FORMAT specifies %d repetitions with record width %d, "
6720                    "which implies field width %d, "
6721                    "but BY specifies field width %d."),
6722              repetitions, record_width, w, by);
6723       else
6724         msg (SE, _("FORMAT specifies field width %d but BY specifies %d."),
6725              w, by);
6726       goto error;
6727     }
6728   if (w && !write->format)
6729     {
6730       write->format = xmalloc (sizeof *write->format);
6731       *write->format = (struct fmt_spec) { .type = format, .w = w };
6732
6733       if (!fmt_check_output (write->format))
6734         goto error;
6735     };
6736
6737   if (write->format && fmt_var_width (write->format) > sizeof (double))
6738     {
6739       char s[FMT_STRING_LEN_MAX + 1];
6740       fmt_to_string (write->format, s);
6741       msg (SE, _("Format %s is too wide for %zu-byte matrix eleemnts."),
6742            s, sizeof (double));
6743       goto error;
6744     }
6745
6746   return cmd;
6747
6748 error:
6749   fh_unref (fh);
6750   matrix_cmd_destroy (cmd);
6751   return NULL;
6752 }
6753
6754 static void
6755 matrix_cmd_execute_write (struct write_command *write)
6756 {
6757   gsl_matrix *m = matrix_expr_evaluate (write->expression);
6758   if (!m)
6759     return;
6760
6761   if (write->triangular && m->size1 != m->size2)
6762     {
6763       msg (SE, _("WRITE with MODE=TRIANGULAR requires a square matrix but "
6764                  "the matrix to be written has dimensions %zu×%zu."),
6765            m->size1, m->size2);
6766       gsl_matrix_free (m);
6767       return;
6768     }
6769
6770   struct dfm_writer *writer = write_file_open (write->wf);
6771   if (!writer || !m->size1)
6772     {
6773       gsl_matrix_free (m);
6774       return;
6775     }
6776
6777   const struct fmt_settings *settings = settings_get_fmt_settings ();
6778   struct u8_line *line = write->wf->held;
6779   for (size_t y = 0; y < m->size1; y++)
6780     {
6781       if (!line)
6782         {
6783           line = xmalloc (sizeof *line);
6784           u8_line_init (line);
6785         }
6786       size_t nx = write->triangular ? y + 1 : m->size2;
6787       int x0 = write->c1;
6788       for (size_t x = 0; x < nx; x++)
6789         {
6790           char *s;
6791           double f = gsl_matrix_get (m, y, x);
6792           if (write->format)
6793             {
6794               union value v;
6795               if (fmt_is_numeric (write->format->type))
6796                 v.f = f;
6797               else
6798                 v.s = (uint8_t *) &f;
6799               s = data_out (&v, NULL, write->format, settings);
6800             }
6801           else
6802             {
6803               s = xmalloc (DBL_BUFSIZE_BOUND);
6804               if (c_dtoastr (s, DBL_BUFSIZE_BOUND, FTOASTR_UPPER_E, 0, f)
6805                   >= DBL_BUFSIZE_BOUND)
6806                 abort ();
6807             }
6808           size_t len = strlen (s);
6809           int width = u8_width (CHAR_CAST (const uint8_t *, s), len, UTF8);
6810           if (width + x0 > write->c2)
6811             {
6812               dfm_put_record_utf8 (writer, line->s.ss.string,
6813                                    line->s.ss.length);
6814               u8_line_clear (line);
6815               x0 = write->c1;
6816             }
6817           u8_line_put (line, x0, x0 + width, s, len);
6818           free (s);
6819
6820           x0 += write->format ? write->format->w : width + 1;
6821         }
6822
6823       if (y + 1 >= m->size1 && write->hold)
6824         break;
6825       dfm_put_record_utf8 (writer, line->s.ss.string, line->s.ss.length);
6826       u8_line_clear (line);
6827     }
6828   if (!write->hold)
6829     {
6830       u8_line_destroy (line);
6831       free (line);
6832       line = NULL;
6833     }
6834   write->wf->held = line;
6835
6836   gsl_matrix_free (m);
6837 }
6838 \f
6839 static struct matrix_cmd *
6840 matrix_parse_get (struct matrix_state *s)
6841 {
6842   struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
6843   *cmd = (struct matrix_cmd) {
6844     .type = MCMD_GET,
6845     .get = {
6846       .dataset = s->dataset,
6847       .user = { .treatment = MGET_ERROR },
6848       .system = { .treatment = MGET_ERROR },
6849     }
6850   };
6851
6852   struct get_command *get = &cmd->get;
6853   get->dst = matrix_lvalue_parse (s);
6854   if (!get->dst)
6855     goto error;
6856
6857   while (lex_match (s->lexer, T_SLASH))
6858     {
6859       if (lex_match_id (s->lexer, "FILE"))
6860         {
6861           lex_match (s->lexer, T_EQUALS);
6862
6863           fh_unref (get->file);
6864           if (lex_match (s->lexer, T_ASTERISK))
6865             get->file = NULL;
6866           else
6867             {
6868               get->file = fh_parse (s->lexer, FH_REF_FILE, s->session);
6869               if (!get->file)
6870                 goto error;
6871             }
6872         }
6873       else if (lex_match_id (s->lexer, "ENCODING"))
6874         {
6875           lex_match (s->lexer, T_EQUALS);
6876           if (!lex_force_string (s->lexer))
6877             goto error;
6878
6879           free (get->encoding);
6880           get->encoding = ss_xstrdup (lex_tokss (s->lexer));
6881
6882           lex_get (s->lexer);
6883         }
6884       else if (lex_match_id (s->lexer, "VARIABLES"))
6885         {
6886           lex_match (s->lexer, T_EQUALS);
6887
6888           if (get->n_vars)
6889             {
6890               lex_sbc_only_once ("VARIABLES");
6891               goto error;
6892             }
6893
6894           if (!var_syntax_parse (s->lexer, &get->vars, &get->n_vars))
6895             goto error;
6896         }
6897       else if (lex_match_id (s->lexer, "NAMES"))
6898         {
6899           lex_match (s->lexer, T_EQUALS);
6900           if (!lex_force_id (s->lexer))
6901             goto error;
6902
6903           struct substring name = lex_tokss (s->lexer);
6904           get->names = matrix_var_lookup (s, name);
6905           if (!get->names)
6906             get->names = matrix_var_create (s, name);
6907           lex_get (s->lexer);
6908         }
6909       else if (lex_match_id (s->lexer, "MISSING"))
6910         {
6911           lex_match (s->lexer, T_EQUALS);
6912           if (lex_match_id (s->lexer, "ACCEPT"))
6913             get->user.treatment = MGET_ACCEPT;
6914           else if (lex_match_id (s->lexer, "OMIT"))
6915             get->user.treatment = MGET_OMIT;
6916           else if (lex_is_number (s->lexer))
6917             {
6918               get->user.treatment = MGET_RECODE;
6919               get->user.substitute = lex_number (s->lexer);
6920               lex_get (s->lexer);
6921             }
6922           else
6923             {
6924               lex_error (s->lexer, NULL);
6925               goto error;
6926             }
6927         }
6928       else if (lex_match_id (s->lexer, "SYSMIS"))
6929         {
6930           lex_match (s->lexer, T_EQUALS);
6931           if (lex_match_id (s->lexer, "OMIT"))
6932             get->system.treatment = MGET_OMIT;
6933           else if (lex_is_number (s->lexer))
6934             {
6935               get->system.treatment = MGET_RECODE;
6936               get->system.substitute = lex_number (s->lexer);
6937               lex_get (s->lexer);
6938             }
6939           else
6940             {
6941               lex_error (s->lexer, NULL);
6942               goto error;
6943             }
6944         }
6945       else
6946         {
6947           lex_error_expecting (s->lexer, "FILE", "VARIABLES", "NAMES",
6948                                "MISSING", "SYSMIS");
6949           goto error;
6950         }
6951     }
6952
6953   if (get->user.treatment != MGET_ACCEPT)
6954     get->system.treatment = MGET_ERROR;
6955
6956   return cmd;
6957
6958 error:
6959   matrix_cmd_destroy (cmd);
6960   return NULL;
6961 }
6962
6963 static void
6964 matrix_cmd_execute_get__ (struct get_command *get, struct casereader *reader,
6965                           const struct dictionary *dict)
6966 {
6967   struct variable **vars;
6968   size_t n_vars = 0;
6969
6970   if (get->n_vars)
6971     {
6972       if (!var_syntax_evaluate (get->vars, get->n_vars, dict,
6973                                 &vars, &n_vars, PV_NUMERIC))
6974         return;
6975     }
6976   else
6977     {
6978       n_vars = dict_get_var_cnt (dict);
6979       vars = xnmalloc (n_vars, sizeof *vars);
6980       for (size_t i = 0; i < n_vars; i++)
6981         {
6982           struct variable *var = dict_get_var (dict, i);
6983           if (!var_is_numeric (var))
6984             {
6985               msg (SE, _("GET: Variable %s is not numeric."),
6986                    var_get_name (var));
6987               free (vars);
6988               return;
6989             }
6990           vars[i] = var;
6991         }
6992     }
6993
6994   if (get->names)
6995     {
6996       gsl_matrix *names = gsl_matrix_alloc (n_vars, 1);
6997       for (size_t i = 0; i < n_vars; i++)
6998         {
6999           char s[sizeof (double)];
7000           double f;
7001           buf_copy_str_rpad (s, sizeof s, var_get_name (vars[i]), ' ');
7002           memcpy (&f, s, sizeof f);
7003           gsl_matrix_set (names, i, 0, f);
7004         }
7005
7006       gsl_matrix_free (get->names->value);
7007       get->names->value = names;
7008     }
7009
7010   size_t n_rows = 0;
7011   gsl_matrix *m = gsl_matrix_alloc (4, n_vars);
7012   long long int casenum = 1;
7013   bool error = false;
7014   for (struct ccase *c = casereader_read (reader); c;
7015        c = casereader_read (reader), casenum++)
7016     {
7017       if (n_rows >= m->size1)
7018         {
7019           gsl_matrix *p = gsl_matrix_alloc (m->size1 * 2, n_vars);
7020           for (size_t y = 0; y < n_rows; y++)
7021             for (size_t x = 0; x < n_vars; x++)
7022               gsl_matrix_set (p, y, x, gsl_matrix_get (m, y, x));
7023           gsl_matrix_free (m);
7024           m = p;
7025         }
7026
7027       bool keep = true;
7028       for (size_t x = 0; x < n_vars; x++)
7029         {
7030           const struct variable *var = vars[x];
7031           double d = case_num (c, var);
7032           if (d == SYSMIS)
7033             {
7034               if (get->system.treatment == MGET_RECODE)
7035                 d = get->system.substitute;
7036               else if (get->system.treatment == MGET_OMIT)
7037                 keep = false;
7038               else
7039                 {
7040                   msg (SE, _("GET: Variable %s in case %lld "
7041                              "is system-missing."),
7042                        var_get_name (var), casenum);
7043                   error = true;
7044                 }
7045             }
7046           else if (var_is_num_missing (var, d, MV_USER))
7047             {
7048               if (get->user.treatment == MGET_RECODE)
7049                 d = get->user.substitute;
7050               else if (get->user.treatment == MGET_OMIT)
7051                 keep = false;
7052               else if (get->user.treatment != MGET_ACCEPT)
7053                 {
7054                   msg (SE, _("GET: Variable %s in case %lld has user-missing "
7055                              "value %g."),
7056                        var_get_name (var), casenum, d);
7057                   error = true;
7058                 }
7059             }
7060           gsl_matrix_set (m, n_rows, x, d);
7061         }
7062       case_unref (c);
7063       if (error)
7064         break;
7065       if (keep)
7066         n_rows++;
7067     }
7068   if (!error)
7069     {
7070       m->size1 = n_rows;
7071       matrix_lvalue_evaluate_and_assign (get->dst, m);
7072     }
7073   else
7074     gsl_matrix_free (m);
7075   free (vars);
7076 }
7077
7078 static bool
7079 matrix_open_casereader (const char *command_name,
7080                         struct file_handle *file, const char *encoding,
7081                         struct dataset *dataset,
7082                         struct casereader **readerp, struct dictionary **dictp)
7083 {
7084   if (file)
7085     {
7086        *readerp = any_reader_open_and_decode (file, encoding, dictp, NULL);
7087        return *readerp != NULL;
7088     }
7089   else
7090     {
7091       if (dict_get_var_cnt (dataset_dict (dataset)) == 0)
7092         {
7093           msg (ME, _("The %s command cannot read an empty active file."),
7094                command_name);
7095           return false;
7096         }
7097       *readerp = proc_open (dataset);
7098       *dictp = dict_ref (dataset_dict (dataset));
7099       return true;
7100     }
7101 }
7102
7103 static void
7104 matrix_close_casereader (struct file_handle *file, struct dataset *dataset,
7105                          struct casereader *reader, struct dictionary *dict)
7106 {
7107   dict_unref (dict);
7108   casereader_destroy (reader);
7109   if (!file)
7110     proc_commit (dataset);
7111 }
7112
7113 static void
7114 matrix_cmd_execute_get (struct get_command *get)
7115 {
7116   struct casereader *r;
7117   struct dictionary *d;
7118   if (matrix_open_casereader ("GET", get->file, get->encoding, get->dataset,
7119                               &r, &d))
7120     {
7121       matrix_cmd_execute_get__ (get, r, d);
7122       matrix_close_casereader (get->file, get->dataset, r, d);
7123     }
7124 }
7125 \f
7126 static const char *
7127 match_rowtype (struct lexer *lexer)
7128 {
7129   static const char *rowtypes[] = {
7130     "COV", "CORR", "MEAN", "STDDEV", "N", "COUNT"
7131   };
7132   size_t n_rowtypes = sizeof rowtypes / sizeof *rowtypes;
7133
7134   for (size_t i = 0; i < n_rowtypes; i++)
7135     if (lex_match_id (lexer, rowtypes[i]))
7136       return rowtypes[i];
7137
7138   lex_error_expecting_array (lexer, rowtypes, n_rowtypes);
7139   return NULL;
7140 }
7141
7142 static bool
7143 parse_var_names (struct lexer *lexer, struct string_array *sa)
7144 {
7145   lex_match (lexer, T_EQUALS);
7146
7147   string_array_clear (sa);
7148
7149   struct dictionary *dict = dict_create (get_default_encoding ());
7150   char **names;
7151   size_t n_names;
7152   bool ok = parse_DATA_LIST_vars (lexer, dict, &names, &n_names,
7153                                   PV_NO_DUPLICATE | PV_NO_SCRATCH);
7154   dict_unref (dict);
7155
7156   if (ok)
7157     {
7158       for (size_t i = 0; i < n_names; i++)
7159         if (ss_equals_case (ss_cstr (names[i]), ss_cstr ("ROWTYPE_"))
7160             || ss_equals_case (ss_cstr (names[i]), ss_cstr ("VARNAME_")))
7161           {
7162             msg (SE, _("Variable name %s is reserved."), names[i]);
7163             for (size_t j = 0; j < n_names; j++)
7164               free (names[i]);
7165             free (names);
7166             return false;
7167           }
7168
7169       string_array_clear (sa);
7170       sa->strings = names;
7171       sa->n = sa->allocated = n_names;
7172     }
7173   return ok;
7174 }
7175
7176 static void
7177 msave_common_destroy (struct msave_common *common)
7178 {
7179   if (common)
7180     {
7181       fh_unref (common->outfile);
7182       string_array_destroy (&common->variables);
7183       string_array_destroy (&common->fnames);
7184       string_array_destroy (&common->snames);
7185
7186       for (size_t i = 0; i < common->n_factors; i++)
7187         matrix_expr_destroy (common->factors[i]);
7188       free (common->factors);
7189
7190       for (size_t i = 0; i < common->n_splits; i++)
7191         matrix_expr_destroy (common->splits[i]);
7192       free (common->splits);
7193
7194       dict_unref (common->dict);
7195       casewriter_destroy (common->writer);
7196
7197       free (common);
7198     }
7199 }
7200
7201 static bool
7202 compare_variables (const char *keyword,
7203                    const struct string_array *new,
7204                    const struct string_array *old)
7205 {
7206   if (new->n)
7207     {
7208       if (!old->n)
7209         {
7210           msg (SE, _("%s may only be specified on MSAVE if it was specified "
7211                      "on the first MSAVE within MATRIX."), keyword);
7212           return false;
7213         }
7214       else if (!string_array_equal_case (old, new))
7215         {
7216           msg (SE, _("%s must specify the same variables each time within "
7217                      "a given MATRIX."), keyword);
7218           return false;
7219         }
7220     }
7221   return true;
7222 }
7223
7224 static struct matrix_cmd *
7225 matrix_parse_msave (struct matrix_state *s)
7226 {
7227   struct msave_common *common = xmalloc (sizeof *common);
7228   *common = (struct msave_common) { .outfile = NULL };
7229
7230   struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
7231   *cmd = (struct matrix_cmd) { .type = MCMD_MSAVE, .msave = { .expr = NULL } };
7232
7233   struct matrix_expr *splits = NULL;
7234   struct matrix_expr *factors = NULL;
7235
7236   struct msave_command *msave = &cmd->msave;
7237   msave->expr = matrix_parse_exp (s);
7238   if (!msave->expr)
7239     goto error;
7240
7241   while (lex_match (s->lexer, T_SLASH))
7242     {
7243       if (lex_match_id (s->lexer, "TYPE"))
7244         {
7245           lex_match (s->lexer, T_EQUALS);
7246
7247           msave->rowtype = match_rowtype (s->lexer);
7248           if (!msave->rowtype)
7249             goto error;
7250         }
7251       else if (lex_match_id (s->lexer, "OUTFILE"))
7252         {
7253           lex_match (s->lexer, T_EQUALS);
7254
7255           fh_unref (common->outfile);
7256           common->outfile = fh_parse (s->lexer, FH_REF_FILE, NULL);
7257           if (!common->outfile)
7258             goto error;
7259         }
7260       else if (lex_match_id (s->lexer, "VARIABLES"))
7261         {
7262           if (!parse_var_names (s->lexer, &common->variables))
7263             goto error;
7264         }
7265       else if (lex_match_id (s->lexer, "FNAMES"))
7266         {
7267           if (!parse_var_names (s->lexer, &common->fnames))
7268             goto error;
7269         }
7270       else if (lex_match_id (s->lexer, "SNAMES"))
7271         {
7272           if (!parse_var_names (s->lexer, &common->snames))
7273             goto error;
7274         }
7275       else if (lex_match_id (s->lexer, "SPLIT"))
7276         {
7277           lex_match (s->lexer, T_EQUALS);
7278
7279           matrix_expr_destroy (splits);
7280           splits = matrix_parse_exp (s);
7281           if (!splits)
7282             goto error;
7283         }
7284       else if (lex_match_id (s->lexer, "FACTOR"))
7285         {
7286           lex_match (s->lexer, T_EQUALS);
7287
7288           matrix_expr_destroy (factors);
7289           factors = matrix_parse_exp (s);
7290           if (!factors)
7291             goto error;
7292         }
7293       else
7294         {
7295           lex_error_expecting (s->lexer, "TYPE", "OUTFILE", "VARIABLES",
7296                                "FNAMES", "SNAMES", "SPLIT", "FACTOR");
7297           goto error;
7298         }
7299     }
7300   if (!msave->rowtype)
7301     {
7302       lex_sbc_missing ("TYPE");
7303       goto error;
7304     }
7305
7306   if (!s->common)
7307     {
7308       if (common->fnames.n && !factors)
7309         {
7310           msg (SE, _("FNAMES requires FACTOR."));
7311           goto error;
7312         }
7313       if (common->snames.n && !splits)
7314         {
7315           msg (SE, _("SNAMES requires SPLIT."));
7316           goto error;
7317         }
7318       if (!common->outfile)
7319         {
7320           lex_sbc_missing ("OUTFILE");
7321           goto error;
7322         }
7323       s->common = common;
7324     }
7325   else
7326     {
7327       if (common->outfile)
7328         {
7329           if (!fh_equal (common->outfile, s->common->outfile))
7330             {
7331               msg (SE, _("OUTFILE must name the same file on each MSAVE "
7332                          "within a single MATRIX command."));
7333               goto error;
7334             }
7335         }
7336       if (!compare_variables ("VARIABLES",
7337                               &common->variables, &s->common->variables)
7338           || !compare_variables ("FNAMES", &common->fnames, &s->common->fnames)
7339           || !compare_variables ("SNAMES", &common->snames, &s->common->snames))
7340         goto error;
7341       msave_common_destroy (common);
7342     }
7343   msave->common = s->common;
7344
7345   struct msave_common *c = s->common;
7346   if (factors)
7347     {
7348       if (c->n_factors >= c->allocated_factors)
7349         c->factors = x2nrealloc (c->factors, &c->allocated_factors,
7350                                  sizeof *c->factors);
7351       c->factors[c->n_factors++] = factors;
7352     }
7353   if (c->n_factors > 0)
7354     msave->factors = c->factors[c->n_factors - 1];
7355
7356   if (splits)
7357     {
7358       if (c->n_splits >= c->allocated_splits)
7359         c->splits = x2nrealloc (c->splits, &c->allocated_splits,
7360                                 sizeof *c->splits);
7361       c->splits[c->n_splits++] = splits;
7362     }
7363   if (c->n_splits > 0)
7364     msave->splits = c->splits[c->n_splits - 1];
7365
7366   return cmd;
7367
7368 error:
7369   matrix_expr_destroy (splits);
7370   matrix_expr_destroy (factors);
7371   msave_common_destroy (common);
7372   matrix_cmd_destroy (cmd);
7373   return NULL;
7374 }
7375
7376 static gsl_vector *
7377 matrix_expr_evaluate_vector (const struct matrix_expr *e, const char *name)
7378 {
7379   gsl_matrix *m = matrix_expr_evaluate (e);
7380   if (!m)
7381     return NULL;
7382
7383   if (!is_vector (m))
7384     {
7385       msg (SE, _("%s expression must evaluate to vector, "
7386                  "not a %zu×%zu matrix."),
7387            name, m->size1, m->size2);
7388       gsl_matrix_free (m);
7389       return NULL;
7390     }
7391
7392   return matrix_to_vector (m);
7393 }
7394
7395 static const char *
7396 msave_add_vars (struct dictionary *d, const struct string_array *vars)
7397 {
7398   for (size_t i = 0; i < vars->n; i++)
7399     if (!dict_create_var (d, vars->strings[i], 0))
7400       return vars->strings[i];
7401   return NULL;
7402 }
7403
7404 static struct dictionary *
7405 msave_create_dict (const struct msave_common *common)
7406 {
7407   struct dictionary *dict = dict_create (get_default_encoding ());
7408
7409   const char *dup_split = msave_add_vars (dict, &common->snames);
7410   if (dup_split)
7411     {
7412       /* Should not be possible because the parser ensures that the names are
7413          unique. */
7414       NOT_REACHED ();
7415     }
7416
7417   dict_create_var_assert (dict, "ROWTYPE_", 8);
7418
7419   const char *dup_factor = msave_add_vars (dict, &common->fnames);
7420   if (dup_factor)
7421     {
7422       msg (SE, _("Duplicate or invalid FACTOR variable name %s."), dup_factor);
7423       goto error;
7424     }
7425
7426   dict_create_var_assert (dict, "VARNAME_", 8);
7427
7428   const char *dup_var = msave_add_vars (dict, &common->variables);
7429   if (dup_var)
7430     {
7431       msg (SE, _("Duplicate or invalid variable name %s."), dup_var);
7432       goto error;
7433     }
7434
7435   return dict;
7436
7437 error:
7438   dict_unref (dict);
7439   return NULL;
7440 }
7441
7442 static void
7443 matrix_cmd_execute_msave (struct msave_command *msave)
7444 {
7445   struct msave_common *common = msave->common;
7446   gsl_matrix *m = NULL;
7447   gsl_vector *factors = NULL;
7448   gsl_vector *splits = NULL;
7449
7450   m = matrix_expr_evaluate (msave->expr);
7451   if (!m)
7452     goto error;
7453
7454   if (!common->variables.n)
7455     for (size_t i = 0; i < m->size2; i++)
7456       string_array_append_nocopy (&common->variables,
7457                                   xasprintf ("COL%zu", i + 1));
7458   else if (m->size2 != common->variables.n)
7459     {
7460       msg (SE,
7461            _("Matrix on MSAVE has %zu columns but there are %zu variables."),
7462            m->size2, common->variables.n);
7463       goto error;
7464     }
7465
7466   if (msave->factors)
7467     {
7468       factors = matrix_expr_evaluate_vector (msave->factors, "FACTOR");
7469       if (!factors)
7470         goto error;
7471
7472       if (!common->fnames.n)
7473         for (size_t i = 0; i < factors->size; i++)
7474           string_array_append_nocopy (&common->fnames,
7475                                       xasprintf ("FAC%zu", i + 1));
7476       else if (factors->size != common->fnames.n)
7477         {
7478           msg (SE, _("There are %zu factor variables, "
7479                      "but %zu factor values were supplied."),
7480                common->fnames.n, factors->size);
7481           goto error;
7482         }
7483     }
7484
7485   if (msave->splits)
7486     {
7487       splits = matrix_expr_evaluate_vector (msave->splits, "SPLIT");
7488       if (!splits)
7489         goto error;
7490
7491       if (!common->snames.n)
7492         for (size_t i = 0; i < splits->size; i++)
7493           string_array_append_nocopy (&common->snames,
7494                                       xasprintf ("SPL%zu", i + 1));
7495       else if (splits->size != common->snames.n)
7496         {
7497           msg (SE, _("There are %zu split variables, "
7498                      "but %zu split values were supplied."),
7499                common->snames.n, splits->size);
7500           goto error;
7501         }
7502     }
7503
7504   if (!common->writer)
7505     {
7506       struct dictionary *dict = msave_create_dict (common);
7507       if (!dict)
7508         goto error;
7509
7510       common->writer = any_writer_open (common->outfile, dict);
7511       if (!common->writer)
7512         {
7513           dict_unref (dict);
7514           goto error;
7515         }
7516
7517       common->dict = dict;
7518     }
7519
7520   bool matrix = (!strcmp (msave->rowtype, "COV")
7521                  || !strcmp (msave->rowtype, "CORR"));
7522   for (size_t y = 0; y < m->size1; y++)
7523     {
7524       struct ccase *c = case_create (dict_get_proto (common->dict));
7525       size_t idx = 0;
7526
7527       /* Split variables */
7528       if (splits)
7529         for (size_t i = 0; i < splits->size; i++)
7530           case_data_rw_idx (c, idx++)->f = gsl_vector_get (splits, i);
7531
7532       /* ROWTYPE_. */
7533       buf_copy_str_rpad (CHAR_CAST (char *, case_data_rw_idx (c, idx++)->s), 8,
7534                          msave->rowtype, ' ');
7535
7536       /* Factors. */
7537       if (factors)
7538         for (size_t i = 0; i < factors->size; i++)
7539           *case_num_rw_idx (c, idx++) = gsl_vector_get (factors, i);
7540
7541       /* VARNAME_. */
7542       const char *varname_ = (matrix && y < common->variables.n
7543                               ? common->variables.strings[y]
7544                               : "");
7545       buf_copy_str_rpad (CHAR_CAST (char *, case_data_rw_idx (c, idx++)->s), 8,
7546                          varname_, ' ');
7547
7548       /* Continuous variables. */
7549       for (size_t x = 0; x < m->size2; x++)
7550         case_data_rw_idx (c, idx++)->f = gsl_matrix_get (m, y, x);
7551       casewriter_write (common->writer, c);
7552     }
7553
7554 error:
7555   gsl_matrix_free (m);
7556   gsl_vector_free (factors);
7557   gsl_vector_free (splits);
7558 }
7559 \f
7560 static struct matrix_cmd *
7561 matrix_parse_mget (struct matrix_state *s)
7562 {
7563   struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
7564   *cmd = (struct matrix_cmd) {
7565     .type = MCMD_MGET,
7566     .mget = {
7567       .state = s,
7568       .rowtypes = STRINGI_SET_INITIALIZER (cmd->mget.rowtypes),
7569     },
7570   };
7571
7572   struct mget_command *mget = &cmd->mget;
7573
7574   lex_match (s->lexer, T_SLASH);
7575   while (lex_token (s->lexer) != T_ENDCMD)
7576     {
7577       if (lex_match_id (s->lexer, "FILE"))
7578         {
7579           lex_match (s->lexer, T_EQUALS);
7580
7581           fh_unref (mget->file);
7582           mget->file = fh_parse (s->lexer, FH_REF_FILE, s->session);
7583           if (!mget->file)
7584             goto error;
7585         }
7586       else if (lex_match_id (s->lexer, "ENCODING"))
7587         {
7588           lex_match (s->lexer, T_EQUALS);
7589           if (!lex_force_string (s->lexer))
7590             goto error;
7591
7592           free (mget->encoding);
7593           mget->encoding = ss_xstrdup (lex_tokss (s->lexer));
7594
7595           lex_get (s->lexer);
7596         }
7597       else if (lex_match_id (s->lexer, "TYPE"))
7598         {
7599           lex_match (s->lexer, T_EQUALS);
7600           while (lex_token (s->lexer) != T_SLASH
7601                  && lex_token (s->lexer) != T_ENDCMD)
7602             {
7603               const char *rowtype = match_rowtype (s->lexer);
7604               if (!rowtype)
7605                 goto error;
7606
7607               stringi_set_insert (&mget->rowtypes, rowtype);
7608             }
7609         }
7610       else
7611         {
7612           lex_error_expecting (s->lexer, "FILE", "TYPE");
7613           goto error;
7614         }
7615       lex_match (s->lexer, T_SLASH);
7616     }
7617   return cmd;
7618
7619 error:
7620   matrix_cmd_destroy (cmd);
7621   return NULL;
7622 }
7623
7624 static const struct variable *
7625 get_a8_var (const struct dictionary *d, const char *name)
7626 {
7627   const struct variable *v = dict_lookup_var (d, name);
7628   if (!v)
7629     {
7630       msg (SE, _("Matrix data file lacks %s variable."), name);
7631       return NULL;
7632     }
7633   if (var_get_width (v) != 8)
7634     {
7635       msg (SE, _("%s variable in matrix data file must be "
7636                  "8-byte string, but it has width %d."),
7637            name, var_get_width (v));
7638       return NULL;
7639     }
7640   return v;
7641 }
7642
7643 static bool
7644 var_changed (const struct ccase *ca, const struct ccase *cb,
7645              const struct variable *var)
7646 {
7647   return (ca && cb
7648           ? !value_equal (case_data (ca, var), case_data (cb, var),
7649                           var_get_width (var))
7650           : ca || cb);
7651 }
7652
7653 static bool
7654 vars_changed (const struct ccase *ca, const struct ccase *cb,
7655               const struct dictionary *d,
7656               size_t first_var, size_t n_vars)
7657 {
7658   for (size_t i = 0; i < n_vars; i++)
7659     {
7660       const struct variable *v = dict_get_var (d, first_var + i);
7661       if (var_changed (ca, cb, v))
7662         return true;
7663     }
7664   return false;
7665 }
7666
7667 static bool
7668 vars_all_missing (const struct ccase *c, const struct dictionary *d,
7669                   size_t first_var, size_t n_vars)
7670 {
7671   for (size_t i = 0; i < n_vars; i++)
7672     if (case_num (c, dict_get_var (d, first_var + i)) != SYSMIS)
7673       return false;
7674   return true;
7675 }
7676
7677 static void
7678 matrix_mget_commit_var (struct ccase **rows, size_t n_rows,
7679                         const struct dictionary *d,
7680                         const struct variable *rowtype_var,
7681                         const struct stringi_set *accepted_rowtypes,
7682                         struct matrix_state *s,
7683                         size_t ss, size_t sn, size_t si,
7684                         size_t fs, size_t fn, size_t fi,
7685                         size_t cs, size_t cn,
7686                         struct pivot_table *pt,
7687                         struct pivot_dimension *var_dimension)
7688 {
7689   if (!n_rows)
7690     goto exit;
7691
7692   /* Is this a matrix for pooled data, either where there are no factor
7693      variables or the factor variables are missing? */
7694   bool pooled = !fn || vars_all_missing (rows[0], d, fs, fn);
7695
7696   struct substring rowtype = case_ss (rows[0], rowtype_var);
7697   ss_rtrim (&rowtype, ss_cstr (" "));
7698   if (!stringi_set_is_empty (accepted_rowtypes)
7699       && !stringi_set_contains_len (accepted_rowtypes,
7700                                     rowtype.string, rowtype.length))
7701     goto exit;
7702
7703   const char *prefix = (ss_equals_case (rowtype, ss_cstr ("COV")) ? "CV"
7704                         : ss_equals_case (rowtype, ss_cstr ("CORR")) ? "CR"
7705                         : ss_equals_case (rowtype, ss_cstr ("MEAN")) ? "MN"
7706                         : ss_equals_case (rowtype, ss_cstr ("STDDEV")) ? "SD"
7707                         : ss_equals_case (rowtype, ss_cstr ("N")) ? "NC"
7708                         : ss_equals_case (rowtype, ss_cstr ("COUNT")) ? "CN"
7709                         : NULL);
7710   if (!prefix)
7711     {
7712       msg (SE, _("Matrix data file contains unknown ROWTYPE_ \"%.*s\"."),
7713            (int) rowtype.length, rowtype.string);
7714       goto exit;
7715     }
7716
7717   struct string name = DS_EMPTY_INITIALIZER;
7718   ds_put_cstr (&name, prefix);
7719   if (!pooled)
7720     ds_put_format (&name, "F%zu", fi);
7721   if (si > 0)
7722     ds_put_format (&name, "S%zu", si);
7723
7724   struct matrix_var *mv = matrix_var_lookup (s, ds_ss (&name));
7725   if (!mv)
7726     mv = matrix_var_create (s, ds_ss (&name));
7727   else if (mv->value)
7728     {
7729       msg (SW, _("Matrix data file contains variable with existing name %s."),
7730            ds_cstr (&name));
7731       goto exit_free_name;
7732     }
7733
7734   gsl_matrix *m = gsl_matrix_alloc (n_rows, cn);
7735   size_t n_missing = 0;
7736   for (size_t y = 0; y < n_rows; y++)
7737     {
7738       for (size_t x = 0; x < cn; x++)
7739         {
7740           struct variable *var = dict_get_var (d, cs + x);
7741           double value = case_num (rows[y], var);
7742           if (var_is_num_missing (var, value, MV_ANY))
7743             {
7744               n_missing++;
7745               value = 0.0;
7746             }
7747           gsl_matrix_set (m, y, x, value);
7748         }
7749     }
7750
7751   int var_index = pivot_category_create_leaf (
7752     var_dimension->root, pivot_value_new_user_text (ds_cstr (&name), SIZE_MAX));
7753   double values[] = { n_rows, cn };
7754   for (size_t j = 0; j < sn; j++)
7755     {
7756       struct variable *var = dict_get_var (d, ss + j);
7757       const union value *value = case_data (rows[0], var);
7758       pivot_table_put2 (pt, j, var_index,
7759                         pivot_value_new_var_value (var, value));
7760     }
7761   for (size_t j = 0; j < fn; j++)
7762     {
7763       struct variable *var = dict_get_var (d, fs + j);
7764       const union value sysmis = { .f = SYSMIS };
7765       const union value *value = pooled ? &sysmis : case_data (rows[0], var);
7766       pivot_table_put2 (pt, j + sn, var_index,
7767                         pivot_value_new_var_value (var, value));
7768     }
7769   for (size_t j = 0; j < sizeof values / sizeof *values; j++)
7770     pivot_table_put2 (pt, j + sn + fn, var_index,
7771                       pivot_value_new_integer (values[j]));
7772
7773   if (n_missing)
7774     msg (SE, ngettext ("Matrix data file variable %s contains a missing "
7775                        "value, which was treated as zero.",
7776                        "Matrix data file variable %s contains %zu missing "
7777                        "values, which were treated as zero.", n_missing),
7778          ds_cstr (&name), n_missing);
7779   mv->value = m;
7780
7781 exit_free_name:
7782   ds_destroy (&name);
7783
7784 exit:
7785   for (size_t y = 0; y < n_rows; y++)
7786     case_unref (rows[y]);
7787 }
7788
7789 static void
7790 matrix_cmd_execute_mget__ (struct mget_command *mget,
7791                            struct casereader *r, const struct dictionary *d)
7792 {
7793   const struct variable *rowtype_ = get_a8_var (d, "ROWTYPE_");
7794   const struct variable *varname_ = get_a8_var (d, "VARNAME_");
7795   if (!rowtype_ || !varname_)
7796     return;
7797
7798   if (var_get_dict_index (rowtype_) >= var_get_dict_index (varname_))
7799     {
7800       msg (SE, _("ROWTYPE_ must precede VARNAME_ in matrix data file."));
7801       return;
7802     }
7803   if (var_get_dict_index (varname_) + 1 >= dict_get_var_cnt (d))
7804     {
7805       msg (SE, _("Matrix data file contains no continuous variables."));
7806       return;
7807     }
7808
7809   for (size_t i = 0; i < dict_get_var_cnt (d); i++)
7810     {
7811       const struct variable *v = dict_get_var (d, i);
7812       if (v != rowtype_ && v != varname_ && var_get_width (v) != 0)
7813         {
7814           msg (SE,
7815                _("Matrix data file contains unexpected string variable %s."),
7816                var_get_name (v));
7817           return;
7818         }
7819     }
7820
7821   /* SPLIT variables. */
7822   size_t ss = 0;
7823   size_t sn = var_get_dict_index (rowtype_);
7824   struct ccase *sc = NULL;
7825   size_t si = 0;
7826
7827   /* FACTOR variables. */
7828   size_t fs = var_get_dict_index (rowtype_) + 1;
7829   size_t fn = var_get_dict_index (varname_) - var_get_dict_index (rowtype_) - 1;
7830   struct ccase *fc = NULL;
7831   size_t fi = 0;
7832
7833   /* Continuous variables. */
7834   size_t cs = var_get_dict_index (varname_) + 1;
7835   size_t cn = dict_get_var_cnt (d) - cs;
7836   struct ccase *cc = NULL;
7837
7838   /* Pivot table. */
7839   struct pivot_table *pt = pivot_table_create (
7840     N_("Matrix Variables Created by MGET"));
7841   struct pivot_dimension *attr_dimension = pivot_dimension_create (
7842     pt, PIVOT_AXIS_COLUMN, N_("Attribute"));
7843   struct pivot_dimension *var_dimension = pivot_dimension_create (
7844     pt, PIVOT_AXIS_ROW, N_("Variable"));
7845   if (sn > 0)
7846     {
7847       struct pivot_category *splits = pivot_category_create_group (
7848         attr_dimension->root, N_("Split Values"));
7849       for (size_t i = 0; i < sn; i++)
7850         pivot_category_create_leaf (splits, pivot_value_new_variable (
7851                                       dict_get_var (d, ss + i)));
7852     }
7853   if (fn > 0)
7854     {
7855       struct pivot_category *factors = pivot_category_create_group (
7856         attr_dimension->root, N_("Factors"));
7857       for (size_t i = 0; i < fn; i++)
7858         pivot_category_create_leaf (factors, pivot_value_new_variable (
7859                                       dict_get_var (d, fs + i)));
7860     }
7861   pivot_category_create_group (attr_dimension->root, N_("Dimensions"),
7862                                 N_("Rows"), N_("Columns"));
7863
7864   /* Matrix. */
7865   struct ccase **rows = NULL;
7866   size_t allocated_rows = 0;
7867   size_t n_rows = 0;
7868
7869   struct ccase *c;
7870   while ((c = casereader_read (r)) != NULL)
7871     {
7872       bool row_has_factors = fn && !vars_all_missing (c, d, fs, fn);
7873
7874       enum
7875         {
7876           SPLITS_CHANGED,
7877           FACTORS_CHANGED,
7878           ROWTYPE_CHANGED,
7879           NOTHING_CHANGED
7880         }
7881       change
7882         = (sn && (!sc || vars_changed (sc, c, d, ss, sn)) ? SPLITS_CHANGED
7883            : fn && (!fc || vars_changed (fc, c, d, fs, fn)) ? FACTORS_CHANGED
7884            : !cc || var_changed (cc, c, rowtype_) ? ROWTYPE_CHANGED
7885            : NOTHING_CHANGED);
7886
7887       if (change != NOTHING_CHANGED)
7888         {
7889           matrix_mget_commit_var (rows, n_rows, d,
7890                                   rowtype_, &mget->rowtypes,
7891                                   mget->state,
7892                                   ss, sn, si,
7893                                   fs, fn, fi,
7894                                   cs, cn,
7895                                   pt, var_dimension);
7896           n_rows = 0;
7897           case_unref (cc);
7898           cc = case_ref (c);
7899         }
7900
7901       if (n_rows >= allocated_rows)
7902         rows = x2nrealloc (rows, &allocated_rows, sizeof *rows);
7903       rows[n_rows++] = c;
7904
7905       if (change == SPLITS_CHANGED)
7906         {
7907           si++;
7908           case_unref (sc);
7909           sc = case_ref (c);
7910
7911           /* Reset the factor number, if there are factors. */
7912           if (fn)
7913             {
7914               fi = 0;
7915               if (row_has_factors)
7916                 fi++;
7917               case_unref (fc);
7918               fc = case_ref (c);
7919             }
7920         }
7921       else if (change == FACTORS_CHANGED)
7922         {
7923           if (row_has_factors)
7924             fi++;
7925           case_unref (fc);
7926           fc = case_ref (c);
7927         }
7928     }
7929   matrix_mget_commit_var (rows, n_rows, d,
7930                           rowtype_, &mget->rowtypes,
7931                           mget->state,
7932                           ss, sn, si,
7933                           fs, fn, fi,
7934                           cs, cn,
7935                           pt, var_dimension);
7936   free (rows);
7937
7938   case_unref (sc);
7939   case_unref (fc);
7940   case_unref (cc);
7941
7942   if (var_dimension->n_leaves)
7943     pivot_table_submit (pt);
7944   else
7945     pivot_table_unref (pt);
7946 }
7947
7948 static void
7949 matrix_cmd_execute_mget (struct mget_command *mget)
7950 {
7951   struct casereader *r;
7952   struct dictionary *d;
7953   if (matrix_open_casereader ("MGET", mget->file, mget->encoding,
7954                               mget->state->dataset, &r, &d))
7955     {
7956       matrix_cmd_execute_mget__ (mget, r, d);
7957       matrix_close_casereader (mget->file, mget->state->dataset, r, d);
7958     }
7959 }
7960 \f
7961 static bool
7962 matrix_parse_dst_var (struct matrix_state *s, struct matrix_var **varp)
7963 {
7964   if (!lex_force_id (s->lexer))
7965     return false;
7966
7967   *varp = matrix_var_lookup (s, lex_tokss (s->lexer));
7968   if (!*varp)
7969     *varp = matrix_var_create (s, lex_tokss (s->lexer));
7970   lex_get (s->lexer);
7971   return true;
7972 }
7973
7974 static struct matrix_cmd *
7975 matrix_parse_eigen (struct matrix_state *s)
7976 {
7977   struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
7978   *cmd = (struct matrix_cmd) {
7979     .type = MCMD_EIGEN,
7980     .eigen = { .expr = NULL }
7981   };
7982
7983   struct eigen_command *eigen = &cmd->eigen;
7984   if (!lex_force_match (s->lexer, T_LPAREN))
7985     goto error;
7986   eigen->expr = matrix_parse_expr (s);
7987   if (!eigen->expr
7988       || !lex_force_match (s->lexer, T_COMMA)
7989       || !matrix_parse_dst_var (s, &eigen->evec)
7990       || !lex_force_match (s->lexer, T_COMMA)
7991       || !matrix_parse_dst_var (s, &eigen->eval)
7992       || !lex_force_match (s->lexer, T_RPAREN))
7993     goto error;
7994
7995   return cmd;
7996
7997 error:
7998   matrix_cmd_destroy (cmd);
7999   return NULL;
8000 }
8001
8002 static void
8003 matrix_cmd_execute_eigen (struct eigen_command *eigen)
8004 {
8005   gsl_matrix *A = matrix_expr_evaluate (eigen->expr);
8006   if (!A)
8007     return;
8008   if (!is_symmetric (A))
8009     {
8010       msg (SE, _("Argument of EIGEN must be symmetric."));
8011       gsl_matrix_free (A);
8012       return;
8013     }
8014
8015   gsl_eigen_symmv_workspace *w = gsl_eigen_symmv_alloc (A->size1);
8016   gsl_matrix *eval = gsl_matrix_alloc (A->size1, 1);
8017   gsl_vector v_eval = to_vector (eval);
8018   gsl_matrix *evec = gsl_matrix_alloc (A->size1, A->size2);
8019   gsl_eigen_symmv (A, &v_eval, evec, w);
8020   gsl_eigen_symmv_free (w);
8021
8022   gsl_eigen_symmv_sort (&v_eval, evec, GSL_EIGEN_SORT_VAL_DESC);
8023
8024   gsl_matrix_free (A);
8025
8026   gsl_matrix_free (eigen->eval->value);
8027   eigen->eval->value = eval;
8028
8029   gsl_matrix_free (eigen->evec->value);
8030   eigen->evec->value = evec;
8031 }
8032 \f
8033 static struct matrix_cmd *
8034 matrix_parse_setdiag (struct matrix_state *s)
8035 {
8036   struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
8037   *cmd = (struct matrix_cmd) {
8038     .type = MCMD_SETDIAG,
8039     .setdiag = { .dst = NULL }
8040   };
8041
8042   struct setdiag_command *setdiag = &cmd->setdiag;
8043   if (!lex_force_match (s->lexer, T_LPAREN) || !lex_force_id (s->lexer))
8044     goto error;
8045
8046   setdiag->dst = matrix_var_lookup (s, lex_tokss (s->lexer));
8047   if (!setdiag->dst)
8048     {
8049       lex_error (s->lexer, _("Unknown variable %s."), lex_tokcstr (s->lexer));
8050       goto error;
8051     }
8052   lex_get (s->lexer);
8053
8054   if (!lex_force_match (s->lexer, T_COMMA))
8055     goto error;
8056
8057   setdiag->expr = matrix_parse_expr (s);
8058   if (!setdiag->expr)
8059     goto error;
8060
8061   if (!lex_force_match (s->lexer, T_RPAREN))
8062     goto error;
8063
8064   return cmd;
8065
8066 error:
8067   matrix_cmd_destroy (cmd);
8068   return NULL;
8069 }
8070
8071 static void
8072 matrix_cmd_execute_setdiag (struct setdiag_command *setdiag)
8073 {
8074   gsl_matrix *dst = setdiag->dst->value;
8075   if (!dst)
8076     {
8077       msg (SE, _("SETDIAG destination matrix %s is uninitialized."),
8078            setdiag->dst->name);
8079       return;
8080     }
8081
8082   gsl_matrix *src = matrix_expr_evaluate (setdiag->expr);
8083   if (!src)
8084     return;
8085
8086   size_t n = MIN (dst->size1, dst->size2);
8087   if (is_scalar (src))
8088     {
8089       double d = to_scalar (src);
8090       for (size_t i = 0; i < n; i++)
8091         gsl_matrix_set (dst, i, i, d);
8092     }
8093   else if (is_vector (src))
8094     {
8095       gsl_vector v = to_vector (src);
8096       for (size_t i = 0; i < n && i < v.size; i++)
8097         gsl_matrix_set (dst, i, i, gsl_vector_get (&v, i));
8098     }
8099   else
8100     msg (SE, _("SETDIAG argument 2 must be a scalar or a vector, "
8101                "not a %zu×%zu matrix."),
8102          src->size1, src->size2);
8103   gsl_matrix_free (src);
8104 }
8105 \f
8106 static struct matrix_cmd *
8107 matrix_parse_svd (struct matrix_state *s)
8108 {
8109   struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
8110   *cmd = (struct matrix_cmd) {
8111     .type = MCMD_SVD,
8112     .svd = { .expr = NULL }
8113   };
8114
8115   struct svd_command *svd = &cmd->svd;
8116   if (!lex_force_match (s->lexer, T_LPAREN))
8117     goto error;
8118   svd->expr = matrix_parse_expr (s);
8119   if (!svd->expr
8120       || !lex_force_match (s->lexer, T_COMMA)
8121       || !matrix_parse_dst_var (s, &svd->u)
8122       || !lex_force_match (s->lexer, T_COMMA)
8123       || !matrix_parse_dst_var (s, &svd->s)
8124       || !lex_force_match (s->lexer, T_COMMA)
8125       || !matrix_parse_dst_var (s, &svd->v)
8126       || !lex_force_match (s->lexer, T_RPAREN))
8127     goto error;
8128
8129   return cmd;
8130
8131 error:
8132   matrix_cmd_destroy (cmd);
8133   return NULL;
8134 }
8135
8136 static void
8137 matrix_cmd_execute_svd (struct svd_command *svd)
8138 {
8139   gsl_matrix *m = matrix_expr_evaluate (svd->expr);
8140   if (!m)
8141     return;
8142
8143   if (m->size1 >= m->size2)
8144     {
8145       gsl_matrix *A = m;
8146       gsl_matrix *V = gsl_matrix_alloc (A->size2, A->size2);
8147       gsl_matrix *S = gsl_matrix_calloc (A->size2, A->size2);
8148       gsl_vector Sv = gsl_matrix_diagonal (S).vector;
8149       gsl_vector *work = gsl_vector_alloc (A->size2);
8150       gsl_linalg_SV_decomp (A, V, &Sv, work);
8151       gsl_vector_free (work);
8152
8153       matrix_var_set (svd->u, A);
8154       matrix_var_set (svd->s, S);
8155       matrix_var_set (svd->v, V);
8156     }
8157   else
8158     {
8159       gsl_matrix *At = gsl_matrix_alloc (m->size2, m->size1);
8160       gsl_matrix_transpose_memcpy (At, m);
8161       gsl_matrix_free (m);
8162
8163       gsl_matrix *Vt = gsl_matrix_alloc (At->size2, At->size2);
8164       gsl_matrix *St = gsl_matrix_calloc (At->size2, At->size2);
8165       gsl_vector Stv = gsl_matrix_diagonal (St).vector;
8166       gsl_vector *work = gsl_vector_alloc (At->size2);
8167       gsl_linalg_SV_decomp (At, Vt, &Stv, work);
8168       gsl_vector_free (work);
8169
8170       matrix_var_set (svd->v, At);
8171       matrix_var_set (svd->s, St);
8172       matrix_var_set (svd->u, Vt);
8173     }
8174 }
8175 \f
8176 static bool
8177 matrix_cmd_execute (struct matrix_cmd *cmd)
8178 {
8179   switch (cmd->type)
8180     {
8181     case MCMD_COMPUTE:
8182       matrix_cmd_execute_compute (&cmd->compute);
8183       break;
8184
8185     case MCMD_PRINT:
8186       matrix_cmd_execute_print (&cmd->print);
8187       break;
8188
8189     case MCMD_DO_IF:
8190       return matrix_cmd_execute_do_if (&cmd->do_if);
8191
8192     case MCMD_LOOP:
8193       matrix_cmd_execute_loop (&cmd->loop);
8194       break;
8195
8196     case MCMD_BREAK:
8197       return false;
8198
8199     case MCMD_DISPLAY:
8200       matrix_cmd_execute_display (&cmd->display);
8201       break;
8202
8203     case MCMD_RELEASE:
8204       matrix_cmd_execute_release (&cmd->release);
8205       break;
8206
8207     case MCMD_SAVE:
8208       matrix_cmd_execute_save (&cmd->save);
8209       break;
8210
8211     case MCMD_READ:
8212       matrix_cmd_execute_read (&cmd->read);
8213       break;
8214
8215     case MCMD_WRITE:
8216       matrix_cmd_execute_write (&cmd->write);
8217       break;
8218
8219     case MCMD_GET:
8220       matrix_cmd_execute_get (&cmd->get);
8221       break;
8222
8223     case MCMD_MSAVE:
8224       matrix_cmd_execute_msave (&cmd->msave);
8225       break;
8226
8227     case MCMD_MGET:
8228       matrix_cmd_execute_mget (&cmd->mget);
8229       break;
8230
8231     case MCMD_EIGEN:
8232       matrix_cmd_execute_eigen (&cmd->eigen);
8233       break;
8234
8235     case MCMD_SETDIAG:
8236       matrix_cmd_execute_setdiag (&cmd->setdiag);
8237       break;
8238
8239     case MCMD_SVD:
8240       matrix_cmd_execute_svd (&cmd->svd);
8241       break;
8242     }
8243
8244   return true;
8245 }
8246
8247 static void
8248 matrix_cmds_uninit (struct matrix_cmds *cmds)
8249 {
8250   for (size_t i = 0; i < cmds->n; i++)
8251     matrix_cmd_destroy (cmds->commands[i]);
8252   free (cmds->commands);
8253 }
8254
8255 static void
8256 matrix_cmd_destroy (struct matrix_cmd *cmd)
8257 {
8258   if (!cmd)
8259     return;
8260
8261   switch (cmd->type)
8262     {
8263     case MCMD_COMPUTE:
8264       matrix_lvalue_destroy (cmd->compute.lvalue);
8265       matrix_expr_destroy (cmd->compute.rvalue);
8266       break;
8267
8268     case MCMD_PRINT:
8269       matrix_expr_destroy (cmd->print.expression);
8270       free (cmd->print.title);
8271       print_labels_destroy (cmd->print.rlabels);
8272       print_labels_destroy (cmd->print.clabels);
8273       break;
8274
8275     case MCMD_DO_IF:
8276       for (size_t i = 0; i < cmd->do_if.n_clauses; i++)
8277         {
8278           matrix_expr_destroy (cmd->do_if.clauses[i].condition);
8279           matrix_cmds_uninit (&cmd->do_if.clauses[i].commands);
8280         }
8281       free (cmd->do_if.clauses);
8282       break;
8283
8284     case MCMD_LOOP:
8285       matrix_expr_destroy (cmd->loop.start);
8286       matrix_expr_destroy (cmd->loop.end);
8287       matrix_expr_destroy (cmd->loop.increment);
8288       matrix_expr_destroy (cmd->loop.top_condition);
8289       matrix_expr_destroy (cmd->loop.bottom_condition);
8290       matrix_cmds_uninit (&cmd->loop.commands);
8291       break;
8292
8293     case MCMD_BREAK:
8294       break;
8295
8296     case MCMD_DISPLAY:
8297       break;
8298
8299     case MCMD_RELEASE:
8300       free (cmd->release.vars);
8301       break;
8302
8303     case MCMD_SAVE:
8304       matrix_expr_destroy (cmd->save.expression);
8305       break;
8306
8307     case MCMD_READ:
8308       matrix_lvalue_destroy (cmd->read.dst);
8309       matrix_expr_destroy (cmd->read.size);
8310       break;
8311
8312     case MCMD_WRITE:
8313       matrix_expr_destroy (cmd->write.expression);
8314       free (cmd->write.format);
8315       break;
8316
8317     case MCMD_GET:
8318       matrix_lvalue_destroy (cmd->get.dst);
8319       fh_unref (cmd->get.file);
8320       free (cmd->get.encoding);
8321       var_syntax_destroy (cmd->get.vars, cmd->get.n_vars);
8322       break;
8323
8324     case MCMD_MSAVE:
8325       matrix_expr_destroy (cmd->msave.expr);
8326       break;
8327
8328     case MCMD_MGET:
8329       fh_unref (cmd->mget.file);
8330       stringi_set_destroy (&cmd->mget.rowtypes);
8331       break;
8332
8333     case MCMD_EIGEN:
8334       matrix_expr_destroy (cmd->eigen.expr);
8335       break;
8336
8337     case MCMD_SETDIAG:
8338       matrix_expr_destroy (cmd->setdiag.expr);
8339       break;
8340
8341     case MCMD_SVD:
8342       matrix_expr_destroy (cmd->svd.expr);
8343       break;
8344     }
8345   free (cmd);
8346 }
8347
8348 struct matrix_command_name
8349   {
8350     const char *name;
8351     struct matrix_cmd *(*parse) (struct matrix_state *);
8352   };
8353
8354 static const struct matrix_command_name *
8355 matrix_parse_command_name (struct lexer *lexer)
8356 {
8357   static const struct matrix_command_name commands[] = {
8358     { "COMPUTE", matrix_parse_compute },
8359     { "CALL EIGEN", matrix_parse_eigen },
8360     { "CALL SETDIAG", matrix_parse_setdiag },
8361     { "CALL SVD", matrix_parse_svd },
8362     { "PRINT", matrix_parse_print },
8363     { "DO IF", matrix_parse_do_if },
8364     { "LOOP", matrix_parse_loop },
8365     { "BREAK", matrix_parse_break },
8366     { "READ", matrix_parse_read },
8367     { "WRITE", matrix_parse_write },
8368     { "GET", matrix_parse_get },
8369     { "SAVE", matrix_parse_save },
8370     { "MGET", matrix_parse_mget },
8371     { "MSAVE", matrix_parse_msave },
8372     { "DISPLAY", matrix_parse_display },
8373     { "RELEASE", matrix_parse_release },
8374   };
8375   static size_t n = sizeof commands / sizeof *commands;
8376
8377   for (const struct matrix_command_name *c = commands; c < &commands[n]; c++)
8378     if (lex_match_phrase (lexer, c->name))
8379       return c;
8380   return NULL;
8381 }
8382
8383 static struct matrix_cmd *
8384 matrix_parse_command (struct matrix_state *s)
8385 {
8386   size_t nesting_level = SIZE_MAX;
8387
8388   struct matrix_cmd *c = NULL;
8389   const struct matrix_command_name *cmd = matrix_parse_command_name (s->lexer);
8390   if (!cmd)
8391     lex_error (s->lexer, _("Unknown matrix command."));
8392   else if (!cmd->parse)
8393     lex_error (s->lexer, _("Matrix command %s is not yet implemented."),
8394                cmd->name);
8395   else
8396     {
8397       nesting_level = output_open_group (
8398         group_item_create_nocopy (utf8_to_title (cmd->name),
8399                                   utf8_to_title (cmd->name)));
8400       c = cmd->parse (s);
8401     }
8402
8403   if (c)
8404     lex_end_of_command (s->lexer);
8405   lex_discard_rest_of_command (s->lexer);
8406   if (nesting_level != SIZE_MAX)
8407     output_close_groups (nesting_level);
8408
8409   return c;
8410 }
8411
8412 int
8413 cmd_matrix (struct lexer *lexer, struct dataset *ds)
8414 {
8415   if (!lex_force_match (lexer, T_ENDCMD))
8416     return CMD_FAILURE;
8417
8418   struct matrix_state state = {
8419     .dataset = ds,
8420     .session = dataset_session (ds),
8421     .lexer = lexer,
8422     .vars = HMAP_INITIALIZER (state.vars),
8423   };
8424
8425   for (;;)
8426     {
8427       while (lex_match (lexer, T_ENDCMD))
8428         continue;
8429       if (lex_token (lexer) == T_STOP)
8430         {
8431           msg (SE, _("Unexpected end of input expecting matrix command."));
8432           break;
8433         }
8434
8435       if (lex_match_phrase (lexer, "END MATRIX"))
8436         break;
8437
8438       struct matrix_cmd *c = matrix_parse_command (&state);
8439       if (c)
8440         {
8441           matrix_cmd_execute (c);
8442           matrix_cmd_destroy (c);
8443         }
8444     }
8445
8446   struct matrix_var *var, *next;
8447   HMAP_FOR_EACH_SAFE (var, next, struct matrix_var, hmap_node, &state.vars)
8448     {
8449       free (var->name);
8450       gsl_matrix_free (var->value);
8451       hmap_delete (&state.vars, &var->hmap_node);
8452       free (var);
8453     }
8454   hmap_destroy (&state.vars);
8455   msave_common_destroy (state.common);
8456   fh_unref (state.prev_read_file);
8457   for (size_t i = 0; i < state.n_read_files; i++)
8458     read_file_destroy (state.read_files[i]);
8459   free (state.read_files);
8460   fh_unref (state.prev_write_file);
8461   for (size_t i = 0; i < state.n_write_files; i++)
8462     write_file_destroy (state.write_files[i]);
8463   free (state.write_files);
8464   fh_unref (state.prev_save_file);
8465   for (size_t i = 0; i < state.n_save_files; i++)
8466     save_file_destroy (state.save_files[i]);
8467   free (state.save_files);
8468
8469   return CMD_SUCCESS;
8470 }