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