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