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