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

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