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   while (lex_match (s->lexer, T_SLASH))
6269     {
6270       if (lex_match_id (s->lexer, "OUTFILE"))
6271         {
6272           lex_match (s->lexer, T_EQUALS);
6273
6274           fh_unref (fh);
6275           fh = (lex_match (s->lexer, T_ASTERISK)
6276                 ? fh_inline_file ()
6277                 : fh_parse (s->lexer, FH_REF_FILE, s->session));
6278           if (!fh)
6279             goto error;
6280         }
6281       else if (lex_match_id (s->lexer, "VARIABLES"))
6282         {
6283           lex_match (s->lexer, T_EQUALS);
6284
6285           char **names;
6286           size_t n;
6287           struct dictionary *d = dict_create (get_default_encoding ());
6288           bool ok = parse_DATA_LIST_vars (s->lexer, d, &names, &n,
6289                                           PV_NO_SCRATCH | PV_NO_DUPLICATE);
6290           dict_unref (d);
6291           if (!ok)
6292             goto error;
6293
6294           string_array_clear (&variables);
6295           variables = (struct string_array) {
6296             .strings = names,
6297             .n = n,
6298             .allocated = n,
6299           };
6300         }
6301       else if (lex_match_id (s->lexer, "NAMES"))
6302         {
6303           lex_match (s->lexer, T_EQUALS);
6304           matrix_expr_destroy (names);
6305           names = matrix_parse_exp (s);
6306           if (!names)
6307             goto error;
6308         }
6309       else if (lex_match_id (s->lexer, "STRINGS"))
6310         {
6311           lex_match (s->lexer, T_EQUALS);
6312           while (lex_token (s->lexer) == T_ID)
6313             {
6314               stringi_set_insert (&strings, lex_tokcstr (s->lexer));
6315               lex_get (s->lexer);
6316               if (!lex_match (s->lexer, T_COMMA))
6317                 break;
6318             }
6319         }
6320       else
6321         {
6322           lex_error_expecting (s->lexer, "OUTFILE", "VARIABLES", "NAMES",
6323                                "STRINGS");
6324           goto error;
6325         }
6326     }
6327
6328   if (!fh)
6329     {
6330       if (s->prev_save_file)
6331         fh = fh_ref (s->prev_save_file);
6332       else
6333         {
6334           lex_sbc_missing (s->lexer, "OUTFILE");
6335           goto error;
6336         }
6337     }
6338   fh_unref (s->prev_save_file);
6339   s->prev_save_file = fh_ref (fh);
6340
6341   if (variables.n && names)
6342     {
6343       msg (SW, _("VARIABLES and NAMES both specified; ignoring NAMES."));
6344       matrix_expr_destroy (names);
6345       names = NULL;
6346     }
6347
6348   save->sf = save_file_create (s, fh, &variables, names, &strings);
6349   return cmd;
6350
6351 error:
6352   string_array_destroy (&variables);
6353   matrix_expr_destroy (names);
6354   stringi_set_destroy (&strings);
6355   fh_unref (fh);
6356   matrix_command_destroy (cmd);
6357   return NULL;
6358 }
6359
6360 static void
6361 matrix_save_execute (const struct matrix_command *cmd)
6362 {
6363   const struct matrix_save *save = &cmd->save;
6364
6365   gsl_matrix *m = matrix_expr_evaluate (save->expression);
6366   if (!m)
6367     return;
6368
6369   struct casewriter *writer = save_file_open (save->sf, m, cmd->location);
6370   if (!writer)
6371     {
6372       gsl_matrix_free (m);
6373       return;
6374     }
6375
6376   const struct caseproto *proto = casewriter_get_proto (writer);
6377   for (size_t y = 0; y < m->size1; y++)
6378     {
6379       struct ccase *c = case_create (proto);
6380       for (size_t x = 0; x < m->size2; x++)
6381         {
6382           double d = gsl_matrix_get (m, y, x);
6383           int width = caseproto_get_width (proto, x);
6384           union value *value = case_data_rw_idx (c, x);
6385           if (width == 0)
6386             value->f = d;
6387           else
6388             memcpy (value->s, &d, width);
6389         }
6390       casewriter_write (writer, c);
6391     }
6392   gsl_matrix_free (m);
6393 }
6394 \f
6395 /* READ. */
6396
6397 static struct read_file *
6398 read_file_create (struct matrix_state *s, struct file_handle *fh)
6399 {
6400   for (size_t i = 0; i < s->n_read_files; i++)
6401     {
6402       struct read_file *rf = s->read_files[i];
6403       if (rf->file == fh)
6404         {
6405           fh_unref (fh);
6406           return rf;
6407         }
6408     }
6409
6410   struct read_file *rf = xmalloc (sizeof *rf);
6411   *rf = (struct read_file) { .file = fh };
6412
6413   s->read_files = xrealloc (s->read_files,
6414                             (s->n_read_files + 1) * sizeof *s->read_files);
6415   s->read_files[s->n_read_files++] = rf;
6416   return rf;
6417 }
6418
6419 static struct dfm_reader *
6420 read_file_open (struct read_file *rf)
6421 {
6422   if (!rf->reader)
6423     rf->reader = dfm_open_reader (rf->file, NULL, rf->encoding);
6424   return rf->reader;
6425 }
6426
6427 static void
6428 read_file_destroy (struct read_file *rf)
6429 {
6430   if (rf)
6431     {
6432       fh_unref (rf->file);
6433       dfm_close_reader (rf->reader);
6434       free (rf->encoding);
6435       free (rf);
6436     }
6437 }
6438
6439 static struct matrix_command *
6440 matrix_read_parse (struct matrix_state *s)
6441 {
6442   struct matrix_command *cmd = xmalloc (sizeof *cmd);
6443   *cmd = (struct matrix_command) {
6444     .type = MCMD_READ,
6445     .read = { .format = FMT_F },
6446   };
6447
6448   struct file_handle *fh = NULL;
6449   char *encoding = NULL;
6450   struct matrix_read *read = &cmd->read;
6451   read->dst = matrix_lvalue_parse (s);
6452   if (!read->dst)
6453     goto error;
6454
6455   int by_ofs = 0;
6456   int format_ofs = 0;
6457   int record_width_start = 0, record_width_end = 0;
6458
6459   int by = 0;
6460   int repetitions = 0;
6461   int record_width = 0;
6462   bool seen_format = false;
6463   while (lex_match (s->lexer, T_SLASH))
6464     {
6465       if (lex_match_id (s->lexer, "FILE"))
6466         {
6467           lex_match (s->lexer, T_EQUALS);
6468
6469           fh_unref (fh);
6470           fh = fh_parse (s->lexer, FH_REF_FILE, NULL);
6471           if (!fh)
6472             goto error;
6473         }
6474       else if (lex_match_id (s->lexer, "ENCODING"))
6475         {
6476           lex_match (s->lexer, T_EQUALS);
6477           if (!lex_force_string (s->lexer))
6478             goto error;
6479
6480           free (encoding);
6481           encoding = ss_xstrdup (lex_tokss (s->lexer));
6482
6483           lex_get (s->lexer);
6484         }
6485       else if (lex_match_id (s->lexer, "FIELD"))
6486         {
6487           lex_match (s->lexer, T_EQUALS);
6488
6489           record_width_start = lex_ofs (s->lexer);
6490           if (!lex_force_int_range (s->lexer, "FIELD", 1, INT_MAX))
6491             goto error;
6492           read->c1 = lex_integer (s->lexer);
6493           lex_get (s->lexer);
6494           if (!lex_force_match (s->lexer, T_TO)
6495               || !lex_force_int_range (s->lexer, "TO", read->c1, INT_MAX))
6496             goto error;
6497           read->c2 = lex_integer (s->lexer) + 1;
6498           record_width_end = lex_ofs (s->lexer);
6499           lex_get (s->lexer);
6500
6501           record_width = read->c2 - read->c1;
6502           if (lex_match (s->lexer, T_BY))
6503             {
6504               if (!lex_force_int_range (s->lexer, "BY", 1,
6505                                         read->c2 - read->c1))
6506                 goto error;
6507               by = lex_integer (s->lexer);
6508               by_ofs = lex_ofs (s->lexer);
6509               int field_end = lex_ofs (s->lexer);
6510               lex_get (s->lexer);
6511
6512               if (record_width % by)
6513                 {
6514                   lex_ofs_error (
6515                     s->lexer, record_width_start, field_end,
6516                     _("Field width %d does not evenly divide record width %d."),
6517                     by, record_width);
6518                   lex_ofs_msg (s->lexer, SN, record_width_start, record_width_end,
6519                                _("This syntax designates the record width."));
6520                   lex_ofs_msg (s->lexer, SN, by_ofs, by_ofs,
6521                                _("This syntax specifies the field width."));
6522                   goto error;
6523                 }
6524             }
6525           else
6526             by = 0;
6527         }
6528       else if (lex_match_id (s->lexer, "SIZE"))
6529         {
6530           lex_match (s->lexer, T_EQUALS);
6531           matrix_expr_destroy (read->size);
6532           read->size = matrix_parse_exp (s);
6533           if (!read->size)
6534             goto error;
6535         }
6536       else if (lex_match_id (s->lexer, "MODE"))
6537         {
6538           lex_match (s->lexer, T_EQUALS);
6539           if (lex_match_id (s->lexer, "RECTANGULAR"))
6540             read->symmetric = false;
6541           else if (lex_match_id (s->lexer, "SYMMETRIC"))
6542             read->symmetric = true;
6543           else
6544             {
6545               lex_error_expecting (s->lexer, "RECTANGULAR", "SYMMETRIC");
6546               goto error;
6547             }
6548         }
6549       else if (lex_match_id (s->lexer, "REREAD"))
6550         read->reread = true;
6551       else if (lex_match_id (s->lexer, "FORMAT"))
6552         {
6553           if (seen_format)
6554             {
6555               lex_sbc_only_once (s->lexer, "FORMAT");
6556               goto error;
6557             }
6558           seen_format = true;
6559
6560           lex_match (s->lexer, T_EQUALS);
6561
6562           if (lex_token (s->lexer) != T_STRING && !lex_force_id (s->lexer))
6563             goto error;
6564
6565           format_ofs = lex_ofs (s->lexer);
6566           const char *p = lex_tokcstr (s->lexer);
6567           if (c_isdigit (p[0]))
6568             {
6569               repetitions = atoi (p);
6570               p += strspn (p, "0123456789");
6571               if (!fmt_from_name (p, &read->format))
6572                 {
6573                   lex_error (s->lexer, _("Unknown format %s."), p);
6574                   goto error;
6575                 }
6576               lex_get (s->lexer);
6577             }
6578           else if (fmt_from_name (p, &read->format))
6579             lex_get (s->lexer);
6580           else
6581             {
6582               struct fmt_spec format;
6583               if (!parse_format_specifier (s->lexer, &format))
6584                 goto error;
6585               read->format = format.type;
6586               read->w = format.w;
6587             }
6588         }
6589       else
6590         {
6591           lex_error_expecting (s->lexer, "FILE", "FIELD", "MODE",
6592                                "REREAD", "FORMAT");
6593           goto error;
6594         }
6595     }
6596
6597   if (!read->c1)
6598     {
6599       lex_sbc_missing (s->lexer, "FIELD");
6600       goto error;
6601     }
6602
6603   if (!read->dst->n_indexes && !read->size)
6604     {
6605       msg (SE, _("SIZE is required for reading data into a full matrix "
6606                  "(as opposed to a submatrix)."));
6607       msg_at (SN, read->dst->var_location,
6608               _("This expression designates a full matrix."));
6609       goto error;
6610     }
6611
6612   if (!fh)
6613     {
6614       if (s->prev_read_file)
6615         fh = fh_ref (s->prev_read_file);
6616       else
6617         {
6618           lex_sbc_missing (s->lexer, "FILE");
6619           goto error;
6620         }
6621     }
6622   fh_unref (s->prev_read_file);
6623   s->prev_read_file = fh_ref (fh);
6624
6625   read->rf = read_file_create (s, fh);
6626   fh = NULL;
6627   if (encoding)
6628     {
6629       free (read->rf->encoding);
6630       read->rf->encoding = encoding;
6631       encoding = NULL;
6632     }
6633
6634   /* Field width may be specified in multiple ways:
6635
6636      1. BY on FIELD.
6637      2. The format on FORMAT.
6638      3. The repetition factor on FORMAT.
6639
6640      (2) and (3) are mutually exclusive.
6641
6642      If more than one of these is present, they must agree.  If none of them is
6643      present, then free-field format is used.
6644    */
6645   if (repetitions > record_width)
6646     {
6647       msg (SE, _("%d repetitions cannot fit in record width %d."),
6648            repetitions, record_width);
6649       lex_ofs_msg (s->lexer, SN, format_ofs, format_ofs,
6650                    _("This syntax designates the number of repetitions."));
6651       lex_ofs_msg (s->lexer, SN, record_width_start, record_width_end,
6652                    _("This syntax designates the record width."));
6653       goto error;
6654     }
6655   int w = (repetitions ? record_width / repetitions
6656            : read->w ? read->w
6657            : by);
6658   if (by && w != by)
6659     {
6660       msg (SE, _("This command specifies two different field widths."));
6661       if (repetitions)
6662         {
6663           lex_ofs_msg (s->lexer, SN, format_ofs, format_ofs,
6664                        ngettext ("This syntax specifies %d repetition.",
6665                                  "This syntax specifies %d repetitions.",
6666                                  repetitions),
6667                        repetitions);
6668           lex_ofs_msg (s->lexer, SN, record_width_start, record_width_end,
6669                        _("This syntax designates record width %d, "
6670                          "which divided by %d repetitions implies "
6671                          "field width %d."),
6672                        record_width, repetitions, w);
6673         }
6674       else
6675         lex_ofs_msg (s->lexer, SN, format_ofs, format_ofs,
6676                      _("This syntax specifies field width %d."), w);
6677
6678       lex_ofs_msg (s->lexer, SN, by_ofs, by_ofs,
6679                    _("This syntax specifies field width %d."), by);
6680       goto error;
6681     }
6682   read->w = w;
6683   return cmd;
6684
6685 error:
6686   fh_unref (fh);
6687   matrix_command_destroy (cmd);
6688   free (encoding);
6689   return NULL;
6690 }
6691
6692 static void
6693 parse_error (const struct dfm_reader *reader, enum fmt_type format,
6694              struct substring data, size_t y, size_t x,
6695              int first_column, int last_column, char *error)
6696 {
6697   int line_number = dfm_get_line_number (reader);
6698   struct msg_location location = {
6699     .file_name = intern_new (dfm_get_file_name (reader)),
6700     .start = { .line = line_number, .column = first_column },
6701     .end = { .line = line_number, .column = last_column },
6702   };
6703   msg_at (DW, &location, _("Error reading \"%.*s\" as format %s "
6704                            "for matrix row %zu, column %zu: %s"),
6705           (int) data.length, data.string, fmt_name (format),
6706           y + 1, x + 1, error);
6707   msg_location_uninit (&location);
6708   free (error);
6709 }
6710
6711 static void
6712 matrix_read_set_field (struct matrix_read *read, struct dfm_reader *reader,
6713                        gsl_matrix *m, struct substring p, size_t y, size_t x,
6714                        const char *line_start)
6715 {
6716   const char *input_encoding = dfm_reader_get_encoding (reader);
6717   char *error;
6718   double f;
6719   if (fmt_is_numeric (read->format))
6720     {
6721       union value v;
6722       error = data_in (p, input_encoding, read->format,
6723                        settings_get_fmt_settings (), &v, 0, NULL);
6724       if (!error && v.f == SYSMIS)
6725         error = xstrdup (_("Matrix data may not contain missing value."));
6726       f = v.f;
6727     }
6728     else
6729       {
6730         uint8_t s[sizeof (double)];
6731         union value v = { .s = s };
6732         error = data_in (p, input_encoding, read->format,
6733                          settings_get_fmt_settings (), &v, sizeof s, "UTF-8");
6734         memcpy (&f, s, sizeof f);
6735       }
6736
6737   if (error)
6738     {
6739       int c1 = utf8_count_columns (line_start, p.string - line_start) + 1;
6740       int nc = ss_utf8_count_columns (p);
6741       int c2 = c1 + MAX (1, nc) - 1;
6742       parse_error (reader, read->format, p, y, x, c1, c2, error);
6743     }
6744   else
6745     {
6746       gsl_matrix_set (m, y, x, f);
6747       if (read->symmetric && x != y)
6748         gsl_matrix_set (m, x, y, f);
6749     }
6750 }
6751
6752 static bool
6753 matrix_read_line (struct matrix_command *cmd, struct dfm_reader *reader,
6754                   struct substring *line, const char **startp)
6755 {
6756   struct matrix_read *read = &cmd->read;
6757   if (dfm_eof (reader))
6758     {
6759       msg_at (SE, cmd->location,
6760               _("Unexpected end of file reading matrix data."));
6761       return false;
6762     }
6763   dfm_expand_tabs (reader);
6764   struct substring record = dfm_get_record (reader);
6765   /* XXX need to recode record into UTF-8 */
6766   *startp = record.string;
6767   *line = ss_utf8_columns (record, read->c1 - 1, read->c2 - read->c1);
6768   return true;
6769 }
6770
6771 static void
6772 matrix_read (struct matrix_command *cmd, struct dfm_reader *reader,
6773              gsl_matrix *m)
6774 {
6775   struct matrix_read *read = &cmd->read;
6776   for (size_t y = 0; y < m->size1; y++)
6777     {
6778       size_t nx = read->symmetric ? y + 1 : m->size2;
6779
6780       struct substring line = ss_empty ();
6781       const char *line_start = line.string;
6782       for (size_t x = 0; x < nx; x++)
6783         {
6784           struct substring p;
6785           if (!read->w)
6786             {
6787               for (;;)
6788                 {
6789                   ss_ltrim (&line, ss_cstr (" ,"));
6790                   if (!ss_is_empty (line))
6791                     break;
6792                   if (!matrix_read_line (cmd, reader, &line, &line_start))
6793                     return;
6794                   dfm_forward_record (reader);
6795                 }
6796
6797               ss_get_bytes (&line, ss_cspan (line, ss_cstr (" ,")), &p);
6798             }
6799           else
6800             {
6801               if (!matrix_read_line (cmd, reader, &line, &line_start))
6802                 return;
6803               size_t fields_per_line = (read->c2 - read->c1) / read->w;
6804               int f = x % fields_per_line;
6805               if (f == fields_per_line - 1)
6806                 dfm_forward_record (reader);
6807
6808               p = ss_substr (line, read->w * f, read->w);
6809             }
6810
6811           matrix_read_set_field (read, reader, m, p, y, x, line_start);
6812         }
6813
6814       if (read->w)
6815         dfm_forward_record (reader);
6816       else
6817         {
6818           ss_ltrim (&line, ss_cstr (" ,"));
6819           if (!ss_is_empty (line))
6820             {
6821               int line_number = dfm_get_line_number (reader);
6822               int c1 = utf8_count_columns (line_start,
6823                                            line.string - line_start) + 1;
6824               int c2 = c1 + ss_utf8_count_columns (line) - 1;
6825               struct msg_location location = {
6826                 .file_name = intern_new (dfm_get_file_name (reader)),
6827                 .start = { .line = line_number, .column = c1 },
6828                 .end = { .line = line_number, .column = c2 },
6829               };
6830               msg_at (DW, &location,
6831                       _("Trailing garbage following data for matrix row %zu."),
6832                       y + 1);
6833               msg_location_uninit (&location);
6834             }
6835         }
6836     }
6837 }
6838
6839 static void
6840 matrix_read_execute (struct matrix_command *cmd)
6841 {
6842   struct matrix_read *read = &cmd->read;
6843   struct index_vector iv0, iv1;
6844   if (!matrix_lvalue_evaluate (read->dst, &iv0, &iv1))
6845     return;
6846
6847   size_t size[2] = { SIZE_MAX, SIZE_MAX };
6848   if (read->size)
6849     {
6850       gsl_matrix *m = matrix_expr_evaluate (read->size);
6851       if (!m)
6852         return;
6853
6854       if (!is_vector (m))
6855         {
6856           msg_at (SE, matrix_expr_location (read->size),
6857                   _("SIZE must evaluate to a scalar or a 2-element vector, "
6858                     "not a %zu×%zu matrix."), m->size1, m->size2);
6859           gsl_matrix_free (m);
6860           index_vector_uninit (&iv0);
6861           index_vector_uninit (&iv1);
6862           return;
6863         }
6864
6865       gsl_vector v = to_vector (m);
6866       double d[2];
6867       if (v.size == 1)
6868         {
6869           d[0] = gsl_vector_get (&v, 0);
6870           d[1] = 1;
6871         }
6872       else if (v.size == 2)
6873         {
6874           d[0] = gsl_vector_get (&v, 0);
6875           d[1] = gsl_vector_get (&v, 1);
6876         }
6877       else
6878         {
6879           msg_at (SE, matrix_expr_location (read->size),
6880                   _("SIZE must evaluate to a scalar or a 2-element vector, "
6881                     "not a %zu×%zu matrix."),
6882                   m->size1, m->size2),
6883           gsl_matrix_free (m);
6884           index_vector_uninit (&iv0);
6885           index_vector_uninit (&iv1);
6886           return;
6887         }
6888       gsl_matrix_free (m);
6889
6890       if (d[0] < 0 || d[0] > SIZE_MAX || d[1] < 0 || d[1] > SIZE_MAX)
6891         {
6892           msg_at (SE, matrix_expr_location (read->size),
6893                   _("Matrix dimensions %g×%g specified on SIZE "
6894                     "are outside valid range."),
6895                   d[0], d[1]);
6896           index_vector_uninit (&iv0);
6897           index_vector_uninit (&iv1);
6898           return;
6899         }
6900
6901       size[0] = d[0];
6902       size[1] = d[1];
6903     }
6904
6905   if (read->dst->n_indexes)
6906     {
6907       size_t submatrix_size[2];
6908       if (read->dst->n_indexes == 2)
6909         {
6910           submatrix_size[0] = iv0.n;
6911           submatrix_size[1] = iv1.n;
6912         }
6913       else if (read->dst->var->value->size1 == 1)
6914         {
6915           submatrix_size[0] = 1;
6916           submatrix_size[1] = iv0.n;
6917         }
6918       else
6919         {
6920           submatrix_size[0] = iv0.n;
6921           submatrix_size[1] = 1;
6922         }
6923
6924       if (read->size)
6925         {
6926           if (size[0] != submatrix_size[0] || size[1] != submatrix_size[1])
6927             {
6928               msg_at (SE, cmd->location,
6929                       _("Dimensions specified on SIZE differ from dimensions "
6930                         "of destination submatrix."));
6931               msg_at (SN, matrix_expr_location (read->size),
6932                       _("SIZE specifies dimensions %zu×%zu."),
6933                       size[0], size[1]);
6934               msg_at (SN, read->dst->full_location,
6935                       _("Destination submatrix has dimensions %zu×%zu."),
6936                       submatrix_size[0], submatrix_size[1]);
6937               index_vector_uninit (&iv0);
6938               index_vector_uninit (&iv1);
6939               return;
6940             }
6941         }
6942       else
6943         {
6944           size[0] = submatrix_size[0];
6945           size[1] = submatrix_size[1];
6946         }
6947     }
6948
6949   struct dfm_reader *reader = read_file_open (read->rf);
6950   if (read->reread)
6951     dfm_reread_record (reader, 1);
6952
6953   if (read->symmetric && size[0] != size[1])
6954     {
6955       msg_at (SE, cmd->location,
6956               _("Cannot read non-square %zu×%zu matrix "
6957                 "using READ with MODE=SYMMETRIC."),
6958               size[0], size[1]);
6959       index_vector_uninit (&iv0);
6960       index_vector_uninit (&iv1);
6961       return;
6962     }
6963   gsl_matrix *tmp = gsl_matrix_calloc (size[0], size[1]);
6964   matrix_read (cmd, reader, tmp);
6965   matrix_lvalue_assign (read->dst, &iv0, &iv1, tmp, cmd->location);
6966 }
6967 \f
6968 /* WRITE. */
6969
6970 static struct write_file *
6971 write_file_create (struct matrix_state *s, struct file_handle *fh)
6972 {
6973   for (size_t i = 0; i < s->n_write_files; i++)
6974     {
6975       struct write_file *wf = s->write_files[i];
6976       if (wf->file == fh)
6977         {
6978           fh_unref (fh);
6979           return wf;
6980         }
6981     }
6982
6983   struct write_file *wf = xmalloc (sizeof *wf);
6984   *wf = (struct write_file) { .file = fh };
6985
6986   s->write_files = xrealloc (s->write_files,
6987                              (s->n_write_files + 1) * sizeof *s->write_files);
6988   s->write_files[s->n_write_files++] = wf;
6989   return wf;
6990 }
6991
6992 static struct dfm_writer *
6993 write_file_open (struct write_file *wf)
6994 {
6995   if (!wf->writer)
6996     wf->writer = dfm_open_writer (wf->file, wf->encoding);
6997   return wf->writer;
6998 }
6999
7000 static void
7001 write_file_destroy (struct write_file *wf)
7002 {
7003   if (wf)
7004     {
7005       if (wf->held)
7006         {
7007           dfm_put_record_utf8 (wf->writer, wf->held->s.ss.string,
7008                                wf->held->s.ss.length);
7009           u8_line_destroy (wf->held);
7010           free (wf->held);
7011         }
7012
7013       fh_unref (wf->file);
7014       dfm_close_writer (wf->writer);
7015       free (wf->encoding);
7016       free (wf);
7017     }
7018 }
7019
7020 static struct matrix_command *
7021 matrix_write_parse (struct matrix_state *s)
7022 {
7023   struct matrix_command *cmd = xmalloc (sizeof *cmd);
7024   *cmd = (struct matrix_command) {
7025     .type = MCMD_WRITE,
7026   };
7027
7028   struct file_handle *fh = NULL;
7029   char *encoding = NULL;
7030   struct matrix_write *write = &cmd->write;
7031   write->expression = matrix_parse_exp (s);
7032   if (!write->expression)
7033     goto error;
7034
7035   int by_ofs = 0;
7036   int format_ofs = 0;
7037   int record_width_start = 0, record_width_end = 0;
7038
7039   int by = 0;
7040   int repetitions = 0;
7041   int record_width = 0;
7042   enum fmt_type format = FMT_F;
7043   bool has_format = false;
7044   while (lex_match (s->lexer, T_SLASH))
7045     {
7046       if (lex_match_id (s->lexer, "OUTFILE"))
7047         {
7048           lex_match (s->lexer, T_EQUALS);
7049
7050           fh_unref (fh);
7051           fh = fh_parse (s->lexer, FH_REF_FILE, NULL);
7052           if (!fh)
7053             goto error;
7054         }
7055       else if (lex_match_id (s->lexer, "ENCODING"))
7056         {
7057           lex_match (s->lexer, T_EQUALS);
7058           if (!lex_force_string (s->lexer))
7059             goto error;
7060
7061           free (encoding);
7062           encoding = ss_xstrdup (lex_tokss (s->lexer));
7063
7064           lex_get (s->lexer);
7065         }
7066       else if (lex_match_id (s->lexer, "FIELD"))
7067         {
7068           lex_match (s->lexer, T_EQUALS);
7069
7070           record_width_start = lex_ofs (s->lexer);
7071
7072           if (!lex_force_int_range (s->lexer, "FIELD", 1, INT_MAX))
7073             goto error;
7074           write->c1 = lex_integer (s->lexer);
7075           lex_get (s->lexer);
7076           if (!lex_force_match (s->lexer, T_TO)
7077               || !lex_force_int_range (s->lexer, "TO", write->c1, INT_MAX))
7078             goto error;
7079           write->c2 = lex_integer (s->lexer) + 1;
7080           record_width_end = lex_ofs (s->lexer);
7081           lex_get (s->lexer);
7082
7083           record_width = write->c2 - write->c1;
7084           if (lex_match (s->lexer, T_BY))
7085             {
7086               if (!lex_force_int_range (s->lexer, "BY", 1,
7087                                         write->c2 - write->c1))
7088                 goto error;
7089               by_ofs = lex_ofs (s->lexer);
7090               int field_end = lex_ofs (s->lexer);
7091               by = lex_integer (s->lexer);
7092               lex_get (s->lexer);
7093
7094               if (record_width % by)
7095                 {
7096                   lex_ofs_error (
7097                     s->lexer, record_width_start, field_end,
7098                     _("Field width %d does not evenly divide record width %d."),
7099                     by, record_width);
7100                   lex_ofs_msg (s->lexer, SN, record_width_start, record_width_end,
7101                                _("This syntax designates the record width."));
7102                   lex_ofs_msg (s->lexer, SN, by_ofs, by_ofs,
7103                                _("This syntax specifies the field width."));
7104                   goto error;
7105                 }
7106             }
7107           else
7108             by = 0;
7109         }
7110       else if (lex_match_id (s->lexer, "MODE"))
7111         {
7112           lex_match (s->lexer, T_EQUALS);
7113           if (lex_match_id (s->lexer, "RECTANGULAR"))
7114             write->triangular = false;
7115           else if (lex_match_id (s->lexer, "TRIANGULAR"))
7116             write->triangular = true;
7117           else
7118             {
7119               lex_error_expecting (s->lexer, "RECTANGULAR", "TRIANGULAR");
7120               goto error;
7121             }
7122         }
7123       else if (lex_match_id (s->lexer, "HOLD"))
7124         write->hold = true;
7125       else if (lex_match_id (s->lexer, "FORMAT"))
7126         {
7127           if (has_format || write->format)
7128             {
7129               lex_sbc_only_once (s->lexer, "FORMAT");
7130               goto error;
7131             }
7132
7133           lex_match (s->lexer, T_EQUALS);
7134
7135           if (lex_token (s->lexer) != T_STRING && !lex_force_id (s->lexer))
7136             goto error;
7137
7138           format_ofs = lex_ofs (s->lexer);
7139           const char *p = lex_tokcstr (s->lexer);
7140           if (c_isdigit (p[0]))
7141             {
7142               repetitions = atoi (p);
7143               p += strspn (p, "0123456789");
7144               if (!fmt_from_name (p, &format))
7145                 {
7146                   lex_error (s->lexer, _("Unknown format %s."), p);
7147                   goto error;
7148                 }
7149               has_format = true;
7150               lex_get (s->lexer);
7151             }
7152           else if (fmt_from_name (p, &format))
7153             {
7154               has_format = true;
7155               lex_get (s->lexer);
7156             }
7157           else
7158             {
7159               struct fmt_spec spec;
7160               if (!parse_format_specifier (s->lexer, &spec))
7161                 goto error;
7162               write->format = xmemdup (&spec, sizeof spec);
7163             }
7164         }
7165       else
7166         {
7167           lex_error_expecting (s->lexer, "OUTFILE", "FIELD", "MODE",
7168                                "HOLD", "FORMAT");
7169           goto error;
7170         }
7171     }
7172
7173   if (!write->c1)
7174     {
7175       lex_sbc_missing (s->lexer, "FIELD");
7176       goto error;
7177     }
7178
7179   if (!fh)
7180     {
7181       if (s->prev_write_file)
7182         fh = fh_ref (s->prev_write_file);
7183       else
7184         {
7185           lex_sbc_missing (s->lexer, "OUTFILE");
7186           goto error;
7187         }
7188     }
7189   fh_unref (s->prev_write_file);
7190   s->prev_write_file = fh_ref (fh);
7191
7192   write->wf = write_file_create (s, fh);
7193   fh = NULL;
7194   if (encoding)
7195     {
7196       free (write->wf->encoding);
7197       write->wf->encoding = encoding;
7198       encoding = NULL;
7199     }
7200
7201   /* Field width may be specified in multiple ways:
7202
7203      1. BY on FIELD.
7204      2. The format on FORMAT.
7205      3. The repetition factor on FORMAT.
7206
7207      (2) and (3) are mutually exclusive.
7208
7209      If more than one of these is present, they must agree.  If none of them is
7210      present, then free-field format is used.
7211    */
7212   if (repetitions > record_width)
7213     {
7214       lex_ofs_msg (s->lexer, SN, format_ofs, format_ofs,
7215                    _("This syntax designates the number of repetitions."));
7216       lex_ofs_msg (s->lexer, SN, record_width_start, record_width_end,
7217                    _("This syntax designates the record width."));
7218       goto error;
7219     }
7220   int w = (repetitions ? record_width / repetitions
7221            : write->format ? write->format->w
7222            : by);
7223   if (by && w != by)
7224     {
7225       msg (SE, _("This command specifies two different field widths."));
7226       if (repetitions)
7227         {
7228           lex_ofs_msg (s->lexer, SN, format_ofs, format_ofs,
7229                        ngettext ("This syntax specifies %d repetition.",
7230                                  "This syntax specifies %d repetitions.",
7231                                  repetitions),
7232                        repetitions);
7233           lex_ofs_msg (s->lexer, SN, record_width_start, record_width_end,
7234                        _("This syntax designates record width %d, "
7235                          "which divided by %d repetitions implies "
7236                          "field width %d."),
7237                        record_width, repetitions, w);
7238         }
7239       else
7240         lex_ofs_msg (s->lexer, SN, format_ofs, format_ofs,
7241                      _("This syntax specifies field width %d."), w);
7242
7243       lex_ofs_msg (s->lexer, SN, by_ofs, by_ofs,
7244                    _("This syntax specifies field width %d."), by);
7245       goto error;
7246     }
7247   if (w && !write->format)
7248     {
7249       write->format = xmalloc (sizeof *write->format);
7250       *write->format = (struct fmt_spec) { .type = format, .w = w };
7251
7252       char *error = fmt_check_output__ (write->format);
7253       if (error)
7254         {
7255           msg (SE, "%s", error);
7256           free (error);
7257
7258           if (has_format)
7259             lex_ofs_msg (s->lexer, SN, format_ofs, format_ofs,
7260                          _("This syntax specifies format %s."),
7261                          fmt_name (format));
7262
7263           if (repetitions)
7264             {
7265               lex_ofs_msg (s->lexer, SN, format_ofs, format_ofs,
7266                            ngettext ("This syntax specifies %d repetition.",
7267                                      "This syntax specifies %d repetitions.",
7268                                      repetitions),
7269                            repetitions);
7270               lex_ofs_msg (s->lexer, SN, record_width_start, record_width_end,
7271                            _("This syntax designates record width %d, "
7272                              "which divided by %d repetitions implies "
7273                              "field width %d."),
7274                            record_width, repetitions, w);
7275             }
7276
7277           if (by)
7278             lex_ofs_msg (s->lexer, SN, by_ofs, by_ofs,
7279                          _("This syntax specifies field width %d."), by);
7280
7281           goto error;
7282         }
7283     }
7284
7285   if (write->format && fmt_var_width (write->format) > sizeof (double))
7286     {
7287       char fs[FMT_STRING_LEN_MAX + 1];
7288       fmt_to_string (write->format, fs);
7289       lex_ofs_error (s->lexer, format_ofs, format_ofs,
7290                      _("Format %s is too wide for %zu-byte matrix elements."),
7291                      fs, sizeof (double));
7292       goto error;
7293     }
7294
7295   return cmd;
7296
7297 error:
7298   fh_unref (fh);
7299   matrix_command_destroy (cmd);
7300   return NULL;
7301 }
7302
7303 static void
7304 matrix_write_execute (struct matrix_write *write)
7305 {
7306   gsl_matrix *m = matrix_expr_evaluate (write->expression);
7307   if (!m)
7308     return;
7309
7310   if (write->triangular && m->size1 != m->size2)
7311     {
7312       msg_at (SE, matrix_expr_location (write->expression),
7313               _("WRITE with MODE=TRIANGULAR requires a square matrix but "
7314                 "the matrix to be written has dimensions %zu×%zu."),
7315               m->size1, m->size2);
7316       gsl_matrix_free (m);
7317       return;
7318     }
7319
7320   struct dfm_writer *writer = write_file_open (write->wf);
7321   if (!writer || !m->size1)
7322     {
7323       gsl_matrix_free (m);
7324       return;
7325     }
7326
7327   const struct fmt_settings *settings = settings_get_fmt_settings ();
7328   struct u8_line *line = write->wf->held;
7329   for (size_t y = 0; y < m->size1; y++)
7330     {
7331       if (!line)
7332         {
7333           line = xmalloc (sizeof *line);
7334           u8_line_init (line);
7335         }
7336       size_t nx = write->triangular ? y + 1 : m->size2;
7337       int x0 = write->c1;
7338       for (size_t x = 0; x < nx; x++)
7339         {
7340           char *s;
7341           double f = gsl_matrix_get (m, y, x);
7342           if (write->format)
7343             {
7344               union value v;
7345               if (fmt_is_numeric (write->format->type))
7346                 v.f = f;
7347               else
7348                 v.s = (uint8_t *) &f;
7349               s = data_out (&v, NULL, write->format, settings);
7350             }
7351           else
7352             {
7353               s = xmalloc (DBL_BUFSIZE_BOUND);
7354               if (c_dtoastr (s, DBL_BUFSIZE_BOUND, FTOASTR_UPPER_E, 0, f)
7355                   >= DBL_BUFSIZE_BOUND)
7356                 abort ();
7357             }
7358           size_t len = strlen (s);
7359           int width = u8_width (CHAR_CAST (const uint8_t *, s), len, UTF8);
7360           if (width + x0 > write->c2)
7361             {
7362               dfm_put_record_utf8 (writer, line->s.ss.string,
7363                                    line->s.ss.length);
7364               u8_line_clear (line);
7365               x0 = write->c1;
7366             }
7367           u8_line_put (line, x0, x0 + width, s, len);
7368           free (s);
7369
7370           x0 += write->format ? write->format->w : width + 1;
7371         }
7372
7373       if (y + 1 >= m->size1 && write->hold)
7374         break;
7375       dfm_put_record_utf8 (writer, line->s.ss.string, line->s.ss.length);
7376       u8_line_clear (line);
7377     }
7378   if (!write->hold)
7379     {
7380       u8_line_destroy (line);
7381       free (line);
7382       line = NULL;
7383     }
7384   write->wf->held = line;
7385
7386   gsl_matrix_free (m);
7387 }
7388 \f
7389 /* GET. */
7390
7391 static struct matrix_command *
7392 matrix_get_parse (struct matrix_state *s)
7393 {
7394   struct matrix_command *cmd = xmalloc (sizeof *cmd);
7395   *cmd = (struct matrix_command) {
7396     .type = MCMD_GET,
7397     .get = {
7398       .lexer = s->lexer,
7399       .dataset = s->dataset,
7400       .user = { .treatment = MGET_ERROR },
7401       .system = { .treatment = MGET_ERROR },
7402     }
7403   };
7404
7405   struct matrix_get *get = &cmd->get;
7406   get->dst = matrix_lvalue_parse (s);
7407   if (!get->dst)
7408     goto error;
7409
7410   while (lex_match (s->lexer, T_SLASH))
7411     {
7412       if (lex_match_id (s->lexer, "FILE"))
7413         {
7414           lex_match (s->lexer, T_EQUALS);
7415
7416           fh_unref (get->file);
7417           if (lex_match (s->lexer, T_ASTERISK))
7418             get->file = NULL;
7419           else
7420             {
7421               get->file = fh_parse (s->lexer, FH_REF_FILE, s->session);
7422               if (!get->file)
7423                 goto error;
7424             }
7425         }
7426       else if (lex_match_id (s->lexer, "ENCODING"))
7427         {
7428           lex_match (s->lexer, T_EQUALS);
7429           if (!lex_force_string (s->lexer))
7430             goto error;
7431
7432           free (get->encoding);
7433           get->encoding = ss_xstrdup (lex_tokss (s->lexer));
7434
7435           lex_get (s->lexer);
7436         }
7437       else if (lex_match_id (s->lexer, "VARIABLES"))
7438         {
7439           lex_match (s->lexer, T_EQUALS);
7440
7441           if (get->n_vars)
7442             {
7443               lex_sbc_only_once (s->lexer, "VARIABLES");
7444               goto error;
7445             }
7446
7447           if (!var_syntax_parse (s->lexer, &get->vars, &get->n_vars))
7448             goto error;
7449         }
7450       else if (lex_match_id (s->lexer, "NAMES"))
7451         {
7452           lex_match (s->lexer, T_EQUALS);
7453           if (!lex_force_id (s->lexer))
7454             goto error;
7455
7456           struct substring name = lex_tokss (s->lexer);
7457           get->names = matrix_var_lookup (s, name);
7458           if (!get->names)
7459             get->names = matrix_var_create (s, name);
7460           lex_get (s->lexer);
7461         }
7462       else if (lex_match_id (s->lexer, "MISSING"))
7463         {
7464           lex_match (s->lexer, T_EQUALS);
7465           if (lex_match_id (s->lexer, "ACCEPT"))
7466             get->user.treatment = MGET_ACCEPT;
7467           else if (lex_match_id (s->lexer, "OMIT"))
7468             get->user.treatment = MGET_OMIT;
7469           else if (lex_is_number (s->lexer))
7470             {
7471               get->user.treatment = MGET_RECODE;
7472               get->user.substitute = lex_number (s->lexer);
7473               lex_get (s->lexer);
7474             }
7475           else
7476             {
7477               lex_error (s->lexer, NULL);
7478               goto error;
7479             }
7480         }
7481       else if (lex_match_id (s->lexer, "SYSMIS"))
7482         {
7483           lex_match (s->lexer, T_EQUALS);
7484           if (lex_match_id (s->lexer, "OMIT"))
7485             get->system.treatment = MGET_OMIT;
7486           else if (lex_is_number (s->lexer))
7487             {
7488               get->system.treatment = MGET_RECODE;
7489               get->system.substitute = lex_number (s->lexer);
7490               lex_get (s->lexer);
7491             }
7492           else
7493             {
7494               lex_error (s->lexer, NULL);
7495               goto error;
7496             }
7497         }
7498       else
7499         {
7500           lex_error_expecting (s->lexer, "FILE", "VARIABLES", "NAMES",
7501                                "MISSING", "SYSMIS");
7502           goto error;
7503         }
7504     }
7505
7506   if (get->user.treatment != MGET_ACCEPT)
7507     get->system.treatment = MGET_ERROR;
7508
7509   return cmd;
7510
7511 error:
7512   matrix_command_destroy (cmd);
7513   return NULL;
7514 }
7515
7516 static void
7517 matrix_get_execute__ (struct matrix_command *cmd, struct casereader *reader,
7518                       const struct dictionary *dict)
7519 {
7520   struct matrix_get *get = &cmd->get;
7521   struct variable **vars;
7522   size_t n_vars = 0;
7523
7524   if (get->n_vars)
7525     {
7526       if (!var_syntax_evaluate (get->lexer, get->vars, get->n_vars, dict,
7527                                 &vars, &n_vars, PV_NUMERIC))
7528         return;
7529     }
7530   else
7531     {
7532       n_vars = dict_get_n_vars (dict);
7533       vars = xnmalloc (n_vars, sizeof *vars);
7534       for (size_t i = 0; i < n_vars; i++)
7535         {
7536           struct variable *var = dict_get_var (dict, i);
7537           if (!var_is_numeric (var))
7538             {
7539               msg_at (SE, cmd->location, _("Variable %s is not numeric."),
7540                       var_get_name (var));
7541               free (vars);
7542               return;
7543             }
7544           vars[i] = var;
7545         }
7546     }
7547
7548   if (get->names)
7549     {
7550       gsl_matrix *names = gsl_matrix_alloc (n_vars, 1);
7551       for (size_t i = 0; i < n_vars; i++)
7552         {
7553           char s[sizeof (double)];
7554           double f;
7555           buf_copy_str_rpad (s, sizeof s, var_get_name (vars[i]), ' ');
7556           memcpy (&f, s, sizeof f);
7557           gsl_matrix_set (names, i, 0, f);
7558         }
7559
7560       gsl_matrix_free (get->names->value);
7561       get->names->value = names;
7562     }
7563
7564   size_t n_rows = 0;
7565   gsl_matrix *m = gsl_matrix_alloc (4, n_vars);
7566   long long int casenum = 1;
7567   bool error = false;
7568   for (struct ccase *c = casereader_read (reader); c;
7569        c = casereader_read (reader), casenum++)
7570     {
7571       if (n_rows >= m->size1)
7572         {
7573           gsl_matrix *p = gsl_matrix_alloc (m->size1 * 2, n_vars);
7574           for (size_t y = 0; y < n_rows; y++)
7575             for (size_t x = 0; x < n_vars; x++)
7576               gsl_matrix_set (p, y, x, gsl_matrix_get (m, y, x));
7577           gsl_matrix_free (m);
7578           m = p;
7579         }
7580
7581       bool keep = true;
7582       for (size_t x = 0; x < n_vars; x++)
7583         {
7584           const struct variable *var = vars[x];
7585           double d = case_num (c, var);
7586           if (d == SYSMIS)
7587             {
7588               if (get->system.treatment == MGET_RECODE)
7589                 d = get->system.substitute;
7590               else if (get->system.treatment == MGET_OMIT)
7591                 keep = false;
7592               else
7593                 {
7594                   msg_at (SE, cmd->location, _("Variable %s in case %lld "
7595                                                "is system-missing."),
7596                           var_get_name (var), casenum);
7597                   error = true;
7598                 }
7599             }
7600           else if (var_is_num_missing (var, d) == MV_USER)
7601             {
7602               if (get->user.treatment == MGET_RECODE)
7603                 d = get->user.substitute;
7604               else if (get->user.treatment == MGET_OMIT)
7605                 keep = false;
7606               else if (get->user.treatment != MGET_ACCEPT)
7607                 {
7608                   msg_at (SE, cmd->location,
7609                           _("Variable %s in case %lld has user-missing "
7610                              "value %g."),
7611                           var_get_name (var), casenum, d);
7612                   error = true;
7613                 }
7614             }
7615           gsl_matrix_set (m, n_rows, x, d);
7616         }
7617       case_unref (c);
7618       if (error)
7619         break;
7620       if (keep)
7621         n_rows++;
7622     }
7623   if (!error)
7624     {
7625       m->size1 = n_rows;
7626       matrix_lvalue_evaluate_and_assign (get->dst, m, cmd->location);
7627     }
7628   else
7629     gsl_matrix_free (m);
7630   free (vars);
7631 }
7632
7633 static bool
7634 matrix_open_casereader (const struct matrix_command *cmd,
7635                         const char *command_name, struct file_handle *file,
7636                         const char *encoding, struct dataset *dataset,
7637                         struct casereader **readerp, struct dictionary **dictp)
7638 {
7639   if (file)
7640     {
7641        *readerp = any_reader_open_and_decode (file, encoding, dictp, NULL);
7642        return *readerp != NULL;
7643     }
7644   else
7645     {
7646       if (dict_get_n_vars (dataset_dict (dataset)) == 0)
7647         {
7648           msg_at (SE, cmd->location,
7649                   _("The %s command cannot read an empty active file."),
7650                   command_name);
7651           return false;
7652         }
7653       *readerp = proc_open (dataset);
7654       *dictp = dict_ref (dataset_dict (dataset));
7655       return true;
7656     }
7657 }
7658
7659 static void
7660 matrix_close_casereader (struct file_handle *file, struct dataset *dataset,
7661                          struct casereader *reader, struct dictionary *dict)
7662 {
7663   dict_unref (dict);
7664   casereader_destroy (reader);
7665   if (!file)
7666     proc_commit (dataset);
7667 }
7668
7669 static void
7670 matrix_get_execute (struct matrix_command *cmd)
7671 {
7672   struct matrix_get *get = &cmd->get;
7673   struct casereader *r;
7674   struct dictionary *d;
7675   if (matrix_open_casereader (cmd, "GET", get->file, get->encoding,
7676                               get->dataset, &r, &d))
7677     {
7678       matrix_get_execute__ (cmd, r, d);
7679       matrix_close_casereader (get->file, get->dataset, r, d);
7680     }
7681 }
7682 \f
7683 /* MSAVE. */
7684
7685 static bool
7686 variables_changed (const char *keyword,
7687                    const struct string_array *new_vars,
7688                    const struct msg_location *new_vars_location,
7689                    const struct msg_location *new_location,
7690                    const struct string_array *old_vars,
7691                    const struct msg_location *old_vars_location,
7692                    const struct msg_location *old_location)
7693 {
7694   if (new_vars->n)
7695     {
7696       if (!old_vars->n)
7697         {
7698           msg_at (SE, new_location,
7699                   _("%s may only be specified on MSAVE if it was specified "
7700                     "on the first MSAVE within MATRIX."), keyword);
7701           msg_at (SN, old_location,
7702                   _("The first MSAVE in MATRIX did not specify %s."),
7703                   keyword);
7704           msg_at (SN, new_vars_location,
7705                   _("This is the specification of %s on a later MSAVE."),
7706                   keyword);
7707           return true;
7708         }
7709       if (!string_array_equal_case (old_vars, new_vars))
7710         {
7711           msg_at (SE, new_location,
7712                   _("%s must specify the same variables on each MSAVE "
7713                     "within a given MATRIX."), keyword);
7714           msg_at (SE, old_vars_location,
7715                   _("This is the specification of %s on the first MSAVE."),
7716                   keyword);
7717           msg_at (SE, new_vars_location,
7718                   _("This is a different specification of %s on a later MSAVE."),
7719                   keyword);
7720           return true;
7721         }
7722     }
7723   return false;
7724 }
7725
7726 static bool
7727 msave_common_changed (const struct msave_common *old,
7728                       const struct msave_common *new)
7729 {
7730   if (new->outfile && !fh_equal (old->outfile, new->outfile))
7731     {
7732       msg (SE, _("OUTFILE must name the same file on each MSAVE "
7733                  "within a single MATRIX command."));
7734       msg_at (SN, old->outfile_location,
7735               _("This is the OUTFILE on the first MSAVE command."));
7736       msg_at (SN, new->outfile_location,
7737               _("This is the OUTFILE on a later MSAVE command."));
7738       return false;
7739     }
7740
7741   if (!variables_changed ("VARIABLES",
7742                           &new->variables, new->variables_location, new->location,
7743                           &old->variables, old->variables_location, old->location)
7744       && !variables_changed ("FNAMES",
7745                              &new->fnames, new->fnames_location, new->location,
7746                              &old->fnames, old->fnames_location, old->location)
7747       && !variables_changed ("SNAMES",
7748                              &new->snames, new->snames_location, new->location,
7749                              &old->snames, old->snames_location, old->location))
7750     return false;
7751
7752   return true;
7753 }
7754
7755 static void
7756 msave_common_destroy (struct msave_common *common)
7757 {
7758   if (common)
7759     {
7760       msg_location_destroy (common->location);
7761       fh_unref (common->outfile);
7762       msg_location_destroy (common->outfile_location);
7763       string_array_destroy (&common->variables);
7764       msg_location_destroy (common->variables_location);
7765       string_array_destroy (&common->fnames);
7766       msg_location_destroy (common->fnames_location);
7767       string_array_destroy (&common->snames);
7768       msg_location_destroy (common->snames_location);
7769
7770       for (size_t i = 0; i < common->n_factors; i++)
7771         matrix_expr_destroy (common->factors[i]);
7772       free (common->factors);
7773
7774       for (size_t i = 0; i < common->n_splits; i++)
7775         matrix_expr_destroy (common->splits[i]);
7776       free (common->splits);
7777
7778       dict_unref (common->dict);
7779       casewriter_destroy (common->writer);
7780
7781       free (common);
7782     }
7783 }
7784
7785 static const char *
7786 match_rowtype (struct lexer *lexer)
7787 {
7788   static const char *rowtypes[] = {
7789     "COV", "CORR", "MEAN", "STDDEV", "N", "COUNT"
7790   };
7791   size_t n_rowtypes = sizeof rowtypes / sizeof *rowtypes;
7792
7793   for (size_t i = 0; i < n_rowtypes; i++)
7794     if (lex_match_id (lexer, rowtypes[i]))
7795       return rowtypes[i];
7796
7797   lex_error_expecting_array (lexer, rowtypes, n_rowtypes);
7798   return NULL;
7799 }
7800
7801 static bool
7802 parse_var_names (struct lexer *lexer, struct string_array *sa,
7803                  struct msg_location **locationp)
7804 {
7805   lex_match (lexer, T_EQUALS);
7806
7807   string_array_clear (sa);
7808   msg_location_destroy (*locationp);
7809   *locationp = NULL;
7810
7811   struct dictionary *dict = dict_create (get_default_encoding ());
7812   char **names;
7813   size_t n_names;
7814   int start_ofs = lex_ofs (lexer);
7815   bool ok = parse_DATA_LIST_vars (lexer, dict, &names, &n_names,
7816                                   PV_NO_DUPLICATE | PV_NO_SCRATCH);
7817   int end_ofs = lex_ofs (lexer) - 1;
7818   dict_unref (dict);
7819
7820   if (ok)
7821     {
7822       for (size_t i = 0; i < n_names; i++)
7823         if (ss_equals_case (ss_cstr (names[i]), ss_cstr ("ROWTYPE_"))
7824             || ss_equals_case (ss_cstr (names[i]), ss_cstr ("VARNAME_")))
7825           {
7826             lex_ofs_error (lexer, start_ofs, end_ofs,
7827                            _("Variable name %s is reserved."), names[i]);
7828             for (size_t j = 0; j < n_names; j++)
7829               free (names[i]);
7830             free (names);
7831             return false;
7832           }
7833
7834       sa->strings = names;
7835       sa->n = sa->allocated = n_names;
7836       *locationp = lex_ofs_location (lexer, start_ofs, end_ofs);
7837     }
7838   return ok;
7839 }
7840
7841 static struct matrix_command *
7842 matrix_msave_parse (struct matrix_state *s)
7843 {
7844   int start_ofs = lex_ofs (s->lexer);
7845
7846   struct msave_common *common = xmalloc (sizeof *common);
7847   *common = (struct msave_common) { .outfile = NULL };
7848
7849   struct matrix_command *cmd = xmalloc (sizeof *cmd);
7850   *cmd = (struct matrix_command) { .type = MCMD_MSAVE, .msave = { .expr = NULL } };
7851
7852   struct matrix_expr *splits = NULL;
7853   struct matrix_expr *factors = NULL;
7854
7855   struct matrix_msave *msave = &cmd->msave;
7856   msave->expr = matrix_parse_exp (s);
7857   if (!msave->expr)
7858     goto error;
7859
7860   while (lex_match (s->lexer, T_SLASH))
7861     {
7862       if (lex_match_id (s->lexer, "TYPE"))
7863         {
7864           lex_match (s->lexer, T_EQUALS);
7865
7866           msave->rowtype = match_rowtype (s->lexer);
7867           if (!msave->rowtype)
7868             goto error;
7869         }
7870       else if (lex_match_id (s->lexer, "OUTFILE"))
7871         {
7872           lex_match (s->lexer, T_EQUALS);
7873
7874           fh_unref (common->outfile);
7875           int start_ofs = lex_ofs (s->lexer);
7876           common->outfile = fh_parse (s->lexer, FH_REF_FILE, NULL);
7877           if (!common->outfile)
7878             goto error;
7879           msg_location_destroy (common->outfile_location);
7880           common->outfile_location = lex_ofs_location (s->lexer, start_ofs,
7881                                                        lex_ofs (s->lexer) - 1);
7882         }
7883       else if (lex_match_id (s->lexer, "VARIABLES"))
7884         {
7885           if (!parse_var_names (s->lexer, &common->variables,
7886                                 &common->variables_location))
7887             goto error;
7888         }
7889       else if (lex_match_id (s->lexer, "FNAMES"))
7890         {
7891           if (!parse_var_names (s->lexer, &common->fnames,
7892                                 &common->fnames_location))
7893             goto error;
7894         }
7895       else if (lex_match_id (s->lexer, "SNAMES"))
7896         {
7897           if (!parse_var_names (s->lexer, &common->snames,
7898                                 &common->snames_location))
7899             goto error;
7900         }
7901       else if (lex_match_id (s->lexer, "SPLIT"))
7902         {
7903           lex_match (s->lexer, T_EQUALS);
7904
7905           matrix_expr_destroy (splits);
7906           splits = matrix_parse_exp (s);
7907           if (!splits)
7908             goto error;
7909         }
7910       else if (lex_match_id (s->lexer, "FACTOR"))
7911         {
7912           lex_match (s->lexer, T_EQUALS);
7913
7914           matrix_expr_destroy (factors);
7915           factors = matrix_parse_exp (s);
7916           if (!factors)
7917             goto error;
7918         }
7919       else
7920         {
7921           lex_error_expecting (s->lexer, "TYPE", "OUTFILE", "VARIABLES",
7922                                "FNAMES", "SNAMES", "SPLIT", "FACTOR");
7923           goto error;
7924         }
7925     }
7926   if (!msave->rowtype)
7927     {
7928       lex_sbc_missing (s->lexer, "TYPE");
7929       goto error;
7930     }
7931
7932   if (!s->msave_common)
7933     {
7934       if (common->fnames.n && !factors)
7935         {
7936           msg_at (SE, common->fnames_location, _("FNAMES requires FACTOR."));
7937           goto error;
7938         }
7939       if (common->snames.n && !splits)
7940         {
7941           msg_at (SE, common->snames_location, _("SNAMES requires SPLIT."));
7942           goto error;
7943         }
7944       if (!common->outfile)
7945         {
7946           lex_sbc_missing (s->lexer, "OUTFILE");
7947           goto error;
7948         }
7949       common->location = lex_ofs_location (s->lexer, start_ofs,
7950                                            lex_ofs (s->lexer));
7951       msg_location_remove_columns (common->location);
7952       s->msave_common = common;
7953     }
7954   else
7955     {
7956       if (msave_common_changed (s->msave_common, common))
7957         goto error;
7958       msave_common_destroy (common);
7959     }
7960   msave->common = s->msave_common;
7961
7962   struct msave_common *c = s->msave_common;
7963   if (factors)
7964     {
7965       if (c->n_factors >= c->allocated_factors)
7966         c->factors = x2nrealloc (c->factors, &c->allocated_factors,
7967                                  sizeof *c->factors);
7968       c->factors[c->n_factors++] = factors;
7969     }
7970   if (c->n_factors > 0)
7971     msave->factors = c->factors[c->n_factors - 1];
7972
7973   if (splits)
7974     {
7975       if (c->n_splits >= c->allocated_splits)
7976         c->splits = x2nrealloc (c->splits, &c->allocated_splits,
7977                                 sizeof *c->splits);
7978       c->splits[c->n_splits++] = splits;
7979     }
7980   if (c->n_splits > 0)
7981     msave->splits = c->splits[c->n_splits - 1];
7982
7983   return cmd;
7984
7985 error:
7986   matrix_expr_destroy (splits);
7987   matrix_expr_destroy (factors);
7988   msave_common_destroy (common);
7989   matrix_command_destroy (cmd);
7990   return NULL;
7991 }
7992
7993 static gsl_vector *
7994 matrix_expr_evaluate_vector (const struct matrix_expr *e, const char *name)
7995 {
7996   gsl_matrix *m = matrix_expr_evaluate (e);
7997   if (!m)
7998     return NULL;
7999
8000   if (!is_vector (m))
8001     {
8002       msg_at (SE, matrix_expr_location (e),
8003               _("%s expression must evaluate to vector, "
8004                 "not a %zu×%zu matrix."),
8005               name, m->size1, m->size2);
8006       gsl_matrix_free (m);
8007       return NULL;
8008     }
8009
8010   return matrix_to_vector (m);
8011 }
8012
8013 static const char *
8014 msave_add_vars (struct dictionary *d, const struct string_array *vars)
8015 {
8016   for (size_t i = 0; i < vars->n; i++)
8017     if (!dict_create_var (d, vars->strings[i], 0))
8018       return vars->strings[i];
8019   return NULL;
8020 }
8021
8022 static struct dictionary *
8023 msave_create_dict (const struct msave_common *common)
8024 {
8025   struct dictionary *dict = dict_create (get_default_encoding ());
8026
8027   const char *dup_split = msave_add_vars (dict, &common->snames);
8028   if (dup_split)
8029     {
8030       /* Should not be possible because the parser ensures that the names are
8031          unique. */
8032       NOT_REACHED ();
8033     }
8034
8035   dict_create_var_assert (dict, "ROWTYPE_", 8);
8036
8037   const char *dup_factor = msave_add_vars (dict, &common->fnames);
8038   if (dup_factor)
8039     {
8040       msg_at (SE, common->fnames_location,
8041               _("Duplicate or invalid FACTOR variable name %s."),
8042               dup_factor);
8043       goto error;
8044     }
8045
8046   dict_create_var_assert (dict, "VARNAME_", 8);
8047
8048   const char *dup_var = msave_add_vars (dict, &common->variables);
8049   if (dup_var)
8050     {
8051       msg_at (SE, common->variables_location,
8052               _("Duplicate or invalid variable name %s."),
8053               dup_var);
8054       goto error;
8055     }
8056
8057   return dict;
8058
8059 error:
8060   dict_unref (dict);
8061   return NULL;
8062 }
8063
8064 static void
8065 matrix_msave_execute (struct matrix_command *cmd)
8066 {
8067   struct matrix_msave *msave = &cmd->msave;
8068   struct msave_common *common = msave->common;
8069   gsl_matrix *m = NULL;
8070   gsl_vector *factors = NULL;
8071   gsl_vector *splits = NULL;
8072
8073   m = matrix_expr_evaluate (msave->expr);
8074   if (!m)
8075     goto error;
8076
8077   if (!common->variables.n)
8078     for (size_t i = 0; i < m->size2; i++)
8079       string_array_append_nocopy (&common->variables,
8080                                   xasprintf ("COL%zu", i + 1));
8081   else if (m->size2 != common->variables.n)
8082     {
8083       msg_at (SE, matrix_expr_location (msave->expr),
8084               _("Matrix on MSAVE has %zu columns but there are %zu variables."),
8085               m->size2, common->variables.n);
8086       goto error;
8087     }
8088
8089   if (msave->factors)
8090     {
8091       factors = matrix_expr_evaluate_vector (msave->factors, "FACTOR");
8092       if (!factors)
8093         goto error;
8094
8095       if (!common->fnames.n)
8096         for (size_t i = 0; i < factors->size; i++)
8097           string_array_append_nocopy (&common->fnames,
8098                                       xasprintf ("FAC%zu", i + 1));
8099       else if (factors->size != common->fnames.n)
8100         {
8101           msg_at (SE, matrix_expr_location (msave->factors),
8102                   _("There are %zu factor variables, "
8103                     "but %zu factor values were supplied."),
8104                   common->fnames.n, factors->size);
8105           goto error;
8106         }
8107     }
8108
8109   if (msave->splits)
8110     {
8111       splits = matrix_expr_evaluate_vector (msave->splits, "SPLIT");
8112       if (!splits)
8113         goto error;
8114
8115       if (!common->snames.n)
8116         for (size_t i = 0; i < splits->size; i++)
8117           string_array_append_nocopy (&common->snames,
8118                                       xasprintf ("SPL%zu", i + 1));
8119       else if (splits->size != common->snames.n)
8120         {
8121           msg_at (SE, matrix_expr_location (msave->splits),
8122                   _("There are %zu split variables, "
8123                     "but %zu split values were supplied."),
8124                   common->snames.n, splits->size);
8125           goto error;
8126         }
8127     }
8128
8129   if (!common->writer)
8130     {
8131       struct dictionary *dict = msave_create_dict (common);
8132       if (!dict)
8133         goto error;
8134
8135       common->writer = any_writer_open (common->outfile, dict);
8136       if (!common->writer)
8137         {
8138           dict_unref (dict);
8139           goto error;
8140         }
8141
8142       common->dict = dict;
8143     }
8144
8145   bool matrix = (!strcmp (msave->rowtype, "COV")
8146                  || !strcmp (msave->rowtype, "CORR"));
8147   for (size_t y = 0; y < m->size1; y++)
8148     {
8149       struct ccase *c = case_create (dict_get_proto (common->dict));
8150       size_t idx = 0;
8151
8152       /* Split variables */
8153       if (splits)
8154         for (size_t i = 0; i < splits->size; i++)
8155           case_data_rw_idx (c, idx++)->f = gsl_vector_get (splits, i);
8156
8157       /* ROWTYPE_. */
8158       buf_copy_str_rpad (CHAR_CAST (char *, case_data_rw_idx (c, idx++)->s), 8,
8159                          msave->rowtype, ' ');
8160
8161       /* Factors. */
8162       if (factors)
8163         for (size_t i = 0; i < factors->size; i++)
8164           *case_num_rw_idx (c, idx++) = gsl_vector_get (factors, i);
8165
8166       /* VARNAME_. */
8167       const char *varname_ = (matrix && y < common->variables.n
8168                               ? common->variables.strings[y]
8169                               : "");
8170       buf_copy_str_rpad (CHAR_CAST (char *, case_data_rw_idx (c, idx++)->s), 8,
8171                          varname_, ' ');
8172
8173       /* Continuous variables. */
8174       for (size_t x = 0; x < m->size2; x++)
8175         case_data_rw_idx (c, idx++)->f = gsl_matrix_get (m, y, x);
8176       casewriter_write (common->writer, c);
8177     }
8178
8179 error:
8180   gsl_matrix_free (m);
8181   gsl_vector_free (factors);
8182   gsl_vector_free (splits);
8183 }
8184 \f
8185 /* MGET. */
8186
8187 static struct matrix_command *
8188 matrix_mget_parse (struct matrix_state *s)
8189 {
8190   struct matrix_command *cmd = xmalloc (sizeof *cmd);
8191   *cmd = (struct matrix_command) {
8192     .type = MCMD_MGET,
8193     .mget = {
8194       .state = s,
8195       .rowtypes = STRINGI_SET_INITIALIZER (cmd->mget.rowtypes),
8196     },
8197   };
8198
8199   struct matrix_mget *mget = &cmd->mget;
8200
8201   lex_match (s->lexer, T_SLASH);
8202   while (lex_token (s->lexer) != T_ENDCMD)
8203     {
8204       if (lex_match_id (s->lexer, "FILE"))
8205         {
8206           lex_match (s->lexer, T_EQUALS);
8207
8208           fh_unref (mget->file);
8209           mget->file = fh_parse (s->lexer, FH_REF_FILE, s->session);
8210           if (!mget->file)
8211             goto error;
8212         }
8213       else if (lex_match_id (s->lexer, "ENCODING"))
8214         {
8215           lex_match (s->lexer, T_EQUALS);
8216           if (!lex_force_string (s->lexer))
8217             goto error;
8218
8219           free (mget->encoding);
8220           mget->encoding = ss_xstrdup (lex_tokss (s->lexer));
8221
8222           lex_get (s->lexer);
8223         }
8224       else if (lex_match_id (s->lexer, "TYPE"))
8225         {
8226           lex_match (s->lexer, T_EQUALS);
8227           while (lex_token (s->lexer) != T_SLASH
8228                  && lex_token (s->lexer) != T_ENDCMD)
8229             {
8230               const char *rowtype = match_rowtype (s->lexer);
8231               if (!rowtype)
8232                 goto error;
8233
8234               stringi_set_insert (&mget->rowtypes, rowtype);
8235             }
8236         }
8237       else
8238         {
8239           lex_error_expecting (s->lexer, "FILE", "TYPE");
8240           goto error;
8241         }
8242       lex_match (s->lexer, T_SLASH);
8243     }
8244   return cmd;
8245
8246 error:
8247   matrix_command_destroy (cmd);
8248   return NULL;
8249 }
8250
8251 static const struct variable *
8252 get_a8_var (const struct msg_location *loc,
8253             const struct dictionary *d, const char *name)
8254 {
8255   const struct variable *v = dict_lookup_var (d, name);
8256   if (!v)
8257     {
8258       msg_at (SE, loc, _("Matrix data file lacks %s variable."), name);
8259       return NULL;
8260     }
8261   if (var_get_width (v) != 8)
8262     {
8263       msg_at (SE, loc, _("%s variable in matrix data file must be "
8264                          "8-byte string, but it has width %d."),
8265               name, var_get_width (v));
8266       return NULL;
8267     }
8268   return v;
8269 }
8270
8271 static bool
8272 var_changed (const struct ccase *ca, const struct ccase *cb,
8273              const struct variable *var)
8274 {
8275   return (ca && cb
8276           ? !value_equal (case_data (ca, var), case_data (cb, var),
8277                           var_get_width (var))
8278           : ca || cb);
8279 }
8280
8281 static bool
8282 vars_changed (const struct ccase *ca, const struct ccase *cb,
8283               const struct dictionary *d,
8284               size_t first_var, size_t n_vars)
8285 {
8286   for (size_t i = 0; i < n_vars; i++)
8287     {
8288       const struct variable *v = dict_get_var (d, first_var + i);
8289       if (var_changed (ca, cb, v))
8290         return true;
8291     }
8292   return false;
8293 }
8294
8295 static bool
8296 vars_all_missing (const struct ccase *c, const struct dictionary *d,
8297                   size_t first_var, size_t n_vars)
8298 {
8299   for (size_t i = 0; i < n_vars; i++)
8300     if (case_num (c, dict_get_var (d, first_var + i)) != SYSMIS)
8301       return false;
8302   return true;
8303 }
8304
8305 static void
8306 matrix_mget_commit_var (struct ccase **rows, size_t n_rows,
8307                         const struct dictionary *d,
8308                         const struct variable *rowtype_var,
8309                         const struct stringi_set *accepted_rowtypes,
8310                         struct matrix_state *s,
8311                         size_t ss, size_t sn, size_t si,
8312                         size_t fs, size_t fn, size_t fi,
8313                         size_t cs, size_t cn,
8314                         struct pivot_table *pt,
8315                         struct pivot_dimension *var_dimension)
8316 {
8317   if (!n_rows)
8318     goto exit;
8319
8320   /* Is this a matrix for pooled data, either where there are no factor
8321      variables or the factor variables are missing? */
8322   bool pooled = !fn || vars_all_missing (rows[0], d, fs, fn);
8323
8324   struct substring rowtype = case_ss (rows[0], rowtype_var);
8325   ss_rtrim (&rowtype, ss_cstr (" "));
8326   if (!stringi_set_is_empty (accepted_rowtypes)
8327       && !stringi_set_contains_len (accepted_rowtypes,
8328                                     rowtype.string, rowtype.length))
8329     goto exit;
8330
8331   const char *prefix = (ss_equals_case (rowtype, ss_cstr ("COV")) ? "CV"
8332                         : ss_equals_case (rowtype, ss_cstr ("CORR")) ? "CR"
8333                         : ss_equals_case (rowtype, ss_cstr ("MEAN")) ? "MN"
8334                         : ss_equals_case (rowtype, ss_cstr ("STDDEV")) ? "SD"
8335                         : ss_equals_case (rowtype, ss_cstr ("N")) ? "NC"
8336                         : ss_equals_case (rowtype, ss_cstr ("COUNT")) ? "CN"
8337                         : NULL);
8338   if (!prefix)
8339     {
8340       msg (SE, _("Matrix data file contains unknown ROWTYPE_ \"%.*s\"."),
8341            (int) rowtype.length, rowtype.string);
8342       goto exit;
8343     }
8344
8345   struct string name = DS_EMPTY_INITIALIZER;
8346   ds_put_cstr (&name, prefix);
8347   if (!pooled)
8348     ds_put_format (&name, "F%zu", fi);
8349   if (si > 0)
8350     ds_put_format (&name, "S%zu", si);
8351
8352   struct matrix_var *mv = matrix_var_lookup (s, ds_ss (&name));
8353   if (!mv)
8354     mv = matrix_var_create (s, ds_ss (&name));
8355   else if (mv->value)
8356     {
8357       msg (SW, _("Matrix data file contains variable with existing name %s."),
8358            ds_cstr (&name));
8359       goto exit_free_name;
8360     }
8361
8362   gsl_matrix *m = gsl_matrix_alloc (n_rows, cn);
8363   size_t n_missing = 0;
8364   for (size_t y = 0; y < n_rows; y++)
8365     {
8366       for (size_t x = 0; x < cn; x++)
8367         {
8368           struct variable *var = dict_get_var (d, cs + x);
8369           double value = case_num (rows[y], var);
8370           if (var_is_num_missing (var, value))
8371             {
8372               n_missing++;
8373               value = 0.0;
8374             }
8375           gsl_matrix_set (m, y, x, value);
8376         }
8377     }
8378
8379   int var_index = pivot_category_create_leaf (
8380     var_dimension->root, pivot_value_new_user_text (ds_cstr (&name), SIZE_MAX));
8381   double values[] = { n_rows, cn };
8382   for (size_t j = 0; j < sn; j++)
8383     {
8384       struct variable *var = dict_get_var (d, ss + j);
8385       const union value *value = case_data (rows[0], var);
8386       pivot_table_put2 (pt, j, var_index,
8387                         pivot_value_new_var_value (var, value));
8388     }
8389   for (size_t j = 0; j < fn; j++)
8390     {
8391       struct variable *var = dict_get_var (d, fs + j);
8392       const union value sysmis = { .f = SYSMIS };
8393       const union value *value = pooled ? &sysmis : case_data (rows[0], var);
8394       pivot_table_put2 (pt, j + sn, var_index,
8395                         pivot_value_new_var_value (var, value));
8396     }
8397   for (size_t j = 0; j < sizeof values / sizeof *values; j++)
8398     pivot_table_put2 (pt, j + sn + fn, var_index,
8399                       pivot_value_new_integer (values[j]));
8400
8401   if (n_missing)
8402     msg (SE, ngettext ("Matrix data file variable %s contains a missing "
8403                        "value, which was treated as zero.",
8404                        "Matrix data file variable %s contains %zu missing "
8405                        "values, which were treated as zero.", n_missing),
8406          ds_cstr (&name), n_missing);
8407   mv->value = m;
8408
8409 exit_free_name:
8410   ds_destroy (&name);
8411
8412 exit:
8413   for (size_t y = 0; y < n_rows; y++)
8414     case_unref (rows[y]);
8415 }
8416
8417 static void
8418 matrix_mget_execute__ (struct matrix_command *cmd, struct casereader *r,
8419                        const struct dictionary *d)
8420 {
8421   struct matrix_mget *mget = &cmd->mget;
8422   const struct msg_location *loc = cmd->location;
8423   const struct variable *rowtype_ = get_a8_var (loc, d, "ROWTYPE_");
8424   const struct variable *varname_ = get_a8_var (loc, d, "VARNAME_");
8425   if (!rowtype_ || !varname_)
8426     return;
8427
8428   if (var_get_dict_index (rowtype_) >= var_get_dict_index (varname_))
8429     {
8430       msg_at (SE, loc,
8431               _("ROWTYPE_ must precede VARNAME_ in matrix data file."));
8432       return;
8433     }
8434   if (var_get_dict_index (varname_) + 1 >= dict_get_n_vars (d))
8435     {
8436       msg_at (SE, loc, _("Matrix data file contains no continuous variables."));
8437       return;
8438     }
8439
8440   for (size_t i = 0; i < dict_get_n_vars (d); i++)
8441     {
8442       const struct variable *v = dict_get_var (d, i);
8443       if (v != rowtype_ && v != varname_ && var_get_width (v) != 0)
8444         {
8445           msg_at (SE, loc,
8446                   _("Matrix data file contains unexpected string variable %s."),
8447                   var_get_name (v));
8448           return;
8449         }
8450     }
8451
8452   /* SPLIT variables. */
8453   size_t ss = 0;
8454   size_t sn = var_get_dict_index (rowtype_);
8455   struct ccase *sc = NULL;
8456   size_t si = 0;
8457
8458   /* FACTOR variables. */
8459   size_t fs = var_get_dict_index (rowtype_) + 1;
8460   size_t fn = var_get_dict_index (varname_) - var_get_dict_index (rowtype_) - 1;
8461   struct ccase *fc = NULL;
8462   size_t fi = 0;
8463
8464   /* Continuous variables. */
8465   size_t cs = var_get_dict_index (varname_) + 1;
8466   size_t cn = dict_get_n_vars (d) - cs;
8467   struct ccase *cc = NULL;
8468
8469   /* Pivot table. */
8470   struct pivot_table *pt = pivot_table_create (
8471     N_("Matrix Variables Created by MGET"));
8472   struct pivot_dimension *attr_dimension = pivot_dimension_create (
8473     pt, PIVOT_AXIS_COLUMN, N_("Attribute"));
8474   struct pivot_dimension *var_dimension = pivot_dimension_create (
8475     pt, PIVOT_AXIS_ROW, N_("Variable"));
8476   if (sn > 0)
8477     {
8478       struct pivot_category *splits = pivot_category_create_group (
8479         attr_dimension->root, N_("Split Values"));
8480       for (size_t i = 0; i < sn; i++)
8481         pivot_category_create_leaf (splits, pivot_value_new_variable (
8482                                       dict_get_var (d, ss + i)));
8483     }
8484   if (fn > 0)
8485     {
8486       struct pivot_category *factors = pivot_category_create_group (
8487         attr_dimension->root, N_("Factors"));
8488       for (size_t i = 0; i < fn; i++)
8489         pivot_category_create_leaf (factors, pivot_value_new_variable (
8490                                       dict_get_var (d, fs + i)));
8491     }
8492   pivot_category_create_group (attr_dimension->root, N_("Dimensions"),
8493                                 N_("Rows"), N_("Columns"));
8494
8495   /* Matrix. */
8496   struct ccase **rows = NULL;
8497   size_t allocated_rows = 0;
8498   size_t n_rows = 0;
8499
8500   struct ccase *c;
8501   while ((c = casereader_read (r)) != NULL)
8502     {
8503       bool row_has_factors = fn && !vars_all_missing (c, d, fs, fn);
8504
8505       enum
8506         {
8507           SPLITS_CHANGED,
8508           FACTORS_CHANGED,
8509           ROWTYPE_CHANGED,
8510           NOTHING_CHANGED
8511         }
8512       change
8513         = (sn && (!sc || vars_changed (sc, c, d, ss, sn)) ? SPLITS_CHANGED
8514            : fn && (!fc || vars_changed (fc, c, d, fs, fn)) ? FACTORS_CHANGED
8515            : !cc || var_changed (cc, c, rowtype_) ? ROWTYPE_CHANGED
8516            : NOTHING_CHANGED);
8517
8518       if (change != NOTHING_CHANGED)
8519         {
8520           matrix_mget_commit_var (rows, n_rows, d,
8521                                   rowtype_, &mget->rowtypes,
8522                                   mget->state,
8523                                   ss, sn, si,
8524                                   fs, fn, fi,
8525                                   cs, cn,
8526                                   pt, var_dimension);
8527           n_rows = 0;
8528           case_unref (cc);
8529           cc = case_ref (c);
8530         }
8531
8532       if (n_rows >= allocated_rows)
8533         rows = x2nrealloc (rows, &allocated_rows, sizeof *rows);
8534       rows[n_rows++] = c;
8535
8536       if (change == SPLITS_CHANGED)
8537         {
8538           si++;
8539           case_unref (sc);
8540           sc = case_ref (c);
8541
8542           /* Reset the factor number, if there are factors. */
8543           if (fn)
8544             {
8545               fi = 0;
8546               if (row_has_factors)
8547                 fi++;
8548               case_unref (fc);
8549               fc = case_ref (c);
8550             }
8551         }
8552       else if (change == FACTORS_CHANGED)
8553         {
8554           if (row_has_factors)
8555             fi++;
8556           case_unref (fc);
8557           fc = case_ref (c);
8558         }
8559     }
8560   matrix_mget_commit_var (rows, n_rows, d,
8561                           rowtype_, &mget->rowtypes,
8562                           mget->state,
8563                           ss, sn, si,
8564                           fs, fn, fi,
8565                           cs, cn,
8566                           pt, var_dimension);
8567   free (rows);
8568
8569   case_unref (sc);
8570   case_unref (fc);
8571   case_unref (cc);
8572
8573   if (var_dimension->n_leaves)
8574     pivot_table_submit (pt);
8575   else
8576     pivot_table_unref (pt);
8577 }
8578
8579 static void
8580 matrix_mget_execute (struct matrix_command *cmd)
8581 {
8582   struct matrix_mget *mget = &cmd->mget;
8583   struct casereader *r;
8584   struct dictionary *d;
8585   if (matrix_open_casereader (cmd, "MGET", mget->file, mget->encoding,
8586                               mget->state->dataset, &r, &d))
8587     {
8588       matrix_mget_execute__ (cmd, r, d);
8589       matrix_close_casereader (mget->file, mget->state->dataset, r, d);
8590     }
8591 }
8592 \f
8593 /* CALL EIGEN. */
8594
8595 static bool
8596 matrix_parse_dst_var (struct matrix_state *s, struct matrix_var **varp)
8597 {
8598   if (!lex_force_id (s->lexer))
8599     return false;
8600
8601   *varp = matrix_var_lookup (s, lex_tokss (s->lexer));
8602   if (!*varp)
8603     *varp = matrix_var_create (s, lex_tokss (s->lexer));
8604   lex_get (s->lexer);
8605   return true;
8606 }
8607
8608 static struct matrix_command *
8609 matrix_eigen_parse (struct matrix_state *s)
8610 {
8611   struct matrix_command *cmd = xmalloc (sizeof *cmd);
8612   *cmd = (struct matrix_command) {
8613     .type = MCMD_EIGEN,
8614     .eigen = { .expr = NULL }
8615   };
8616
8617   struct matrix_eigen *eigen = &cmd->eigen;
8618   if (!lex_force_match (s->lexer, T_LPAREN))
8619     goto error;
8620   eigen->expr = matrix_expr_parse (s);
8621   if (!eigen->expr
8622       || !lex_force_match (s->lexer, T_COMMA)
8623       || !matrix_parse_dst_var (s, &eigen->evec)
8624       || !lex_force_match (s->lexer, T_COMMA)
8625       || !matrix_parse_dst_var (s, &eigen->eval)
8626       || !lex_force_match (s->lexer, T_RPAREN))
8627     goto error;
8628
8629   return cmd;
8630
8631 error:
8632   matrix_command_destroy (cmd);
8633   return NULL;
8634 }
8635
8636 static void
8637 matrix_eigen_execute (struct matrix_command *cmd)
8638 {
8639   struct matrix_eigen *eigen = &cmd->eigen;
8640   gsl_matrix *A = matrix_expr_evaluate (eigen->expr);
8641   if (!A)
8642     return;
8643   if (!is_symmetric (A))
8644     {
8645       msg_at (SE, cmd->location, _("Argument of EIGEN must be symmetric."));
8646       gsl_matrix_free (A);
8647       return;
8648     }
8649
8650   gsl_eigen_symmv_workspace *w = gsl_eigen_symmv_alloc (A->size1);
8651   gsl_matrix *eval = gsl_matrix_alloc (A->size1, 1);
8652   gsl_vector v_eval = to_vector (eval);
8653   gsl_matrix *evec = gsl_matrix_alloc (A->size1, A->size2);
8654   gsl_eigen_symmv (A, &v_eval, evec, w);
8655   gsl_eigen_symmv_free (w);
8656
8657   gsl_eigen_symmv_sort (&v_eval, evec, GSL_EIGEN_SORT_VAL_DESC);
8658
8659   gsl_matrix_free (A);
8660
8661   gsl_matrix_free (eigen->eval->value);
8662   eigen->eval->value = eval;
8663
8664   gsl_matrix_free (eigen->evec->value);
8665   eigen->evec->value = evec;
8666 }
8667 \f
8668 /* CALL SETDIAG. */
8669
8670 static struct matrix_command *
8671 matrix_setdiag_parse (struct matrix_state *s)
8672 {
8673   struct matrix_command *cmd = xmalloc (sizeof *cmd);
8674   *cmd = (struct matrix_command) {
8675     .type = MCMD_SETDIAG,
8676     .setdiag = { .dst = NULL }
8677   };
8678
8679   struct matrix_setdiag *setdiag = &cmd->setdiag;
8680   if (!lex_force_match (s->lexer, T_LPAREN) || !lex_force_id (s->lexer))
8681     goto error;
8682
8683   setdiag->dst = matrix_var_lookup (s, lex_tokss (s->lexer));
8684   if (!setdiag->dst)
8685     {
8686       lex_error (s->lexer, _("Unknown variable %s."), lex_tokcstr (s->lexer));
8687       goto error;
8688     }
8689   lex_get (s->lexer);
8690
8691   if (!lex_force_match (s->lexer, T_COMMA))
8692     goto error;
8693
8694   setdiag->expr = matrix_expr_parse (s);
8695   if (!setdiag->expr)
8696     goto error;
8697
8698   if (!lex_force_match (s->lexer, T_RPAREN))
8699     goto error;
8700
8701   return cmd;
8702
8703 error:
8704   matrix_command_destroy (cmd);
8705   return NULL;
8706 }
8707
8708 static void
8709 matrix_setdiag_execute (struct matrix_command *cmd)
8710 {
8711   struct matrix_setdiag *setdiag = &cmd->setdiag;
8712   gsl_matrix *dst = setdiag->dst->value;
8713   if (!dst)
8714     {
8715       msg_at (SE, cmd->location,
8716               _("SETDIAG destination matrix %s is uninitialized."),
8717               setdiag->dst->name);
8718       return;
8719     }
8720
8721   gsl_matrix *src = matrix_expr_evaluate (setdiag->expr);
8722   if (!src)
8723     return;
8724
8725   size_t n = MIN (dst->size1, dst->size2);
8726   if (is_scalar (src))
8727     {
8728       double d = to_scalar (src);
8729       for (size_t i = 0; i < n; i++)
8730         gsl_matrix_set (dst, i, i, d);
8731     }
8732   else if (is_vector (src))
8733     {
8734       gsl_vector v = to_vector (src);
8735       for (size_t i = 0; i < n && i < v.size; i++)
8736         gsl_matrix_set (dst, i, i, gsl_vector_get (&v, i));
8737     }
8738   else
8739     msg_at (SE, matrix_expr_location (setdiag->expr),
8740             _("SETDIAG argument 2 must be a scalar or a vector, "
8741               "not a %zu×%zu matrix."),
8742             src->size1, src->size2);
8743   gsl_matrix_free (src);
8744 }
8745 \f
8746 /* CALL SVD. */
8747
8748 static struct matrix_command *
8749 matrix_svd_parse (struct matrix_state *s)
8750 {
8751   struct matrix_command *cmd = xmalloc (sizeof *cmd);
8752   *cmd = (struct matrix_command) {
8753     .type = MCMD_SVD,
8754     .svd = { .expr = NULL }
8755   };
8756
8757   struct matrix_svd *svd = &cmd->svd;
8758   if (!lex_force_match (s->lexer, T_LPAREN))
8759     goto error;
8760   svd->expr = matrix_expr_parse (s);
8761   if (!svd->expr
8762       || !lex_force_match (s->lexer, T_COMMA)
8763       || !matrix_parse_dst_var (s, &svd->u)
8764       || !lex_force_match (s->lexer, T_COMMA)
8765       || !matrix_parse_dst_var (s, &svd->s)
8766       || !lex_force_match (s->lexer, T_COMMA)
8767       || !matrix_parse_dst_var (s, &svd->v)
8768       || !lex_force_match (s->lexer, T_RPAREN))
8769     goto error;
8770
8771   return cmd;
8772
8773 error:
8774   matrix_command_destroy (cmd);
8775   return NULL;
8776 }
8777
8778 static void
8779 matrix_svd_execute (struct matrix_svd *svd)
8780 {
8781   gsl_matrix *m = matrix_expr_evaluate (svd->expr);
8782   if (!m)
8783     return;
8784
8785   if (m->size1 >= m->size2)
8786     {
8787       gsl_matrix *A = m;
8788       gsl_matrix *V = gsl_matrix_alloc (A->size2, A->size2);
8789       gsl_matrix *S = gsl_matrix_calloc (A->size2, A->size2);
8790       gsl_vector Sv = gsl_matrix_diagonal (S).vector;
8791       gsl_vector *work = gsl_vector_alloc (A->size2);
8792       gsl_linalg_SV_decomp (A, V, &Sv, work);
8793       gsl_vector_free (work);
8794
8795       matrix_var_set (svd->u, A);
8796       matrix_var_set (svd->s, S);
8797       matrix_var_set (svd->v, V);
8798     }
8799   else
8800     {
8801       gsl_matrix *At = gsl_matrix_alloc (m->size2, m->size1);
8802       gsl_matrix_transpose_memcpy (At, m);
8803       gsl_matrix_free (m);
8804
8805       gsl_matrix *Vt = gsl_matrix_alloc (At->size2, At->size2);
8806       gsl_matrix *St = gsl_matrix_calloc (At->size2, At->size2);
8807       gsl_vector Stv = gsl_matrix_diagonal (St).vector;
8808       gsl_vector *work = gsl_vector_alloc (At->size2);
8809       gsl_linalg_SV_decomp (At, Vt, &Stv, work);
8810       gsl_vector_free (work);
8811
8812       matrix_var_set (svd->v, At);
8813       matrix_var_set (svd->s, St);
8814       matrix_var_set (svd->u, Vt);
8815     }
8816 }
8817 \f
8818 /* The main MATRIX command logic. */
8819
8820 static bool
8821 matrix_command_execute (struct matrix_command *cmd)
8822 {
8823   switch (cmd->type)
8824     {
8825     case MCMD_COMPUTE:
8826       matrix_compute_execute (cmd);
8827       break;
8828
8829     case MCMD_PRINT:
8830       matrix_print_execute (&cmd->print);
8831       break;
8832
8833     case MCMD_DO_IF:
8834       return matrix_do_if_execute (&cmd->do_if);
8835
8836     case MCMD_LOOP:
8837       matrix_loop_execute (&cmd->loop);
8838       break;
8839
8840     case MCMD_BREAK:
8841       return false;
8842
8843     case MCMD_DISPLAY:
8844       matrix_display_execute (&cmd->display);
8845       break;
8846
8847     case MCMD_RELEASE:
8848       matrix_release_execute (&cmd->release);
8849       break;
8850
8851     case MCMD_SAVE:
8852       matrix_save_execute (cmd);
8853       break;
8854
8855     case MCMD_READ:
8856       matrix_read_execute (cmd);
8857       break;
8858
8859     case MCMD_WRITE:
8860       matrix_write_execute (&cmd->write);
8861       break;
8862
8863     case MCMD_GET:
8864       matrix_get_execute (cmd);
8865       break;
8866
8867     case MCMD_MSAVE:
8868       matrix_msave_execute (cmd);
8869       break;
8870
8871     case MCMD_MGET:
8872       matrix_mget_execute (cmd);
8873       break;
8874
8875     case MCMD_EIGEN:
8876       matrix_eigen_execute (cmd);
8877       break;
8878
8879     case MCMD_SETDIAG:
8880       matrix_setdiag_execute (cmd);
8881       break;
8882
8883     case MCMD_SVD:
8884       matrix_svd_execute (&cmd->svd);
8885       break;
8886     }
8887
8888   return true;
8889 }
8890
8891 static void
8892 matrix_command_destroy (struct matrix_command *cmd)
8893 {
8894   if (!cmd)
8895     return;
8896
8897   msg_location_destroy (cmd->location);
8898
8899   switch (cmd->type)
8900     {
8901     case MCMD_COMPUTE:
8902       matrix_lvalue_destroy (cmd->compute.lvalue);
8903       matrix_expr_destroy (cmd->compute.rvalue);
8904       break;
8905
8906     case MCMD_PRINT:
8907       matrix_expr_destroy (cmd->print.expression);
8908       free (cmd->print.title);
8909       print_labels_destroy (cmd->print.rlabels);
8910       print_labels_destroy (cmd->print.clabels);
8911       break;
8912
8913     case MCMD_DO_IF:
8914       for (size_t i = 0; i < cmd->do_if.n_clauses; i++)
8915         {
8916           matrix_expr_destroy (cmd->do_if.clauses[i].condition);
8917           matrix_commands_uninit (&cmd->do_if.clauses[i].commands);
8918         }
8919       free (cmd->do_if.clauses);
8920       break;
8921
8922     case MCMD_LOOP:
8923       matrix_expr_destroy (cmd->loop.start);
8924       matrix_expr_destroy (cmd->loop.end);
8925       matrix_expr_destroy (cmd->loop.increment);
8926       matrix_expr_destroy (cmd->loop.top_condition);
8927       matrix_expr_destroy (cmd->loop.bottom_condition);
8928       matrix_commands_uninit (&cmd->loop.commands);
8929       break;
8930
8931     case MCMD_BREAK:
8932       break;
8933
8934     case MCMD_DISPLAY:
8935       break;
8936
8937     case MCMD_RELEASE:
8938       free (cmd->release.vars);
8939       break;
8940
8941     case MCMD_SAVE:
8942       matrix_expr_destroy (cmd->save.expression);
8943       break;
8944
8945     case MCMD_READ:
8946       matrix_lvalue_destroy (cmd->read.dst);
8947       matrix_expr_destroy (cmd->read.size);
8948       break;
8949
8950     case MCMD_WRITE:
8951       matrix_expr_destroy (cmd->write.expression);
8952       free (cmd->write.format);
8953       break;
8954
8955     case MCMD_GET:
8956       matrix_lvalue_destroy (cmd->get.dst);
8957       fh_unref (cmd->get.file);
8958       free (cmd->get.encoding);
8959       var_syntax_destroy (cmd->get.vars, cmd->get.n_vars);
8960       break;
8961
8962     case MCMD_MSAVE:
8963       matrix_expr_destroy (cmd->msave.expr);
8964       break;
8965
8966     case MCMD_MGET:
8967       fh_unref (cmd->mget.file);
8968       stringi_set_destroy (&cmd->mget.rowtypes);
8969       break;
8970
8971     case MCMD_EIGEN:
8972       matrix_expr_destroy (cmd->eigen.expr);
8973       break;
8974
8975     case MCMD_SETDIAG:
8976       matrix_expr_destroy (cmd->setdiag.expr);
8977       break;
8978
8979     case MCMD_SVD:
8980       matrix_expr_destroy (cmd->svd.expr);
8981       break;
8982     }
8983   free (cmd);
8984 }
8985
8986 static bool
8987 matrix_commands_parse (struct matrix_state *s, struct matrix_commands *c,
8988                        const char *command_name,
8989                        const char *stop1, const char *stop2)
8990 {
8991   lex_end_of_command (s->lexer);
8992   lex_discard_rest_of_command (s->lexer);
8993
8994   size_t allocated = 0;
8995   for (;;)
8996     {
8997       while (lex_token (s->lexer) == T_ENDCMD)
8998         lex_get (s->lexer);
8999
9000       if (lex_at_phrase (s->lexer, stop1)
9001           || (stop2 && lex_at_phrase (s->lexer, stop2)))
9002         return true;
9003
9004       if (lex_at_phrase (s->lexer, "END MATRIX"))
9005         {
9006           lex_next_error (s->lexer, 0, 1,
9007                           _("Premature END MATRIX within %s."), command_name);
9008           return false;
9009         }
9010
9011       struct matrix_command *cmd = matrix_command_parse (s);
9012       if (!cmd)
9013         return false;
9014
9015       if (c->n >= allocated)
9016         c->commands = x2nrealloc (c->commands, &allocated, sizeof *c->commands);
9017       c->commands[c->n++] = cmd;
9018     }
9019 }
9020
9021 static void
9022 matrix_commands_uninit (struct matrix_commands *cmds)
9023 {
9024   for (size_t i = 0; i < cmds->n; i++)
9025     matrix_command_destroy (cmds->commands[i]);
9026   free (cmds->commands);
9027 }
9028
9029 struct matrix_command_name
9030   {
9031     const char *name;
9032     struct matrix_command *(*parse) (struct matrix_state *);
9033   };
9034
9035 static const struct matrix_command_name *
9036 matrix_command_name_parse (struct lexer *lexer)
9037 {
9038   static const struct matrix_command_name commands[] = {
9039     { "COMPUTE", matrix_compute_parse },
9040     { "CALL EIGEN", matrix_eigen_parse },
9041     { "CALL SETDIAG", matrix_setdiag_parse },
9042     { "CALL SVD", matrix_svd_parse },
9043     { "PRINT", matrix_print_parse },
9044     { "DO IF", matrix_do_if_parse },
9045     { "LOOP", matrix_loop_parse },
9046     { "BREAK", matrix_break_parse },
9047     { "READ", matrix_read_parse },
9048     { "WRITE", matrix_write_parse },
9049     { "GET", matrix_get_parse },
9050     { "SAVE", matrix_save_parse },
9051     { "MGET", matrix_mget_parse },
9052     { "MSAVE", matrix_msave_parse },
9053     { "DISPLAY", matrix_display_parse },
9054     { "RELEASE", matrix_release_parse },
9055   };
9056   static size_t n = sizeof commands / sizeof *commands;
9057
9058   for (const struct matrix_command_name *c = commands; c < &commands[n]; c++)
9059     if (lex_match_phrase (lexer, c->name))
9060       return c;
9061   return NULL;
9062 }
9063
9064 static struct matrix_command *
9065 matrix_command_parse (struct matrix_state *s)
9066 {
9067   int start_ofs = lex_ofs (s->lexer);
9068   size_t nesting_level = SIZE_MAX;
9069
9070   struct matrix_command *c = NULL;
9071   const struct matrix_command_name *cmd = matrix_command_name_parse (s->lexer);
9072   if (!cmd)
9073     lex_error (s->lexer, _("Unknown matrix command."));
9074   else if (!cmd->parse)
9075     lex_error (s->lexer, _("Matrix command %s is not yet implemented."),
9076                cmd->name);
9077   else
9078     {
9079       nesting_level = output_open_group (
9080         group_item_create_nocopy (utf8_to_title (cmd->name),
9081                                   utf8_to_title (cmd->name)));
9082       c = cmd->parse (s);
9083     }
9084
9085   if (c)
9086     {
9087       c->location = lex_ofs_location (s->lexer, start_ofs, lex_ofs (s->lexer));
9088       msg_location_remove_columns (c->location);
9089       lex_end_of_command (s->lexer);
9090     }
9091   lex_discard_rest_of_command (s->lexer);
9092   if (nesting_level != SIZE_MAX)
9093     output_close_groups (nesting_level);
9094
9095   return c;
9096 }
9097
9098 int
9099 cmd_matrix (struct lexer *lexer, struct dataset *ds)
9100 {
9101   if (!lex_force_match (lexer, T_ENDCMD))
9102     return CMD_FAILURE;
9103
9104   struct matrix_state state = {
9105     .dataset = ds,
9106     .session = dataset_session (ds),
9107     .lexer = lexer,
9108     .vars = HMAP_INITIALIZER (state.vars),
9109   };
9110
9111   for (;;)
9112     {
9113       while (lex_match (lexer, T_ENDCMD))
9114         continue;
9115       if (lex_token (lexer) == T_STOP)
9116         {
9117           msg (SE, _("Unexpected end of input expecting matrix command."));
9118           break;
9119         }
9120
9121       if (lex_match_phrase (lexer, "END MATRIX"))
9122         break;
9123
9124       struct matrix_command *c = matrix_command_parse (&state);
9125       if (c)
9126         {
9127           matrix_command_execute (c);
9128           matrix_command_destroy (c);
9129         }
9130     }
9131
9132   struct matrix_var *var, *next;
9133   HMAP_FOR_EACH_SAFE (var, next, struct matrix_var, hmap_node, &state.vars)
9134     {
9135       free (var->name);
9136       gsl_matrix_free (var->value);
9137       hmap_delete (&state.vars, &var->hmap_node);
9138       free (var);
9139     }
9140   hmap_destroy (&state.vars);
9141   msave_common_destroy (state.msave_common);
9142   fh_unref (state.prev_read_file);
9143   for (size_t i = 0; i < state.n_read_files; i++)
9144     read_file_destroy (state.read_files[i]);
9145   free (state.read_files);
9146   fh_unref (state.prev_write_file);
9147   for (size_t i = 0; i < state.n_write_files; i++)
9148     write_file_destroy (state.write_files[i]);
9149   free (state.write_files);
9150   fh_unref (state.prev_save_file);
9151   for (size_t i = 0; i < state.n_save_files; i++)
9152     save_file_destroy (state.save_files[i]);
9153   free (state.save_files);
9154
9155   return CMD_SUCCESS;
9156 }