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