--- /dev/null
+/* PSPP - a program for statistical analysis.
+ Copyright (C) 2021 Free Software Foundation, Inc.
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+#include <gsl/gsl_blas.h>
+#include <gsl/gsl_eigen.h>
+#include <gsl/gsl_linalg.h>
+#include <gsl/gsl_matrix.h>
+#include <gsl/gsl_permutation.h>
+#include <gsl/gsl_randist.h>
+#include <gsl/gsl_vector.h>
+#include <limits.h>
+#include <math.h>
+#include <uniwidth.h>
+
+#include "data/any-reader.h"
+#include "data/any-writer.h"
+#include "data/casereader.h"
+#include "data/casewriter.h"
+#include "data/data-in.h"
+#include "data/data-out.h"
+#include "data/dataset.h"
+#include "data/dictionary.h"
+#include "data/file-handle-def.h"
+#include "language/command.h"
+#include "language/data-io/data-reader.h"
+#include "language/data-io/data-writer.h"
+#include "language/data-io/file-handle.h"
+#include "language/lexer/format-parser.h"
+#include "language/lexer/lexer.h"
+#include "language/lexer/variable-parser.h"
+#include "libpspp/array.h"
+#include "libpspp/assertion.h"
+#include "libpspp/compiler.h"
+#include "libpspp/hmap.h"
+#include "libpspp/i18n.h"
+#include "libpspp/misc.h"
+#include "libpspp/str.h"
+#include "libpspp/string-array.h"
+#include "libpspp/stringi-set.h"
+#include "libpspp/u8-line.h"
+#include "math/random.h"
+#include "output/driver.h"
+#include "output/output-item.h"
+#include "output/pivot-table.h"
+
+#include "gl/c-ctype.h"
+#include "gl/minmax.h"
+#include "gl/xsize.h"
+
+#include "gettext.h"
+#define _(msgid) gettext (msgid)
+#define N_(msgid) (msgid)
+
+struct matrix_var
+ {
+ struct hmap_node hmap_node;
+ const char *name;
+ gsl_matrix *value;
+ };
+
+struct msave_common
+ {
+ /* Configuration. */
+ struct file_handle *outfile;
+ struct string_array variables;
+ struct string_array fnames;
+ struct string_array snames;
+ bool has_factors;
+ bool has_splits;
+ size_t n_varnames;
+
+ /* Execution state. */
+ struct dictionary *dict;
+ struct casewriter *writer;
+ };
+
+struct read_file
+ {
+ struct file_handle *file;
+ struct dfm_reader *reader;
+ char *encoding;
+ };
+
+struct matrix_state
+ {
+ struct dataset *dataset;
+ struct session *session;
+ struct lexer *lexer;
+ struct hmap vars;
+ bool in_loop;
+ struct file_handle *prev_save_outfile;
+ struct file_handle *prev_write_outfile;
+ struct msave_common *common;
+
+ struct file_handle *prev_read_file;
+ struct read_file **read_files;
+ size_t n_read_files;
+ };
+
+static struct matrix_var *
+matrix_var_lookup (struct matrix_state *s, struct substring name)
+{
+ struct matrix_var *var;
+
+ HMAP_FOR_EACH_WITH_HASH (var, struct matrix_var, hmap_node,
+ utf8_hash_case_substring (name, 0), &s->vars)
+ if (!utf8_sscasecmp (ss_cstr (var->name), name))
+ return var;
+
+ return NULL;
+}
+
+static struct matrix_var *
+matrix_var_create (struct matrix_state *s, struct substring name)
+{
+ struct matrix_var *var = xmalloc (sizeof *var);
+ *var = (struct matrix_var) { .name = ss_xstrdup (name) };
+ hmap_insert (&s->vars, &var->hmap_node, utf8_hash_case_substring (name, 0));
+ return var;
+}
+
+static void
+matrix_var_set (struct matrix_var *var, gsl_matrix *value)
+{
+ gsl_matrix_free (var->value);
+ var->value = value;
+}
+\f
+#define MATRIX_FUNCTIONS \
+ F(ABS, m_m) \
+ F(ALL, d_m) \
+ F(ANY, d_m) \
+ F(ARSIN, m_m) \
+ F(ARTAN, m_m) \
+ F(BLOCK, m_any) \
+ F(CHOL, m_m) \
+ F(CMIN, m_m) \
+ F(CMAX, m_m) \
+ F(COS, m_m) \
+ F(CSSQ, m_m) \
+ F(CSUM, m_m) \
+ F(DESIGN, m_m) \
+ F(DET, d_m) \
+ F(DIAG, m_m) \
+ F(EVAL, m_m) \
+ F(EXP, m_m) \
+ F(GINV, m_m) \
+ F(GRADE, m_m) \
+ F(GSCH, m_m) \
+ F(IDENT, IDENT) \
+ F(INV, m_m) \
+ F(KRONEKER, m_mm) \
+ F(LG10, m_m) \
+ F(LN, m_m) \
+ F(MAGIC, m_d) \
+ F(MAKE, m_ddd) \
+ F(MDIAG, m_v) \
+ F(MMAX, d_m) \
+ F(MMIN, d_m) \
+ F(MOD, m_md) \
+ F(MSSQ, d_m) \
+ F(MSUM, d_m) \
+ F(NCOL, d_m) \
+ F(NROW, d_m) \
+ F(RANK, d_m) \
+ F(RESHAPE, m_mdd) \
+ F(RMAX, m_m) \
+ F(RMIN, m_m) \
+ F(RND, m_m) \
+ F(RNKORDER, m_m) \
+ F(RSSQ, m_m) \
+ F(RSUM, m_m) \
+ F(SIN, m_m) \
+ F(SOLVE, m_mm) \
+ F(SQRT, m_m) \
+ F(SSCP, m_m) \
+ F(SVAL, m_m) \
+ F(SWEEP, m_md) \
+ F(T, m_m) \
+ F(TRACE, d_m) \
+ F(TRANSPOS, m_m) \
+ F(TRUNC, m_m) \
+ F(UNIFORM, m_dd)
+
+enum { m_d_MIN_ARGS = 1, m_d_MAX_ARGS = 1 };
+enum { m_dd_MIN_ARGS = 2, m_dd_MAX_ARGS = 2 };
+enum { m_ddd_MIN_ARGS = 3, m_ddd_MAX_ARGS = 3 };
+enum { m_m_MIN_ARGS = 1, m_m_MAX_ARGS = 1 };
+enum { m_md_MIN_ARGS = 2, m_md_MAX_ARGS = 2 };
+enum { m_mdd_MIN_ARGS = 3, m_mdd_MAX_ARGS = 3 };
+enum { m_mm_MIN_ARGS = 2, m_mm_MAX_ARGS = 2 };
+enum { m_v_MIN_ARGS = 1, m_v_MAX_ARGS = 1 };
+enum { d_m_MIN_ARGS = 1, d_m_MAX_ARGS = 1 };
+enum { m_any_MIN_ARGS = 1, m_any_MAX_ARGS = INT_MAX };
+enum { IDENT_MIN_ARGS = 1, IDENT_MAX_ARGS = 2 };
+
+typedef gsl_matrix *matrix_proto_m_d (double);
+typedef gsl_matrix *matrix_proto_m_dd (double, double);
+typedef gsl_matrix *matrix_proto_m_ddd (double, double, double);
+typedef gsl_matrix *matrix_proto_m_m (gsl_matrix *);
+typedef gsl_matrix *matrix_proto_m_md (gsl_matrix *, double);
+typedef gsl_matrix *matrix_proto_m_mdd (gsl_matrix *, double, double);
+typedef gsl_matrix *matrix_proto_m_mm (gsl_matrix *, gsl_matrix *);
+typedef gsl_matrix *matrix_proto_m_v (gsl_vector *);
+typedef double matrix_proto_d_m (gsl_matrix *);
+typedef gsl_matrix *matrix_proto_m_any (gsl_matrix *[], size_t n);
+typedef gsl_matrix *matrix_proto_IDENT (double, double);
+
+#define F(NAME, PROTOTYPE) static matrix_proto_##PROTOTYPE matrix_eval_##NAME;
+MATRIX_FUNCTIONS
+#undef F
+\f
+/* Matrix expressions. */
+
+struct matrix_expr
+ {
+ enum matrix_op
+ {
+ /* Functions. */
+#define F(NAME, PROTOTYPE) MOP_F_##NAME,
+ MATRIX_FUNCTIONS
+#undef F
+
+ /* Elementwise and scalar arithmetic. */
+ MOP_NEGATE, /* unary - */
+ MOP_ADD_ELEMS, /* + */
+ MOP_SUB_ELEMS, /* - */
+ MOP_MUL_ELEMS, /* &* */
+ MOP_DIV_ELEMS, /* / and &/ */
+ MOP_EXP_ELEMS, /* &** */
+ MOP_SEQ, /* a:b */
+ MOP_SEQ_BY, /* a:b:c */
+
+ /* Matrix arithmetic. */
+ MOP_MUL_MAT, /* * */
+ MOP_EXP_MAT, /* ** */
+
+ /* Relational. */
+ MOP_GT, /* > */
+ MOP_GE, /* >= */
+ MOP_LT, /* < */
+ MOP_LE, /* <= */
+ MOP_EQ, /* = */
+ MOP_NE, /* <> */
+
+ /* Logical. */
+ MOP_NOT, /* NOT */
+ MOP_AND, /* AND */
+ MOP_OR, /* OR */
+ MOP_XOR, /* XOR */
+
+ /* {}. */
+ MOP_PASTE_HORZ, /* a, b, c, ... */
+ MOP_PASTE_VERT, /* a; b; c; ... */
+ MOP_EMPTY, /* {} */
+
+ /* Sub-matrices. */
+ MOP_VEC_INDEX, /* x(y) */
+ MOP_VEC_ALL, /* x(:) */
+ MOP_MAT_INDEX, /* x(y,z) */
+ MOP_ROW_INDEX, /* x(y,:) */
+ MOP_COL_INDEX, /* x(:,z) */
+
+ /* Literals. */
+ MOP_NUMBER,
+ MOP_VARIABLE,
+
+ /* Oddball stuff. */
+ MOP_EOF, /* EOF('file') */
+ }
+ op;
+
+ union
+ {
+ struct
+ {
+ struct matrix_expr **subs;
+ size_t n_subs;
+ };
+
+ double number;
+ struct matrix_var *variable;
+ struct read_file *eof;
+ };
+ };
+
+static void
+matrix_expr_destroy (struct matrix_expr *e)
+{
+ if (!e)
+ return;
+
+ switch (e->op)
+ {
+#define F(NAME, PROTOTYPE) case MOP_F_##NAME:
+MATRIX_FUNCTIONS
+#undef F
+ case MOP_NEGATE:
+ case MOP_ADD_ELEMS:
+ case MOP_SUB_ELEMS:
+ case MOP_MUL_ELEMS:
+ case MOP_DIV_ELEMS:
+ case MOP_EXP_ELEMS:
+ case MOP_SEQ:
+ case MOP_SEQ_BY:
+ case MOP_MUL_MAT:
+ case MOP_EXP_MAT:
+ case MOP_GT:
+ case MOP_GE:
+ case MOP_LT:
+ case MOP_LE:
+ case MOP_EQ:
+ case MOP_NE:
+ case MOP_NOT:
+ case MOP_AND:
+ case MOP_OR:
+ case MOP_XOR:
+ case MOP_EMPTY:
+ case MOP_PASTE_HORZ:
+ case MOP_PASTE_VERT:
+ case MOP_VEC_INDEX:
+ case MOP_VEC_ALL:
+ case MOP_MAT_INDEX:
+ case MOP_ROW_INDEX:
+ case MOP_COL_INDEX:
+ for (size_t i = 0; i < e->n_subs; i++)
+ matrix_expr_destroy (e->subs[i]);
+ break;
+
+ case MOP_NUMBER:
+ case MOP_VARIABLE:
+ case MOP_EOF:
+ break;
+ }
+ free (e);
+}
+
+static struct matrix_expr *
+matrix_expr_create_subs (enum matrix_op op, struct matrix_expr **subs,
+ size_t n_subs)
+{
+ struct matrix_expr *e = xmalloc (sizeof *e);
+ *e = (struct matrix_expr) {
+ .op = op,
+ .subs = xmemdup (subs, n_subs * sizeof *subs),
+ .n_subs = n_subs
+ };
+ return e;
+}
+
+static struct matrix_expr *
+matrix_expr_create_0 (enum matrix_op op)
+{
+ struct matrix_expr *sub;
+ return matrix_expr_create_subs (op, &sub, 0);
+}
+
+static struct matrix_expr *
+matrix_expr_create_1 (enum matrix_op op, struct matrix_expr *sub)
+{
+ return matrix_expr_create_subs (op, &sub, 1);
+}
+
+static struct matrix_expr *
+matrix_expr_create_2 (enum matrix_op op,
+ struct matrix_expr *sub0, struct matrix_expr *sub1)
+{
+ struct matrix_expr *subs[] = { sub0, sub1 };
+ return matrix_expr_create_subs (op, subs, sizeof subs / sizeof *subs);
+}
+
+static struct matrix_expr *
+matrix_expr_create_3 (enum matrix_op op, struct matrix_expr *sub0,
+ struct matrix_expr *sub1, struct matrix_expr *sub2)
+{
+ struct matrix_expr *subs[] = { sub0, sub1, sub2 };
+ return matrix_expr_create_subs (op, subs, sizeof subs / sizeof *subs);
+}
+
+static struct matrix_expr *
+matrix_expr_create_number (double number)
+{
+ struct matrix_expr *e = xmalloc (sizeof *e);
+ *e = (struct matrix_expr) { .op = MOP_NUMBER, .number = number };
+ return e;
+}
+
+static struct matrix_expr *matrix_parse_or_xor (struct matrix_state *);
+
+static struct matrix_expr *
+matrix_parse_curly_comma (struct matrix_state *s)
+{
+ struct matrix_expr *lhs = matrix_parse_or_xor (s);
+ if (!lhs)
+ return NULL;
+
+ while (lex_match (s->lexer, T_COMMA))
+ {
+ struct matrix_expr *rhs = matrix_parse_or_xor (s);
+ if (!rhs)
+ {
+ matrix_expr_destroy (lhs);
+ return NULL;
+ }
+ lhs = matrix_expr_create_2 (MOP_PASTE_HORZ, lhs, rhs);
+ }
+ return lhs;
+}
+
+static struct matrix_expr *
+matrix_parse_curly_semi (struct matrix_state *s)
+{
+ if (lex_token (s->lexer) == T_RCURLY)
+ return matrix_expr_create_0 (MOP_EMPTY);
+
+ struct matrix_expr *lhs = matrix_parse_curly_comma (s);
+ if (!lhs)
+ return NULL;
+
+ while (lex_match (s->lexer, T_SEMICOLON))
+ {
+ struct matrix_expr *rhs = matrix_parse_curly_comma (s);
+ if (!rhs)
+ {
+ matrix_expr_destroy (lhs);
+ return NULL;
+ }
+ lhs = matrix_expr_create_2 (MOP_PASTE_VERT, lhs, rhs);
+ }
+ return lhs;
+}
+
+#define MATRIX_FOR_ALL_ELEMENTS(D, Y, X, M) \
+ for (size_t Y = 0; Y < (M)->size1; Y++) \
+ for (size_t X = 0; X < (M)->size2; X++) \
+ for (double *D = gsl_matrix_ptr ((M), Y, X); D; D = NULL)
+
+static bool
+is_vector (gsl_matrix *m)
+{
+ return m->size1 <= 1 || m->size2 <= 1;
+}
+
+static gsl_vector
+to_vector (gsl_matrix *m)
+{
+ return (m->size1 == 1
+ ? gsl_matrix_row (m, 0).vector
+ : gsl_matrix_column (m, 0).vector);
+}
+
+
+static gsl_matrix *
+matrix_eval_ABS (gsl_matrix *m)
+{
+ MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
+ *d = fabs (*d);
+ return m;
+}
+
+static double
+matrix_eval_ALL (gsl_matrix *m)
+{
+ MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
+ if (*d == 0.0)
+ return 0.0;
+ return 1.0;
+}
+
+static double
+matrix_eval_ANY (gsl_matrix *m)
+{
+ MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
+ if (*d != 0.0)
+ return !.0;
+ return 0.0;
+}
+
+static gsl_matrix *
+matrix_eval_ARSIN (gsl_matrix *m)
+{
+ MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
+ *d = asin (*d);
+ return m;
+}
+
+static gsl_matrix *
+matrix_eval_ARTAN (gsl_matrix *m)
+{
+ MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
+ *d = atan (*d);
+ return m;
+}
+
+static gsl_matrix *
+matrix_eval_BLOCK (gsl_matrix *m[], size_t n)
+{
+ size_t r = 0;
+ size_t c = 0;
+ for (size_t i = 0; i < n; i++)
+ {
+ r += m[i]->size1;
+ c += m[i]->size2;
+ }
+ gsl_matrix *block = gsl_matrix_calloc (r, c);
+ r = c = 0;
+ for (size_t i = 0; i < n; i++)
+ {
+ for (size_t y = 0; y < m[i]->size1; y++)
+ for (size_t x = 0; x < m[i]->size2; x++)
+ gsl_matrix_set (block, r + y, c + x, gsl_matrix_get (m[i], y, x));
+ r += m[i]->size1;
+ c += m[i]->size2;
+ }
+ return block;
+}
+
+static gsl_matrix *
+matrix_eval_CHOL (gsl_matrix *m)
+{
+ if (!gsl_linalg_cholesky_decomp1 (m))
+ {
+ for (size_t y = 0; y < m->size1; y++)
+ for (size_t x = y + 1; x < m->size2; x++)
+ gsl_matrix_set (m, y, x, gsl_matrix_get (m, x, y));
+
+ for (size_t y = 0; y < m->size1; y++)
+ for (size_t x = 0; x < y; x++)
+ gsl_matrix_set (m, y, x, 0);
+ return m;
+ }
+ else
+ {
+ msg (SE, _("Input to CHOL function is not positive-definite."));
+ return NULL;
+ }
+}
+
+static gsl_matrix *
+matrix_eval_col_extremum (gsl_matrix *m, bool min)
+{
+ if (m->size1 <= 1)
+ return m;
+ else if (!m->size2)
+ return gsl_matrix_alloc (1, 0);
+
+ gsl_matrix *cext = gsl_matrix_alloc (1, m->size2);
+ for (size_t x = 0; x < m->size2; x++)
+ {
+ double ext = gsl_matrix_get (m, 0, x);
+ for (size_t y = 1; y < m->size1; y++)
+ {
+ double value = gsl_matrix_get (m, y, x);
+ if (min ? value < ext : value > ext)
+ ext = value;
+ }
+ gsl_matrix_set (cext, 0, x, ext);
+ }
+ return cext;
+}
+
+static gsl_matrix *
+matrix_eval_CMAX (gsl_matrix *m)
+{
+ return matrix_eval_col_extremum (m, false);
+}
+
+static gsl_matrix *
+matrix_eval_CMIN (gsl_matrix *m)
+{
+ return matrix_eval_col_extremum (m, true);
+}
+
+static gsl_matrix *
+matrix_eval_COS (gsl_matrix *m)
+{
+ MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
+ *d = cos (*d);
+ return m;
+}
+
+static gsl_matrix *
+matrix_eval_col_sum (gsl_matrix *m, bool square)
+{
+ if (m->size1 == 0)
+ return m;
+ else if (!m->size2)
+ return gsl_matrix_alloc (1, 0);
+
+ gsl_matrix *result = gsl_matrix_alloc (1, m->size2);
+ for (size_t x = 0; x < m->size2; x++)
+ {
+ double sum = 0;
+ for (size_t y = 0; y < m->size1; y++)
+ {
+ double d = gsl_matrix_get (m, y, x);
+ sum += square ? pow2 (d) : d;
+ }
+ gsl_matrix_set (result, 0, x, sum);
+ }
+ return result;
+}
+
+static gsl_matrix *
+matrix_eval_CSSQ (gsl_matrix *m)
+{
+ return matrix_eval_col_sum (m, true);
+}
+
+static gsl_matrix *
+matrix_eval_CSUM (gsl_matrix *m)
+{
+ return matrix_eval_col_sum (m, false);
+}
+
+static int
+compare_double_3way (const void *a_, const void *b_)
+{
+ const double *a = a_;
+ const double *b = b_;
+ return *a < *b ? -1 : *a > *b;
+}
+
+static gsl_matrix *
+matrix_eval_DESIGN (gsl_matrix *m)
+{
+ double *tmp = xmalloc (m->size1 * m->size2 * sizeof *tmp);
+ gsl_matrix m2 = gsl_matrix_view_array (tmp, m->size2, m->size1).matrix;
+ gsl_matrix_transpose_memcpy (&m2, m);
+
+ for (size_t y = 0; y < m2.size1; y++)
+ qsort (tmp + y * m2.size2, m2.size2, sizeof *tmp, compare_double_3way);
+
+ size_t *n = xcalloc (m2.size1, sizeof *n);
+ size_t n_total = 0;
+ for (size_t i = 0; i < m2.size1; i++)
+ {
+ double *row = tmp + m2.size2 * i;
+ for (size_t j = 0; j < m2.size2; )
+ {
+ size_t k;
+ for (k = j + 1; k < m2.size2; k++)
+ if (row[j] != row[k])
+ break;
+ row[n[i]++] = row[j];
+ j = k;
+ }
+
+ if (n[i] <= 1)
+ msg (MW, _("Column %zu in DESIGN argument has constant value."), i + 1);
+ else
+ n_total += n[i];
+ }
+
+ gsl_matrix *result = gsl_matrix_alloc (m->size1, n_total);
+ size_t x = 0;
+ for (size_t i = 0; i < m->size2; i++)
+ {
+ if (n[i] <= 1)
+ continue;
+
+ const double *unique = tmp + m2.size2 * i;
+ for (size_t j = 0; j < n[i]; j++, x++)
+ {
+ double value = unique[j];
+ for (size_t y = 0; y < m->size1; y++)
+ gsl_matrix_set (result, y, x, gsl_matrix_get (m, y, i) == value);
+ }
+ }
+
+ free (n);
+ free (tmp);
+
+ return result;
+}
+
+static double
+matrix_eval_DET (gsl_matrix *m)
+{
+ gsl_permutation *p = gsl_permutation_alloc (m->size1);
+ int signum;
+ gsl_linalg_LU_decomp (m, p, &signum);
+ gsl_permutation_free (p);
+ return gsl_linalg_LU_det (m, signum);
+}
+
+static gsl_matrix *
+matrix_eval_DIAG (gsl_matrix *m)
+{
+ gsl_matrix *diag = gsl_matrix_alloc (MIN (m->size1, m->size2), 1);
+ for (size_t i = 0; i < diag->size1; i++)
+ gsl_matrix_set (diag, i, 0, gsl_matrix_get (m, i, i));
+ return diag;
+}
+
+static bool
+is_symmetric (const gsl_matrix *m)
+{
+ if (m->size1 != m->size2)
+ return false;
+
+ for (size_t y = 0; y < m->size1; y++)
+ for (size_t x = 0; x < y; x++)
+ if (gsl_matrix_get (m, y, x) != gsl_matrix_get (m, x, y))
+ return false;
+
+ return true;
+}
+
+static int
+compare_double_desc (const void *a_, const void *b_)
+{
+ const double *a = a_;
+ const double *b = b_;
+ return *a > *b ? -1 : *a < *b;
+}
+
+static gsl_matrix *
+matrix_eval_EVAL (gsl_matrix *m)
+{
+ if (!is_symmetric (m))
+ {
+ msg (SE, _("Argument of EVAL must be symmetric."));
+ return NULL;
+ }
+
+ gsl_eigen_symm_workspace *w = gsl_eigen_symm_alloc (m->size1);
+ gsl_matrix *eval = gsl_matrix_alloc (m->size1, 1);
+ gsl_vector v_eval = to_vector (eval);
+ gsl_eigen_symm (m, &v_eval, w);
+ gsl_eigen_symm_free (w);
+
+ assert (v_eval.stride == 1);
+ qsort (v_eval.data, v_eval.size, sizeof *v_eval.data, compare_double_desc);
+
+ return eval;
+}
+
+static gsl_matrix *
+matrix_eval_EXP (gsl_matrix *m)
+{
+ MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
+ *d = exp (*d);
+ return m;
+}
+
+/* From https://gist.github.com/turingbirds/5e99656e08dbe1324c99, where it was
+ marked as:
+
+ Charl Linssen <charl@itfromb.it>
+ Feb 2016
+ PUBLIC DOMAIN */
+static gsl_matrix *
+matrix_eval_GINV (gsl_matrix *A)
+{
+ size_t n = A->size1;
+ size_t m = A->size2;
+ bool swap = m > n;
+ gsl_matrix *tmp_mat = NULL;
+ if (swap)
+ {
+ /* libgsl SVD can only handle the case m <= n, so transpose matrix. */
+ tmp_mat = gsl_matrix_alloc (m, n);
+ gsl_matrix_transpose_memcpy (tmp_mat, A);
+ A = tmp_mat;
+ size_t i = m;
+ m = n;
+ n = i;
+ }
+
+ /* Do SVD. */
+ gsl_matrix *V = gsl_matrix_alloc (m, m);
+ gsl_vector *u = gsl_vector_alloc (m);
+
+ gsl_vector *tmp_vec = gsl_vector_alloc (m);
+ gsl_linalg_SV_decomp (A, V, u, tmp_vec);
+ gsl_vector_free (tmp_vec);
+
+ /* Compute Σ⁻¹. */
+ gsl_matrix *Sigma_pinv = gsl_matrix_alloc (m, n);
+ gsl_matrix_set_zero (Sigma_pinv);
+ double cutoff = 1e-15 * gsl_vector_max (u);
+
+ for (size_t i = 0; i < m; ++i)
+ {
+ double x = gsl_vector_get (u, i);
+ gsl_matrix_set (Sigma_pinv, i, i, x > cutoff ? 1.0 / x : 0);
+ }
+
+ /* libgsl SVD yields "thin" SVD - pad to full matrix by adding zeros */
+ gsl_matrix *U = gsl_matrix_calloc (n, n);
+ for (size_t i = 0; i < n; i++)
+ for (size_t j = 0; j < m; j++)
+ gsl_matrix_set (U, i, j, gsl_matrix_get (A, i, j));
+
+ /* two dot products to obtain pseudoinverse */
+ tmp_mat = gsl_matrix_alloc (m, n);
+ gsl_blas_dgemm (CblasNoTrans, CblasNoTrans, 1., V, Sigma_pinv, 0., tmp_mat);
+
+ gsl_matrix *A_pinv;
+ if (swap)
+ {
+ A_pinv = gsl_matrix_alloc (n, m);
+ gsl_blas_dgemm (CblasNoTrans, CblasTrans, 1., U, tmp_mat, 0., A_pinv);
+ }
+ else
+ {
+ A_pinv = gsl_matrix_alloc (m, n);
+ gsl_blas_dgemm (CblasNoTrans, CblasTrans, 1., tmp_mat, U, 0., A_pinv);
+ }
+
+ gsl_matrix_free (tmp_mat);
+ gsl_matrix_free (U);
+ gsl_matrix_free (Sigma_pinv);
+ gsl_vector_free (u);
+ gsl_matrix_free (V);
+
+ return A_pinv;
+}
+
+struct grade
+ {
+ size_t y, x;
+ double value;
+ };
+
+static int
+grade_compare_3way (const void *a_, const void *b_)
+{
+ const struct grade *a = a_;
+ const struct grade *b = b_;
+
+ return (a->value < b->value ? -1
+ : a->value > b->value ? 1
+ : a->y < b->y ? -1
+ : a->y > b->y ? 1
+ : a->x < b->x ? -1
+ : a->x > b->x);
+}
+
+static gsl_matrix *
+matrix_eval_GRADE (gsl_matrix *m)
+{
+ size_t n = m->size1 * m->size2;
+ struct grade *grades = xmalloc (n * sizeof *grades);
+
+ size_t i = 0;
+ MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
+ grades[i++] = (struct grade) { .y = y, .x = x, .value = *d };
+ qsort (grades, n, sizeof *grades, grade_compare_3way);
+
+ for (size_t i = 0; i < n; i++)
+ gsl_matrix_set (m, grades[i].y, grades[i].x, i + 1);
+
+ free (grades);
+
+ return m;
+}
+
+static double
+dot (gsl_vector *a, gsl_vector *b)
+{
+ double result = 0.0;
+ for (size_t i = 0; i < a->size; i++)
+ result += gsl_vector_get (a, i) * gsl_vector_get (b, i);
+ return result;
+}
+
+static double
+norm2 (gsl_vector *v)
+{
+ double result = 0.0;
+ for (size_t i = 0; i < v->size; i++)
+ result += pow2 (gsl_vector_get (v, i));
+ return result;
+}
+
+static double
+norm (gsl_vector *v)
+{
+ return sqrt (norm2 (v));
+}
+
+static gsl_matrix *
+matrix_eval_GSCH (gsl_matrix *v)
+{
+ if (v->size2 < v->size1)
+ {
+ msg (SE, _("GSCH requires its argument to have at least as many columns "
+ "as rows, but it has dimensions (%zu,%zu)."),
+ v->size1, v->size2);
+ return NULL;
+ }
+ if (!v->size1 || !v->size2)
+ return v;
+
+ gsl_matrix *u = gsl_matrix_calloc (v->size1, v->size2);
+ size_t ux = 0;
+ for (size_t vx = 0; vx < v->size2; vx++)
+ {
+ gsl_vector u_i = gsl_matrix_column (u, ux).vector;
+ gsl_vector v_i = gsl_matrix_column (v, vx).vector;
+
+ gsl_vector_memcpy (&u_i, &v_i);
+ for (size_t j = 0; j < ux; j++)
+ {
+ gsl_vector u_j = gsl_matrix_column (u, j).vector;
+ double scale = dot (&u_j, &u_i) / norm2 (&u_j);
+ for (size_t k = 0; k < u_i.size; k++)
+ gsl_vector_set (&u_i, k, (gsl_vector_get (&u_i, k)
+ - scale * gsl_vector_get (&u_j, k)));
+ }
+
+ double len = norm (&u_i);
+ if (len > 1e-15)
+ {
+ gsl_vector_scale (&u_i, 1.0 / len);
+ if (++ux >= v->size1)
+ break;
+ }
+ }
+
+ if (ux < v->size1)
+ {
+ msg (SE, _("Argument to GSCH with dimensions (%zu,%zu) contains only "
+ "%zu linearly independent columns."),
+ v->size1, v->size2, ux);
+ return NULL;
+ }
+
+ u->size2 = v->size1;
+ return u;
+}
+
+static gsl_matrix *
+matrix_eval_IDENT (double s1, double s2)
+{
+ if (s1 < 0 || s1 > SIZE_MAX || s2 < 0 || s2 > SIZE_MAX)
+ {
+ msg (SE, _("Arguments to IDENT must be non-negative integers."));
+ return NULL;
+ }
+
+ gsl_matrix *m = gsl_matrix_alloc (s1, s2);
+ MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
+ *d = x == y;
+ return m;
+}
+
+static void
+invert_matrix (gsl_matrix *x)
+{
+ gsl_permutation *p = gsl_permutation_alloc (x->size1);
+ int signum;
+ gsl_linalg_LU_decomp (x, p, &signum);
+ gsl_linalg_LU_invx (x, p);
+ gsl_permutation_free (p);
+}
+
+static gsl_matrix *
+matrix_eval_INV (gsl_matrix *m)
+{
+ invert_matrix (m);
+ return m;
+}
+
+static gsl_matrix *
+matrix_eval_KRONEKER (gsl_matrix *a, gsl_matrix *b)
+{
+ gsl_matrix *k = gsl_matrix_alloc (a->size1 * b->size1,
+ a->size2 * b->size2);
+ size_t y = 0;
+ for (size_t ar = 0; ar < a->size1; ar++)
+ for (size_t br = 0; br < b->size1; br++, y++)
+ {
+ size_t x = 0;
+ for (size_t ac = 0; ac < a->size2; ac++)
+ for (size_t bc = 0; bc < b->size2; bc++, x++)
+ {
+ double av = gsl_matrix_get (a, ar, ac);
+ double bv = gsl_matrix_get (b, br, bc);
+ gsl_matrix_set (k, y, x, av * bv);
+ }
+ }
+ return k;
+}
+
+static gsl_matrix *
+matrix_eval_LG10 (gsl_matrix *m)
+{
+ MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
+ *d = log10 (*d);
+ return m;
+}
+
+static gsl_matrix *
+matrix_eval_LN (gsl_matrix *m)
+{
+ MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
+ *d = log (*d);
+ return m;
+}
+
+static void
+matrix_eval_MAGIC_odd (gsl_matrix *m, size_t n)
+{
+ /* Siamese method: https://en.wikipedia.org/wiki/Siamese_method. */
+ size_t y = 0;
+ size_t x = n / 2;
+ for (size_t i = 1; i <= n * n; i++)
+ {
+ gsl_matrix_set (m, y, x, i);
+
+ size_t y1 = !y ? n - 1 : y - 1;
+ size_t x1 = x + 1 >= n ? 0 : x + 1;
+ if (gsl_matrix_get (m, y1, x1) == 0)
+ {
+ y = y1;
+ x = x1;
+ }
+ else
+ y = y + 1 >= n ? 0 : y + 1;
+ }
+}
+
+static void
+magic_exchange (gsl_matrix *m, size_t y1, size_t x1, size_t y2, size_t x2)
+{
+ double a = gsl_matrix_get (m, y1, x1);
+ double b = gsl_matrix_get (m, y2, x2);
+ gsl_matrix_set (m, y1, x1, b);
+ gsl_matrix_set (m, y2, x2, a);
+}
+
+static void
+matrix_eval_MAGIC_doubly_even (gsl_matrix *m, size_t n)
+{
+ size_t x, y;
+
+ /* A. Umar, "On the Construction of Even Order Magic Squares",
+ https://arxiv.org/ftp/arxiv/papers/1202/1202.0948.pdf. */
+ x = y = 0;
+ for (size_t i = 1; i <= n * n / 2; i++)
+ {
+ gsl_matrix_set (m, y, x, i);
+ if (++y >= n)
+ {
+ y = 0;
+ x++;
+ }
+ }
+
+ x = n - 1;
+ y = 0;
+ for (size_t i = n * n; i > n * n / 2; i--)
+ {
+ gsl_matrix_set (m, y, x, i);
+ if (++y >= n)
+ {
+ y = 0;
+ x--;
+ }
+ }
+
+ for (size_t y = 0; y < n; y++)
+ for (size_t x = 0; x < n / 2; x++)
+ {
+ unsigned int d = gsl_matrix_get (m, y, x);
+ if (d % 2 != (y < n / 2))
+ magic_exchange (m, y, x, y, n - x - 1);
+ }
+
+ size_t y1 = n / 2;
+ size_t y2 = n - 1;
+ size_t x1 = n / 2 - 1;
+ size_t x2 = n / 2;
+ magic_exchange (m, y1, x1, y2, x1);
+ magic_exchange (m, y1, x2, y2, x2);
+}
+
+static void
+matrix_eval_MAGIC_singly_even (gsl_matrix *m, size_t n)
+{
+ /* A. Umar, "On the Construction of Even Order Magic Squares",
+ https://arxiv.org/ftp/arxiv/papers/1202/1202.0948.pdf. */
+ size_t x, y;
+
+ x = y = 0;
+ for (size_t i = 1; ; i++)
+ {
+ gsl_matrix_set (m, y, x, i);
+ if (++y == n / 2 - 1)
+ y += 2;
+ else if (y >= n)
+ {
+ y = 0;
+ if (++x >= n / 2)
+ break;
+ }
+ }
+
+ x = n - 1;
+ y = 0;
+ for (size_t i = n * n; ; i--)
+ {
+ gsl_matrix_set (m, y, x, i);
+ if (++y == n / 2 - 1)
+ y += 2;
+ else if (y >= n)
+ {
+ y = 0;
+ if (--x < n / 2)
+ break;
+ }
+ }
+ for (size_t y = 0; y < n; y++)
+ if (y != n / 2 - 1 && y != n / 2)
+ for (size_t x = 0; x < n / 2; x++)
+ {
+ unsigned int d = gsl_matrix_get (m, y, x);
+ if (d % 2 != (y < n / 2))
+ magic_exchange (m, y, x, y, n - x - 1);
+ }
+
+ size_t a0 = (n * n - 2 * n) / 2 + 1;
+ for (size_t i = 0; i < n / 2; i++)
+ {
+ size_t a = a0 + i;
+ gsl_matrix_set (m, n / 2, i, a);
+ gsl_matrix_set (m, n / 2 - 1, i, (n * n + 1) - a);
+ }
+ for (size_t i = 0; i < n / 2; i++)
+ {
+ size_t a = a0 + i + n / 2;
+ gsl_matrix_set (m, n / 2 - 1, n - i - 1, a);
+ gsl_matrix_set (m, n / 2, n - i - 1, (n * n + 1) - a);
+ }
+ for (size_t x = 1; x < n / 2; x += 2)
+ magic_exchange (m, n / 2, x, n / 2 - 1, x);
+ for (size_t x = n / 2 + 2; x <= n - 3; x += 2)
+ magic_exchange (m, n / 2, x, n / 2 - 1, x);
+ size_t x1 = n / 2 - 2;
+ size_t x2 = n / 2 + 1;
+ size_t y1 = n / 2 - 2;
+ size_t y2 = n / 2 + 1;
+ magic_exchange (m, y1, x1, y2, x1);
+ magic_exchange (m, y1, x2, y2, x2);
+}
+
+static gsl_matrix *
+matrix_eval_MAGIC (double n_)
+{
+ if (n_ < 3 || n_ >= sqrt (SIZE_MAX))
+ {
+ msg (SE, _("MAGIC argument must be an integer 3 or greater."));
+ return NULL;
+ }
+ size_t n = n_;
+
+ gsl_matrix *m = gsl_matrix_calloc (n, n);
+ if (n % 2)
+ matrix_eval_MAGIC_odd (m, n);
+ else if (n % 4)
+ matrix_eval_MAGIC_singly_even (m, n);
+ else
+ matrix_eval_MAGIC_doubly_even (m, n);
+ return m;
+}
+
+static gsl_matrix *
+matrix_eval_MAKE (double r, double c, double value)
+{
+ if (r < 0 || r >= SIZE_MAX || c < 0 || c >= SIZE_MAX)
+ {
+ msg (SE, _("Size arguments to MAKE must be integers."));
+ return NULL;
+ }
+
+ gsl_matrix *m = gsl_matrix_alloc (r, c);
+ MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
+ *d = value;
+ return m;
+}
+
+static gsl_matrix *
+matrix_eval_MDIAG (gsl_vector *v)
+{
+ gsl_matrix *m = gsl_matrix_alloc (v->size, v->size);
+ gsl_vector diagonal = gsl_matrix_diagonal (m).vector;
+ gsl_vector_memcpy (&diagonal, v);
+ return m;
+}
+
+static double
+matrix_eval_MMAX (gsl_matrix *m)
+{
+ return gsl_matrix_max (m);
+}
+
+static double
+matrix_eval_MMIN (gsl_matrix *m)
+{
+ return gsl_matrix_min (m);
+}
+
+static gsl_matrix *
+matrix_eval_MOD (gsl_matrix *m, double divisor)
+{
+ if (divisor == 0.0)
+ {
+ msg (SE, _("Divisor argument to MOD function must be nonzero."));
+ return NULL;
+ }
+
+ MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
+ *d = fmod (*d, divisor);
+ return m;
+}
+
+static double
+matrix_eval_MSSQ (gsl_matrix *m)
+{
+ double mssq = 0.0;
+ MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
+ mssq += *d * *d;
+ return mssq;
+}
+
+static double
+matrix_eval_MSUM (gsl_matrix *m)
+{
+ double msum = 0.0;
+ MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
+ msum += *d;
+ return msum;
+}
+
+static double
+matrix_eval_NCOL (gsl_matrix *m)
+{
+ return m->size2;
+}
+
+static double
+matrix_eval_NROW (gsl_matrix *m)
+{
+ return m->size1;
+}
+
+static double
+matrix_eval_RANK (gsl_matrix *m)
+{
+ gsl_vector *tau = gsl_vector_alloc (MIN (m->size1, m->size2));
+ gsl_linalg_QR_decomp (m, tau);
+ gsl_vector_free (tau);
+
+ return gsl_linalg_QRPT_rank (m, -1);
+}
+
+static gsl_matrix *
+matrix_eval_RESHAPE (gsl_matrix *m, double r_, double c_)
+{
+ if (r_ < 0 || r_ >= SIZE_MAX || c_ < 0 || c_ >= SIZE_MAX)
+ {
+ msg (SE, _("Arguments 2 and 3 to RESHAPE must be integers."));
+ return NULL;
+ }
+ size_t r = r_;
+ size_t c = c_;
+ if (size_overflow_p (xtimes (r, xmax (c, 1))) || c * r != m->size1 * m->size2)
+ {
+ msg (SE, _("Product of RESHAPE arguments 2 and 3 differ from "
+ "product of matrix dimensions."));
+ return NULL;
+ }
+
+ gsl_matrix *dst = gsl_matrix_alloc (r, c);
+ size_t y1 = 0;
+ size_t x1 = 0;
+ MATRIX_FOR_ALL_ELEMENTS (d, y2, x2, m)
+ {
+ gsl_matrix_set (dst, y1, x1, *d);
+ if (++x1 >= c)
+ {
+ x1 = 0;
+ y1++;
+ }
+ }
+ return dst;
+}
+
+static gsl_matrix *
+matrix_eval_row_extremum (gsl_matrix *m, bool min)
+{
+ if (m->size2 <= 1)
+ return m;
+ else if (!m->size1)
+ return gsl_matrix_alloc (0, 1);
+
+ gsl_matrix *rext = gsl_matrix_alloc (m->size1, 1);
+ for (size_t y = 0; y < m->size1; y++)
+ {
+ double ext = gsl_matrix_get (m, y, 0);
+ for (size_t x = 1; x < m->size2; x++)
+ {
+ double value = gsl_matrix_get (m, y, x);
+ if (min ? value < ext : value > ext)
+ ext = value;
+ }
+ gsl_matrix_set (rext, y, 0, ext);
+ }
+ return rext;
+}
+
+static gsl_matrix *
+matrix_eval_RMAX (gsl_matrix *m)
+{
+ return matrix_eval_row_extremum (m, false);
+}
+
+static gsl_matrix *
+matrix_eval_RMIN (gsl_matrix *m)
+{
+ return matrix_eval_row_extremum (m, true);
+}
+
+static gsl_matrix *
+matrix_eval_RND (gsl_matrix *m)
+{
+ MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
+ *d = rint (*d);
+ return m;
+}
+
+struct rank
+ {
+ size_t y, x;
+ double value;
+ };
+
+static int
+rank_compare_3way (const void *a_, const void *b_)
+{
+ const struct rank *a = a_;
+ const struct rank *b = b_;
+
+ return a->value < b->value ? -1 : a->value > b->value;
+}
+
+static gsl_matrix *
+matrix_eval_RNKORDER (gsl_matrix *m)
+{
+ size_t n = m->size1 * m->size2;
+ struct rank *ranks = xmalloc (n * sizeof *ranks);
+ size_t i = 0;
+ MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
+ ranks[i++] = (struct rank) { .y = y, .x = x, .value = *d };
+ qsort (ranks, n, sizeof *ranks, rank_compare_3way);
+
+ for (size_t i = 0; i < n; )
+ {
+ size_t j;
+ for (j = i + 1; j < n; j++)
+ if (ranks[i].value != ranks[j].value)
+ break;
+
+ double rank = (i + j + 1.0) / 2.0;
+ for (size_t k = i; k < j; k++)
+ gsl_matrix_set (m, ranks[k].y, ranks[k].x, rank);
+
+ i = j;
+ }
+
+ free (ranks);
+
+ return m;
+}
+
+static gsl_matrix *
+matrix_eval_row_sum (gsl_matrix *m, bool square)
+{
+ if (m->size1 == 0)
+ return m;
+ else if (!m->size1)
+ return gsl_matrix_alloc (0, 1);
+
+ gsl_matrix *result = gsl_matrix_alloc (m->size1, 1);
+ for (size_t y = 0; y < m->size1; y++)
+ {
+ double sum = 0;
+ for (size_t x = 0; x < m->size2; x++)
+ {
+ double d = gsl_matrix_get (m, y, x);
+ sum += square ? pow2 (d) : d;
+ }
+ gsl_matrix_set (result, y, 0, sum);
+ }
+ return result;
+}
+
+static gsl_matrix *
+matrix_eval_RSSQ (gsl_matrix *m)
+{
+ return matrix_eval_row_sum (m, true);
+}
+
+static gsl_matrix *
+matrix_eval_RSUM (gsl_matrix *m)
+{
+ return matrix_eval_row_sum (m, false);
+}
+
+static gsl_matrix *
+matrix_eval_SIN (gsl_matrix *m)
+{
+ MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
+ *d = sin (*d);
+ return m;
+}
+
+static gsl_matrix *
+matrix_eval_SOLVE (gsl_matrix *m1, gsl_matrix *m2)
+{
+ if (m1->size1 != m2->size1)
+ {
+ msg (SE, _("SOLVE requires its arguments to have the same number of "
+ "rows, but the first argument has dimensions (%zu,%zu) and "
+ "the second (%zu,%zu)."),
+ m1->size1, m1->size2,
+ m2->size1, m2->size2);
+ return NULL;
+ }
+
+ gsl_matrix *x = gsl_matrix_alloc (m2->size1, m2->size2);
+ gsl_permutation *p = gsl_permutation_alloc (m1->size1);
+ int signum;
+ gsl_linalg_LU_decomp (m1, p, &signum);
+ for (size_t i = 0; i < m2->size2; i++)
+ {
+ gsl_vector bi = gsl_matrix_column (m2, i).vector;
+ gsl_vector xi = gsl_matrix_column (x, i).vector;
+ gsl_linalg_LU_solve (m1, p, &bi, &xi);
+ }
+ gsl_permutation_free (p);
+ return x;
+}
+
+static gsl_matrix *
+matrix_eval_SQRT (gsl_matrix *m)
+{
+ MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
+ {
+ if (*d < 0)
+ {
+ msg (SE, _("Argument to SQRT must be nonnegative."));
+ return NULL;
+ }
+ *d = sqrt (*d);
+ }
+ return m;
+}
+
+static gsl_matrix *
+matrix_eval_SSCP (gsl_matrix *m)
+{
+ gsl_matrix *sscp = gsl_matrix_alloc (m->size2, m->size2);
+ gsl_blas_dgemm (CblasTrans, CblasNoTrans, 1.0, m, m, 0.0, sscp);
+ return sscp;
+}
+
+static gsl_matrix *
+matrix_eval_SVAL (gsl_matrix *m)
+{
+ gsl_matrix *tmp_mat = NULL;
+ if (m->size2 > m->size1)
+ {
+ tmp_mat = gsl_matrix_alloc (m->size2, m->size1);
+ gsl_matrix_transpose_memcpy (tmp_mat, m);
+ m = tmp_mat;
+ }
+
+ /* Do SVD. */
+ gsl_matrix *V = gsl_matrix_alloc (m->size2, m->size2);
+ gsl_vector *S = gsl_vector_alloc (m->size2);
+ gsl_vector *work = gsl_vector_alloc (m->size2);
+ gsl_linalg_SV_decomp (m, V, S, work);
+
+ gsl_matrix *vals = gsl_matrix_alloc (m->size2, 1);
+ for (size_t i = 0; i < m->size2; i++)
+ gsl_matrix_set (vals, i, 0, gsl_vector_get (S, i));
+
+ gsl_matrix_free (V);
+ gsl_vector_free (S);
+ gsl_vector_free (work);
+ gsl_matrix_free (tmp_mat);
+
+ return vals;
+}
+
+static gsl_matrix *
+matrix_eval_SWEEP (gsl_matrix *m, double d)
+{
+ if (d < 1 || d > SIZE_MAX)
+ {
+ msg (SE, _("Scalar argument to SWEEP must be integer."));
+ return NULL;
+ }
+ size_t k = d - 1;
+ if (k >= MIN (m->size1, m->size2))
+ {
+ msg (SE, _("Scalar argument to SWEEP must be integer less than or "
+ "equal to the smaller of the matrix argument's rows and "
+ "columns."));
+ return NULL;
+ }
+
+ double m_kk = gsl_matrix_get (m, k, k);
+ if (fabs (m_kk) > 1e-19)
+ {
+ gsl_matrix *a = gsl_matrix_alloc (m->size1, m->size2);
+ MATRIX_FOR_ALL_ELEMENTS (a_ij, i, j, a)
+ {
+ double m_ij = gsl_matrix_get (m, i, j);
+ double m_ik = gsl_matrix_get (m, i, k);
+ double m_kj = gsl_matrix_get (m, k, j);
+ *a_ij = (i != k && j != k ? m_ij * m_kk - m_ik * m_kj
+ : i != k ? -m_ik
+ : j != k ? m_kj
+ : 1.0) / m_kk;
+ }
+ return a;
+ }
+ else
+ {
+ for (size_t i = 0; i < m->size1; i++)
+ {
+ gsl_matrix_set (m, i, k, 0);
+ gsl_matrix_set (m, k, i, 0);
+ }
+ return m;
+ }
+}
+
+static double
+matrix_eval_TRACE (gsl_matrix *m)
+{
+ double sum = 0;
+ size_t n = MIN (m->size1, m->size2);
+ for (size_t i = 0; i < n; i++)
+ sum += gsl_matrix_get (m, i, i);
+ return sum;
+}
+
+static gsl_matrix *
+matrix_eval_T (gsl_matrix *m)
+{
+ return matrix_eval_TRANSPOS (m);
+}
+
+static gsl_matrix *
+matrix_eval_TRANSPOS (gsl_matrix *m)
+{
+ if (m->size1 == m->size2)
+ {
+ gsl_matrix_transpose (m);
+ return m;
+ }
+ else
+ {
+ gsl_matrix *t = gsl_matrix_alloc (m->size2, m->size1);
+ gsl_matrix_transpose_memcpy (t, m);
+ return t;
+ }
+}
+
+static gsl_matrix *
+matrix_eval_TRUNC (gsl_matrix *m)
+{
+ MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
+ *d = trunc (*d);
+ return m;
+}
+
+static gsl_matrix *
+matrix_eval_UNIFORM (double r_, double c_)
+{
+ if (r_ < 0 || r_ >= SIZE_MAX || c_ < 0 || c_ >= SIZE_MAX)
+ {
+ msg (SE, _("Arguments to UNIFORM must be integers."));
+ return NULL;
+ }
+ size_t r = r_;
+ size_t c = c_;
+ if (size_overflow_p (xtimes (r, xmax (c, 1))))
+ {
+ msg (SE, _("Product of arguments to UNIFORM exceeds memory size."));
+ return NULL;
+ }
+
+ gsl_matrix *m = gsl_matrix_alloc (r, c);
+ MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
+ *d = gsl_ran_flat (get_rng (), 0, 1);
+ return m;
+}
+
+struct matrix_function
+ {
+ const char *name;
+ enum matrix_op op;
+ size_t min_args, max_args;
+ };
+
+static struct matrix_expr *matrix_parse_expr (struct matrix_state *);
+
+static const struct matrix_function *
+matrix_parse_function_name (const char *token)
+{
+ static const struct matrix_function functions[] =
+ {
+#define F(NAME, PROTO) { #NAME, MOP_F_##NAME, PROTO##_MIN_ARGS, PROTO##_MAX_ARGS },
+ MATRIX_FUNCTIONS
+#undef F
+ };
+ enum { N_FUNCTIONS = sizeof functions / sizeof *functions };
+
+ for (size_t i = 0; i < N_FUNCTIONS; i++)
+ {
+ if (lex_id_match_n (ss_cstr (functions[i].name), ss_cstr (token), 3))
+ return &functions[i];
+ }
+ return NULL;
+}
+
+static struct read_file *
+read_file_create (struct matrix_state *s, struct file_handle *fh)
+{
+ for (size_t i = 0; i < s->n_read_files; i++)
+ {
+ struct read_file *rf = s->read_files[i];
+ if (rf->file == fh)
+ {
+ fh_unref (fh);
+ return rf;
+ }
+ }
+
+ struct read_file *rf = xmalloc (sizeof *rf);
+ *rf = (struct read_file) { .file = fh };
+
+ s->read_files = xrealloc (s->read_files,
+ (s->n_read_files + 1) * sizeof *s->read_files);
+ s->read_files[s->n_read_files++] = rf;
+ return rf;
+}
+
+static struct dfm_reader *
+read_file_open (struct read_file *rf)
+{
+ if (!rf->reader)
+ rf->reader = dfm_open_reader (rf->file, NULL, rf->encoding);
+ return rf->reader;
+}
+
+static bool
+matrix_parse_function (struct matrix_state *s, const char *token,
+ struct matrix_expr **exprp)
+{
+ *exprp = NULL;
+ if (lex_next_token (s->lexer, 1) != T_LPAREN)
+ return false;
+
+ if (lex_match_id (s->lexer, "EOF"))
+ {
+ lex_get (s->lexer);
+ struct file_handle *fh = fh_parse (s->lexer, FH_REF_FILE, s->session);
+ if (!fh)
+ return true;
+
+ if (!lex_force_match (s->lexer, T_RPAREN))
+ {
+ fh_unref (fh);
+ return true;
+ }
+
+ struct read_file *rf = read_file_create (s, fh);
+
+ struct matrix_expr *e = xmalloc (sizeof *e);
+ *e = (struct matrix_expr) { .op = MOP_EOF, .eof = rf };
+ *exprp = e;
+ return true;
+ }
+
+ const struct matrix_function *f = matrix_parse_function_name (token);
+ if (!f)
+ return false;
+
+ lex_get_n (s->lexer, 2);
+
+ struct matrix_expr *e = xmalloc (sizeof *e);
+ *e = (struct matrix_expr) { .op = f->op, .subs = NULL };
+
+ size_t allocated_subs = 0;
+ do
+ {
+ struct matrix_expr *sub = matrix_parse_expr (s);
+ if (!sub)
+ goto error;
+
+ if (e->n_subs >= allocated_subs)
+ e->subs = x2nrealloc (e->subs, &allocated_subs, sizeof *e->subs);
+ e->subs[e->n_subs++] = sub;
+ }
+ while (lex_match (s->lexer, T_COMMA));
+ if (!lex_force_match (s->lexer, T_RPAREN))
+ goto error;
+
+ *exprp = e;
+ return true;
+
+error:
+ matrix_expr_destroy (e);
+ return true;
+}
+
+static struct matrix_expr *
+matrix_parse_primary (struct matrix_state *s)
+{
+ if (lex_is_number (s->lexer))
+ {
+ double number = lex_number (s->lexer);
+ lex_get (s->lexer);
+ return matrix_expr_create_number (number);
+ }
+ else if (lex_is_string (s->lexer))
+ {
+ char string[sizeof (double)];
+ buf_copy_str_rpad (string, sizeof string, lex_tokcstr (s->lexer), ' ');
+ lex_get (s->lexer);
+
+ double number;
+ memcpy (&number, string, sizeof number);
+ return matrix_expr_create_number (number);
+ }
+ else if (lex_match (s->lexer, T_LPAREN))
+ {
+ struct matrix_expr *e = matrix_parse_or_xor (s);
+ if (!e || !lex_force_match (s->lexer, T_RPAREN))
+ {
+ matrix_expr_destroy (e);
+ return NULL;
+ }
+ return e;
+ }
+ else if (lex_match (s->lexer, T_LCURLY))
+ {
+ struct matrix_expr *e = matrix_parse_curly_semi (s);
+ if (!e || !lex_force_match (s->lexer, T_RCURLY))
+ {
+ matrix_expr_destroy (e);
+ return NULL;
+ }
+ return e;
+ }
+ else if (lex_token (s->lexer) == T_ID)
+ {
+ struct matrix_expr *retval;
+ if (matrix_parse_function (s, lex_tokcstr (s->lexer), &retval))
+ return retval;
+
+ struct matrix_var *var = matrix_var_lookup (s, lex_tokss (s->lexer));
+ if (!var)
+ {
+ lex_error (s->lexer, _("Unknown variable %s."),
+ lex_tokcstr (s->lexer));
+ return NULL;
+ }
+ lex_get (s->lexer);
+
+ struct matrix_expr *e = xmalloc (sizeof *e);
+ *e = (struct matrix_expr) { .op = MOP_VARIABLE, .variable = var };
+ return e;
+ }
+ else if (lex_token (s->lexer) == T_ALL)
+ {
+ struct matrix_expr *retval;
+ if (matrix_parse_function (s, "ALL", &retval))
+ return retval;
+ }
+
+ lex_error (s->lexer, NULL);
+ return NULL;
+}
+
+static struct matrix_expr *matrix_parse_postfix (struct matrix_state *);
+
+static bool
+matrix_parse_index_expr (struct matrix_state *s, struct matrix_expr **indexp)
+{
+ if (lex_match (s->lexer, T_COLON))
+ {
+ *indexp = NULL;
+ return true;
+ }
+ else
+ {
+ *indexp = matrix_parse_expr (s);
+ return *indexp != NULL;
+ }
+}
+
+static struct matrix_expr *
+matrix_parse_postfix (struct matrix_state *s)
+{
+ struct matrix_expr *lhs = matrix_parse_primary (s);
+ if (!lhs || !lex_match (s->lexer, T_LPAREN))
+ return lhs;
+
+ struct matrix_expr *i0;
+ if (!matrix_parse_index_expr (s, &i0))
+ {
+ matrix_expr_destroy (lhs);
+ return NULL;
+ }
+ if (lex_match (s->lexer, T_RPAREN))
+ return (i0
+ ? matrix_expr_create_2 (MOP_VEC_INDEX, lhs, i0)
+ : matrix_expr_create_1 (MOP_VEC_ALL, lhs));
+ else if (lex_match (s->lexer, T_COMMA))
+ {
+ struct matrix_expr *i1;
+ if (!matrix_parse_index_expr (s, &i1)
+ || !lex_force_match (s->lexer, T_RPAREN))
+ {
+ matrix_expr_destroy (lhs);
+ matrix_expr_destroy (i0);
+ matrix_expr_destroy (i1);
+ return NULL;
+ }
+ return (i0 && i1 ? matrix_expr_create_3 (MOP_MAT_INDEX, lhs, i0, i1)
+ : i0 ? matrix_expr_create_2 (MOP_ROW_INDEX, lhs, i0)
+ : i1 ? matrix_expr_create_2 (MOP_COL_INDEX, lhs, i1)
+ : lhs);
+ }
+ else
+ {
+ lex_error_expecting (s->lexer, "`)'", "`,'");
+ return NULL;
+ }
+}
+
+static struct matrix_expr *
+matrix_parse_unary (struct matrix_state *s)
+{
+ if (lex_match (s->lexer, T_DASH))
+ {
+ struct matrix_expr *lhs = matrix_parse_unary (s);
+ return lhs ? matrix_expr_create_1 (MOP_NEGATE, lhs) : NULL;
+ }
+ else if (lex_match (s->lexer, T_PLUS))
+ return matrix_parse_unary (s);
+ else
+ return matrix_parse_postfix (s);
+}
+
+static struct matrix_expr *
+matrix_parse_seq (struct matrix_state *s)
+{
+ struct matrix_expr *start = matrix_parse_unary (s);
+ if (!start || !lex_match (s->lexer, T_COLON))
+ return start;
+
+ struct matrix_expr *end = matrix_parse_unary (s);
+ if (!end)
+ {
+ matrix_expr_destroy (start);
+ return NULL;
+ }
+
+ if (lex_match (s->lexer, T_COLON))
+ {
+ struct matrix_expr *increment = matrix_parse_unary (s);
+ if (!increment)
+ {
+ matrix_expr_destroy (start);
+ matrix_expr_destroy (end);
+ return NULL;
+ }
+ return matrix_expr_create_3 (MOP_SEQ_BY, start, end, increment);
+ }
+ else
+ return matrix_expr_create_2 (MOP_SEQ, start, end);
+}
+
+static struct matrix_expr *
+matrix_parse_exp (struct matrix_state *s)
+{
+ struct matrix_expr *lhs = matrix_parse_seq (s);
+ if (!lhs)
+ return NULL;
+
+ for (;;)
+ {
+ enum matrix_op op;
+ if (lex_match (s->lexer, T_EXP))
+ op = MOP_EXP_MAT;
+ else if (lex_match_phrase (s->lexer, "&**"))
+ op = MOP_EXP_ELEMS;
+ else
+ return lhs;
+
+ struct matrix_expr *rhs = matrix_parse_seq (s);
+ if (!rhs)
+ {
+ matrix_expr_destroy (lhs);
+ return NULL;
+ }
+ lhs = matrix_expr_create_2 (op, lhs, rhs);
+ }
+}
+
+static struct matrix_expr *
+matrix_parse_mul_div (struct matrix_state *s)
+{
+ struct matrix_expr *lhs = matrix_parse_exp (s);
+ if (!lhs)
+ return NULL;
+
+ for (;;)
+ {
+ enum matrix_op op;
+ if (lex_match (s->lexer, T_ASTERISK))
+ op = MOP_MUL_MAT;
+ else if (lex_match (s->lexer, T_SLASH))
+ op = MOP_DIV_ELEMS;
+ else if (lex_match_phrase (s->lexer, "&*"))
+ op = MOP_MUL_ELEMS;
+ else if (lex_match_phrase (s->lexer, "&/"))
+ op = MOP_DIV_ELEMS;
+ else
+ return lhs;
+
+ struct matrix_expr *rhs = matrix_parse_exp (s);
+ if (!rhs)
+ {
+ matrix_expr_destroy (lhs);
+ return NULL;
+ }
+ lhs = matrix_expr_create_2 (op, lhs, rhs);
+ }
+}
+
+static struct matrix_expr *
+matrix_parse_add_sub (struct matrix_state *s)
+{
+ struct matrix_expr *lhs = matrix_parse_mul_div (s);
+ if (!lhs)
+ return NULL;
+
+ for (;;)
+ {
+ enum matrix_op op;
+ if (lex_match (s->lexer, T_PLUS))
+ op = MOP_ADD_ELEMS;
+ else if (lex_match (s->lexer, T_DASH))
+ op = MOP_SUB_ELEMS;
+ else if (lex_token (s->lexer) == T_NEG_NUM)
+ op = MOP_ADD_ELEMS;
+ else
+ return lhs;
+
+ struct matrix_expr *rhs = matrix_parse_mul_div (s);
+ if (!rhs)
+ {
+ matrix_expr_destroy (lhs);
+ return NULL;
+ }
+ lhs = matrix_expr_create_2 (op, lhs, rhs);
+ }
+}
+
+static struct matrix_expr *
+matrix_parse_relational (struct matrix_state *s)
+{
+ struct matrix_expr *lhs = matrix_parse_add_sub (s);
+ if (!lhs)
+ return NULL;
+
+ for (;;)
+ {
+ enum matrix_op op;
+ if (lex_match (s->lexer, T_GT))
+ op = MOP_GT;
+ else if (lex_match (s->lexer, T_GE))
+ op = MOP_GE;
+ else if (lex_match (s->lexer, T_LT))
+ op = MOP_LT;
+ else if (lex_match (s->lexer, T_LE))
+ op = MOP_LE;
+ else if (lex_match (s->lexer, T_EQUALS) || lex_match (s->lexer, T_EQ))
+ op = MOP_EQ;
+ else if (lex_match (s->lexer, T_NE))
+ op = MOP_NE;
+ else
+ return lhs;
+
+ struct matrix_expr *rhs = matrix_parse_add_sub (s);
+ if (!rhs)
+ {
+ matrix_expr_destroy (lhs);
+ return NULL;
+ }
+ lhs = matrix_expr_create_2 (op, lhs, rhs);
+ }
+}
+
+static struct matrix_expr *
+matrix_parse_not (struct matrix_state *s)
+{
+ if (lex_match (s->lexer, T_NOT))
+ {
+ struct matrix_expr *lhs = matrix_parse_not (s);
+ return lhs ? matrix_expr_create_1 (MOP_NOT, lhs) : NULL;
+ }
+ else
+ return matrix_parse_relational (s);
+}
+
+static struct matrix_expr *
+matrix_parse_and (struct matrix_state *s)
+{
+ struct matrix_expr *lhs = matrix_parse_not (s);
+ if (!lhs)
+ return NULL;
+
+ while (lex_match (s->lexer, T_AND))
+ {
+ struct matrix_expr *rhs = matrix_parse_not (s);
+ if (!rhs)
+ {
+ matrix_expr_destroy (lhs);
+ return NULL;
+ }
+ lhs = matrix_expr_create_2 (MOP_AND, lhs, rhs);
+ }
+ return lhs;
+}
+
+static struct matrix_expr *
+matrix_parse_or_xor (struct matrix_state *s)
+{
+ struct matrix_expr *lhs = matrix_parse_and (s);
+ if (!lhs)
+ return NULL;
+
+ for (;;)
+ {
+ enum matrix_op op;
+ if (lex_match (s->lexer, T_OR))
+ op = MOP_OR;
+ else if (lex_match_id (s->lexer, "XOR"))
+ op = MOP_XOR;
+ else
+ return lhs;
+
+ struct matrix_expr *rhs = matrix_parse_and (s);
+ if (!rhs)
+ {
+ matrix_expr_destroy (lhs);
+ return NULL;
+ }
+ lhs = matrix_expr_create_2 (op, lhs, rhs);
+ }
+}
+
+static struct matrix_expr *
+matrix_parse_expr (struct matrix_state *s)
+{
+ return matrix_parse_or_xor (s);
+}
+\f
+/* Expression evaluation. */
+
+static double
+matrix_op_eval (enum matrix_op op, double a, double b)
+{
+ switch (op)
+ {
+ case MOP_ADD_ELEMS: return a + b;
+ case MOP_SUB_ELEMS: return a - b;
+ case MOP_MUL_ELEMS: return a * b;
+ case MOP_DIV_ELEMS: return a / b;
+ case MOP_EXP_ELEMS: return pow (a, b);
+ case MOP_GT: return a > b;
+ case MOP_GE: return a >= b;
+ case MOP_LT: return a < b;
+ case MOP_LE: return a <= b;
+ case MOP_EQ: return a == b;
+ case MOP_NE: return a != b;
+ case MOP_AND: return (a > 0) && (b > 0);
+ case MOP_OR: return (a > 0) || (b > 0);
+ case MOP_XOR: return (a > 0) != (b > 0);
+
+#define F(NAME, PROTOTYPE) case MOP_F_##NAME:
+ MATRIX_FUNCTIONS
+#undef F
+ case MOP_NEGATE:
+ case MOP_SEQ:
+ case MOP_SEQ_BY:
+ case MOP_MUL_MAT:
+ case MOP_EXP_MAT:
+ case MOP_NOT:
+ case MOP_PASTE_HORZ:
+ case MOP_PASTE_VERT:
+ case MOP_EMPTY:
+ case MOP_VEC_INDEX:
+ case MOP_VEC_ALL:
+ case MOP_MAT_INDEX:
+ case MOP_ROW_INDEX:
+ case MOP_COL_INDEX:
+ case MOP_NUMBER:
+ case MOP_VARIABLE:
+ case MOP_EOF:
+ NOT_REACHED ();
+ }
+ NOT_REACHED ();
+}
+
+static const char *
+matrix_op_name (enum matrix_op op)
+{
+ switch (op)
+ {
+ case MOP_ADD_ELEMS: return "+";
+ case MOP_SUB_ELEMS: return "-";
+ case MOP_MUL_ELEMS: return "&*";
+ case MOP_DIV_ELEMS: return "&/";
+ case MOP_EXP_ELEMS: return "&**";
+ case MOP_GT: return ">";
+ case MOP_GE: return ">=";
+ case MOP_LT: return "<";
+ case MOP_LE: return "<=";
+ case MOP_EQ: return "=";
+ case MOP_NE: return "<>";
+ case MOP_AND: return "AND";
+ case MOP_OR: return "OR";
+ case MOP_XOR: return "XOR";
+
+#define F(NAME, PROTOTYPE) case MOP_F_##NAME:
+ MATRIX_FUNCTIONS
+#undef F
+ case MOP_NEGATE:
+ case MOP_SEQ:
+ case MOP_SEQ_BY:
+ case MOP_MUL_MAT:
+ case MOP_EXP_MAT:
+ case MOP_NOT:
+ case MOP_PASTE_HORZ:
+ case MOP_PASTE_VERT:
+ case MOP_EMPTY:
+ case MOP_VEC_INDEX:
+ case MOP_VEC_ALL:
+ case MOP_MAT_INDEX:
+ case MOP_ROW_INDEX:
+ case MOP_COL_INDEX:
+ case MOP_NUMBER:
+ case MOP_VARIABLE:
+ case MOP_EOF:
+ NOT_REACHED ();
+ }
+ NOT_REACHED ();
+}
+
+static bool
+is_scalar (const gsl_matrix *m)
+{
+ return m->size1 == 1 && m->size2 == 1;
+}
+
+static double
+to_scalar (const gsl_matrix *m)
+{
+ assert (is_scalar (m));
+ return gsl_matrix_get (m, 0, 0);
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_elementwise (enum matrix_op op,
+ gsl_matrix *a, gsl_matrix *b)
+{
+ if (is_scalar (b))
+ {
+ double be = to_scalar (b);
+ for (size_t r = 0; r < a->size1; r++)
+ for (size_t c = 0; c < a->size2; c++)
+ {
+ double *ae = gsl_matrix_ptr (a, r, c);
+ *ae = matrix_op_eval (op, *ae, be);
+ }
+ return a;
+ }
+ else if (is_scalar (a))
+ {
+ double ae = to_scalar (a);
+ for (size_t r = 0; r < b->size1; r++)
+ for (size_t c = 0; c < b->size2; c++)
+ {
+ double *be = gsl_matrix_ptr (b, r, c);
+ *be = matrix_op_eval (op, ae, *be);
+ }
+ return b;
+ }
+ else if (a->size1 == b->size1 && a->size2 == b->size2)
+ {
+ for (size_t r = 0; r < a->size1; r++)
+ for (size_t c = 0; c < a->size2; c++)
+ {
+ double *ae = gsl_matrix_ptr (a, r, c);
+ double be = gsl_matrix_get (b, r, c);
+ *ae = matrix_op_eval (op, *ae, be);
+ }
+ return a;
+ }
+ else
+ {
+ msg (SE, _("Operands to %s must have the same dimensions or one "
+ "must be a scalar, not matrices with dimensions (%zu,%zu) "
+ "and (%zu,%zu)."),
+ matrix_op_name (op), a->size1, a->size2, b->size1, b->size2);
+ return NULL;
+ }
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_mul_mat (gsl_matrix *a, gsl_matrix *b)
+{
+ if (is_scalar (a) || is_scalar (b))
+ return matrix_expr_evaluate_elementwise (MOP_MUL_ELEMS, a, b);
+
+ if (a->size2 != b->size1)
+ {
+ msg (SE, _("Matrices with dimensions (%zu,%zu) and (%zu,%zu) are "
+ "not conformable for multiplication."),
+ a->size1, a->size2, b->size1, b->size2);
+ return NULL;
+ }
+
+ gsl_matrix *c = gsl_matrix_alloc (a->size1, b->size2);
+ gsl_blas_dgemm (CblasNoTrans, CblasNoTrans, 1.0, a, b, 0.0, c);
+ return c;
+}
+
+static void
+swap_matrix (gsl_matrix **a, gsl_matrix **b)
+{
+ gsl_matrix *tmp = *a;
+ *a = *b;
+ *b = tmp;
+}
+
+static void
+mul_matrix (gsl_matrix **z, const gsl_matrix *x, const gsl_matrix *y,
+ gsl_matrix **tmp)
+{
+ gsl_blas_dgemm (CblasNoTrans, CblasNoTrans, 1.0, x, y, 0.0, *tmp);
+ swap_matrix (z, tmp);
+}
+
+static void
+square_matrix (gsl_matrix **x, gsl_matrix **tmp)
+{
+ mul_matrix (x, *x, *x, tmp);
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_exp_mat (gsl_matrix *x_, gsl_matrix *b)
+{
+ gsl_matrix *x = x_;
+ if (x->size1 != x->size2)
+ {
+ msg (SE, _("Matrix exponentation with ** requires a square matrix on "
+ "the left-hand size, not one with dimensions (%zu,%zu)."),
+ x->size1, x->size2);
+ return NULL;
+ }
+ if (!is_scalar (b))
+ {
+ msg (SE, _("Matrix exponentiation with ** requires a scalar on the "
+ "right-hand side, not a matrix with dimensions (%zu,%zu)."),
+ b->size1, b->size2);
+ return NULL;
+ }
+ double bf = to_scalar (b);
+ if (bf != floor (bf) || bf <= LONG_MIN || bf > LONG_MAX)
+ {
+ msg (SE, _("Exponent %.1f in matrix multiplication is non-integer "
+ "or outside the valid range."), bf);
+ return NULL;
+ }
+ long int bl = bf;
+
+ gsl_matrix *tmp = gsl_matrix_alloc (x->size1, x->size2);
+ gsl_matrix *y = gsl_matrix_alloc (x->size1, x->size2);
+ gsl_matrix_set_identity (y);
+ if (bl == 0)
+ return y;
+
+ for (unsigned long int n = labs (bl); n > 1; n /= 2)
+ if (n & 1)
+ {
+ mul_matrix (&y, x, y, &tmp);
+ square_matrix (&x, &tmp);
+ }
+ else
+ square_matrix (&x, &tmp);
+
+ mul_matrix (&y, x, y, &tmp);
+ if (bf < 0)
+ invert_matrix (y);
+
+ if (tmp != x_)
+ gsl_matrix_free (tmp);
+ return y;
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_seq (gsl_matrix *start_, gsl_matrix *end_,
+ gsl_matrix *by_)
+{
+ if (!is_scalar (start_) || !is_scalar (end_) || (by_ && !is_scalar (by_)))
+ {
+ msg (SE, _("All operands of : operator must be scalars."));
+ return NULL;
+ }
+
+ long int start = to_scalar (start_);
+ long int end = to_scalar (end_);
+ long int by = by_ ? to_scalar (by_) : 1;
+
+ if (!by)
+ {
+ msg (SE, _("The increment operand to : must be nonzero."));
+ return NULL;
+ }
+
+ long int n = (end > start && by > 0 ? (end - start + by) / by
+ : end < start && by < 0 ? (start - end - by) / -by
+ : 0);
+ gsl_matrix *m = gsl_matrix_alloc (1, n);
+ for (long int i = 0; i < n; i++)
+ gsl_matrix_set (m, 0, i, start + i * by);
+ return m;
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_not (gsl_matrix *a)
+{
+ for (size_t r = 0; r < a->size1; r++)
+ for (size_t c = 0; c < a->size2; c++)
+ {
+ double *ae = gsl_matrix_ptr (a, r, c);
+ *ae = !(*ae > 0);
+ }
+ return a;
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_paste_horz (gsl_matrix *a, gsl_matrix *b)
+{
+ if (a->size1 != b->size1)
+ {
+ if (!a->size1 || !a->size2)
+ return b;
+ else if (!b->size1 || !b->size2)
+ return a;
+
+ msg (SE, _("All columns in a matrix must have the same number of rows, "
+ "but this tries to paste matrices with %zu and %zu rows."),
+ a->size1, b->size1);
+ return NULL;
+ }
+
+ gsl_matrix *c = gsl_matrix_alloc (a->size1, a->size2 + b->size2);
+ for (size_t y = 0; y < a->size1; y++)
+ {
+ for (size_t x = 0; x < a->size2; x++)
+ gsl_matrix_set (c, y, x, gsl_matrix_get (a, y, x));
+ for (size_t x = 0; x < b->size2; x++)
+ gsl_matrix_set (c, y, x + a->size2, gsl_matrix_get (b, y, x));
+ }
+ return c;
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_paste_vert (gsl_matrix *a, gsl_matrix *b)
+{
+ if (a->size2 != b->size2)
+ {
+ if (!a->size1 || !a->size2)
+ return b;
+ else if (!b->size1 || !b->size2)
+ return a;
+
+ msg (SE, _("All rows in a matrix must have the same number of columns, "
+ "but this tries to stack matrices with %zu and %zu columns."),
+ a->size2, b->size2);
+ return NULL;
+ }
+
+ gsl_matrix *c = gsl_matrix_alloc (a->size1 + b->size1, a->size2);
+ for (size_t x = 0; x < a->size2; x++)
+ {
+ for (size_t y = 0; y < a->size1; y++)
+ gsl_matrix_set (c, y, x, gsl_matrix_get (a, y, x));
+ for (size_t y = 0; y < b->size1; y++)
+ gsl_matrix_set (c, y + a->size1, x, gsl_matrix_get (b, y, x));
+ }
+ return c;
+}
+
+static gsl_vector *
+matrix_to_vector (gsl_matrix *m)
+{
+ assert (m->owner);
+ gsl_vector v = to_vector (m);
+ assert (v.block == m->block || !v.block);
+ assert (!v.owner);
+ v.owner = 1;
+ m->owner = 0;
+ return xmemdup (&v, sizeof v);
+}
+
+enum index_type {
+ IV_ROW,
+ IV_COLUMN,
+ IV_VECTOR
+};
+
+struct index_vector
+ {
+ size_t *indexes;
+ size_t n;
+ };
+#define INDEX_VECTOR_INIT (struct index_vector) { .n = 0 }
+
+static bool
+matrix_normalize_index_vector (gsl_matrix *m, size_t size,
+ enum index_type index_type, size_t other_size,
+ struct index_vector *iv)
+{
+ if (m)
+ {
+ if (!is_vector (m))
+ {
+ switch (index_type)
+ {
+ case IV_VECTOR:
+ msg (SE, _("Vector index must be scalar or vector, not a "
+ "matrix with dimensions (%zu,%zu)."),
+ m->size1, m->size2);
+ break;
+
+ case IV_ROW:
+ msg (SE, _("Matrix row index must be scalar or vector, not a "
+ "matrix with dimensions (%zu,%zu)."),
+ m->size1, m->size2);
+ break;
+
+ case IV_COLUMN:
+ msg (SE, _("Matrix column index must be scalar or vector, not a "
+ "matrix with dimensions (%zu,%zu)."),
+ m->size1, m->size2);
+ break;
+ }
+ return false;
+ }
+
+ gsl_vector v = to_vector (m);
+ *iv = (struct index_vector) {
+ .indexes = xnmalloc (v.size, sizeof *iv->indexes),
+ .n = v.size,
+ };
+ for (size_t i = 0; i < v.size; i++)
+ {
+ double index = gsl_vector_get (&v, i);
+ if (index < 1 || index >= size + 1)
+ {
+ switch (index_type)
+ {
+ case IV_VECTOR:
+ msg (SE, _("Index %g is out of range for vector "
+ "with %zu elements."), index, size);
+ break;
+
+ case IV_ROW:
+ msg (SE, _("%g is not a valid row index for a matrix "
+ "with dimensions (%zu,%zu)."),
+ index, size, other_size);
+ break;
+
+ case IV_COLUMN:
+ msg (SE, _("%g is not a valid column index for a matrix "
+ "with dimensions (%zu,%zu)."),
+ index, other_size, size);
+ break;
+ }
+
+ free (iv->indexes);
+ return false;
+ }
+ iv->indexes[i] = index - 1;
+ }
+ return true;
+ }
+ else
+ {
+ *iv = (struct index_vector) {
+ .indexes = xnmalloc (size, sizeof *iv->indexes),
+ .n = size,
+ };
+ for (size_t i = 0; i < size; i++)
+ iv->indexes[i] = i;
+ return true;
+ }
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_vec_all (gsl_matrix *sm)
+{
+ if (!is_vector (sm))
+ {
+ msg (SE, _("Vector index operator must be applied to vector, "
+ "not a matrix with dimensions (%zu,%zu)."),
+ sm->size1, sm->size2);
+ return NULL;
+ }
+
+ return sm;
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_vec_index (gsl_matrix *sm, gsl_matrix *im)
+{
+ if (!matrix_expr_evaluate_vec_all (sm))
+ return NULL;
+
+ gsl_vector sv = to_vector (sm);
+ struct index_vector iv;
+ if (!matrix_normalize_index_vector (im, sv.size, IV_VECTOR, 0, &iv))
+ return NULL;
+
+ gsl_matrix *dm = gsl_matrix_alloc (sm->size1 == 1 ? 1 : iv.n,
+ sm->size1 == 1 ? iv.n : 1);
+ gsl_vector dv = to_vector (dm);
+ for (size_t dx = 0; dx < iv.n; dx++)
+ {
+ size_t sx = iv.indexes[dx];
+ gsl_vector_set (&dv, dx, gsl_vector_get (&sv, sx));
+ }
+ free (iv.indexes);
+
+ return dm;
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_mat_index (gsl_matrix *sm, gsl_matrix *im0,
+ gsl_matrix *im1)
+{
+ struct index_vector iv0;
+ if (!matrix_normalize_index_vector (im0, sm->size1, IV_ROW, sm->size2, &iv0))
+ return NULL;
+
+ struct index_vector iv1;
+ if (!matrix_normalize_index_vector (im1, sm->size2, IV_COLUMN, sm->size1,
+ &iv1))
+ {
+ free (iv0.indexes);
+ return NULL;
+ }
+
+ gsl_matrix *dm = gsl_matrix_alloc (iv0.n, iv1.n);
+ for (size_t dy = 0; dy < iv0.n; dy++)
+ {
+ size_t sy = iv0.indexes[dy];
+
+ for (size_t dx = 0; dx < iv1.n; dx++)
+ {
+ size_t sx = iv1.indexes[dx];
+ gsl_matrix_set (dm, dy, dx, gsl_matrix_get (sm, sy, sx));
+ }
+ }
+ free (iv0.indexes);
+ free (iv1.indexes);
+ return dm;
+}
+
+#define F(NAME, PROTOTYPE) \
+ static gsl_matrix *matrix_expr_evaluate_##PROTOTYPE ( \
+ const char *name, gsl_matrix *[], size_t, \
+ matrix_proto_##PROTOTYPE *);
+MATRIX_FUNCTIONS
+#undef F
+
+static bool
+check_scalar_arg (const char *name, gsl_matrix *subs[], size_t index)
+{
+ if (!is_scalar (subs[index]))
+ {
+ msg (SE, _("Function %s argument %zu must be a scalar, "
+ "but it has dimensions (%zu,%zu)."),
+ name, index + 1, subs[index]->size1, subs[index]->size2);
+ return false;
+ }
+ return true;
+}
+
+static bool
+check_vector_arg (const char *name, gsl_matrix *subs[], size_t index)
+{
+ if (!is_vector (subs[index]))
+ {
+ msg (SE, _("Function %s argument %zu must be a vector, "
+ "but it has dimensions (%zu,%zu)."),
+ name, index + 1, subs[index]->size1, subs[index]->size2);
+ return false;
+ }
+ return true;
+}
+
+static bool
+to_scalar_args (const char *name, gsl_matrix *subs[], size_t n_subs, double d[])
+{
+ for (size_t i = 0; i < n_subs; i++)
+ {
+ if (!check_scalar_arg (name, subs, i))
+ return false;
+ d[i] = to_scalar (subs[i]);
+ }
+ return true;
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_m_d (const char *name,
+ gsl_matrix *subs[], size_t n_subs,
+ matrix_proto_m_d *f)
+{
+ assert (n_subs == 1);
+
+ double d;
+ return to_scalar_args (name, subs, n_subs, &d) ? f(d) : NULL;
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_m_dd (const char *name,
+ gsl_matrix *subs[], size_t n_subs,
+ matrix_proto_m_dd *f)
+{
+ assert (n_subs == 2);
+
+ double d[2];
+ return to_scalar_args (name, subs, n_subs, d) ? f(d[0], d[1]) : NULL;
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_m_ddd (const char *name,
+ gsl_matrix *subs[], size_t n_subs,
+ matrix_proto_m_ddd *f)
+{
+ assert (n_subs == 3);
+
+ double d[3];
+ return to_scalar_args (name, subs, n_subs, d) ? f(d[0], d[1], d[2]) : NULL;
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_m_m (const char *name UNUSED,
+ gsl_matrix *subs[], size_t n_subs,
+ matrix_proto_m_m *f)
+{
+ assert (n_subs == 1);
+ return f (subs[0]);
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_m_md (const char *name UNUSED,
+ gsl_matrix *subs[], size_t n_subs,
+ matrix_proto_m_md *f)
+{
+ assert (n_subs == 2);
+ if (!check_scalar_arg (name, subs, 1))
+ return NULL;
+ return f (subs[0], to_scalar (subs[1]));
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_m_mdd (const char *name UNUSED,
+ gsl_matrix *subs[], size_t n_subs,
+ matrix_proto_m_mdd *f)
+{
+ assert (n_subs == 3);
+ if (!check_scalar_arg (name, subs, 1) || !check_scalar_arg (name, subs, 2))
+ return NULL;
+ return f (subs[0], to_scalar (subs[1]), to_scalar (subs[2]));
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_m_mm (const char *name UNUSED,
+ gsl_matrix *subs[], size_t n_subs,
+ matrix_proto_m_mm *f)
+{
+ assert (n_subs == 2);
+ return f (subs[0], subs[1]);
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_m_v (const char *name,
+ gsl_matrix *subs[], size_t n_subs,
+ matrix_proto_m_v *f)
+{
+ assert (n_subs == 1);
+ if (!check_vector_arg (name, subs, 0))
+ return NULL;
+ gsl_vector v = to_vector (subs[0]);
+ return f (&v);
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_d_m (const char *name UNUSED,
+ gsl_matrix *subs[], size_t n_subs,
+ matrix_proto_d_m *f)
+{
+ assert (n_subs == 1);
+
+ gsl_matrix *m = gsl_matrix_alloc (1, 1);
+ gsl_matrix_set (m, 0, 0, f (subs[0]));
+ return m;
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_m_any (const char *name UNUSED,
+ gsl_matrix *subs[], size_t n_subs,
+ matrix_proto_m_any *f)
+{
+ return f (subs, n_subs);
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_IDENT (const char *name,
+ gsl_matrix *subs[], size_t n_subs,
+ matrix_proto_IDENT *f)
+{
+ assert (n_subs <= 2);
+
+ double d[2];
+ if (!to_scalar_args (name, subs, n_subs, d))
+ return NULL;
+
+ return f (d[0], d[n_subs - 1]);
+}
+
+static gsl_matrix *
+matrix_expr_evaluate (const struct matrix_expr *e)
+{
+ if (e->op == MOP_NUMBER)
+ {
+ gsl_matrix *m = gsl_matrix_alloc (1, 1);
+ gsl_matrix_set (m, 0, 0, e->number);
+ return m;
+ }
+ else if (e->op == MOP_VARIABLE)
+ {
+ const gsl_matrix *src = e->variable->value;
+ if (!src)
+ {
+ msg (SE, _("Uninitialized variable %s used in expression."),
+ e->variable->name);
+ return NULL;
+ }
+
+ gsl_matrix *dst = gsl_matrix_alloc (src->size1, src->size2);
+ gsl_matrix_memcpy (dst, src);
+ return dst;
+ }
+ else if (e->op == MOP_EOF)
+ {
+ struct dfm_reader *reader = read_file_open (e->eof);
+ gsl_matrix *m = gsl_matrix_alloc (1, 1);
+ gsl_matrix_set (m, 0, 0, !reader || dfm_eof (reader));
+ return m;
+ }
+
+ enum { N_LOCAL = 3 };
+ gsl_matrix *local_subs[N_LOCAL];
+ gsl_matrix **subs = (e->n_subs < N_LOCAL
+ ? local_subs
+ : xmalloc (e->n_subs * sizeof *subs));
+
+ for (size_t i = 0; i < e->n_subs; i++)
+ {
+ subs[i] = matrix_expr_evaluate (e->subs[i]);
+ if (!subs[i])
+ {
+ for (size_t j = 0; j < i; j++)
+ gsl_matrix_free (subs[j]);
+ if (subs != local_subs)
+ free (subs);
+ return NULL;
+ }
+ }
+
+ gsl_matrix *result = NULL;
+ switch (e->op)
+ {
+#define F(NAME, PROTOTYPE) \
+ case MOP_F_##NAME: \
+ result = matrix_expr_evaluate_##PROTOTYPE (#NAME, \
+ subs, e->n_subs, \
+ matrix_eval_##NAME); \
+ break;
+ MATRIX_FUNCTIONS
+#undef F
+
+ case MOP_NEGATE:
+ gsl_matrix_scale (subs[0], -1.0);
+ result = subs[0];
+ break;
+
+ case MOP_ADD_ELEMS:
+ case MOP_SUB_ELEMS:
+ case MOP_MUL_ELEMS:
+ case MOP_DIV_ELEMS:
+ case MOP_EXP_ELEMS:
+ case MOP_GT:
+ case MOP_GE:
+ case MOP_LT:
+ case MOP_LE:
+ case MOP_EQ:
+ case MOP_NE:
+ case MOP_AND:
+ case MOP_OR:
+ case MOP_XOR:
+ result = matrix_expr_evaluate_elementwise (e->op, subs[0], subs[1]);
+ break;
+
+ case MOP_NOT:
+ result = matrix_expr_evaluate_not (subs[0]);
+ break;
+
+ case MOP_SEQ:
+ result = matrix_expr_evaluate_seq (subs[0], subs[1], NULL);
+ break;
+
+ case MOP_SEQ_BY:
+ result = matrix_expr_evaluate_seq (subs[0], subs[1], subs[2]);
+ break;
+
+ case MOP_MUL_MAT:
+ result = matrix_expr_evaluate_mul_mat (subs[0], subs[1]);
+ break;
+
+ case MOP_EXP_MAT:
+ result = matrix_expr_evaluate_exp_mat (subs[0], subs[1]);
+ break;
+
+ case MOP_PASTE_HORZ:
+ result = matrix_expr_evaluate_paste_horz (subs[0], subs[1]);
+ break;
+
+ case MOP_PASTE_VERT:
+ result = matrix_expr_evaluate_paste_vert (subs[0], subs[1]);
+ break;
+
+ case MOP_EMPTY:
+ result = gsl_matrix_alloc (0, 0);
+ break;
+
+ case MOP_VEC_INDEX:
+ result = matrix_expr_evaluate_vec_index (subs[0], subs[1]);
+ break;
+
+ case MOP_VEC_ALL:
+ result = matrix_expr_evaluate_vec_all (subs[0]);
+ break;
+
+ case MOP_MAT_INDEX:
+ result = matrix_expr_evaluate_mat_index (subs[0], subs[1], subs[2]);
+ break;
+
+ case MOP_ROW_INDEX:
+ result = matrix_expr_evaluate_mat_index (subs[0], subs[1], NULL);
+ break;
+
+ case MOP_COL_INDEX:
+ result = matrix_expr_evaluate_mat_index (subs[0], NULL, subs[1]);
+ break;
+
+ case MOP_NUMBER:
+ case MOP_VARIABLE:
+ case MOP_EOF:
+ NOT_REACHED ();
+ }
+
+ for (size_t i = 0; i < e->n_subs; i++)
+ if (subs[i] != result)
+ gsl_matrix_free (subs[i]);
+ if (subs != local_subs)
+ free (subs);
+ return result;
+}
+
+static bool
+matrix_expr_evaluate_scalar (const struct matrix_expr *e, const char *context,
+ double *d)
+{
+ gsl_matrix *m = matrix_expr_evaluate (e);
+ if (!m)
+ return false;
+
+ if (!is_scalar (m))
+ {
+ msg (SE, _("Expression for %s must evaluate to scalar, "
+ "not a matrix with dimensions (%zu,%zu)."),
+ context, m->size1, m->size2);
+ gsl_matrix_free (m);
+ return false;
+ }
+
+ *d = to_scalar (m);
+ gsl_matrix_free (m);
+ return true;
+}
+
+static bool
+matrix_expr_evaluate_integer (const struct matrix_expr *e, const char *context,
+ long int *integer)
+{
+ double d;
+ if (!matrix_expr_evaluate_scalar (e, context, &d))
+ return false;
+
+ d = trunc (d);
+ if (d < LONG_MIN || d > LONG_MAX)
+ {
+ msg (SE, _("Expression for %s is outside the integer range."), context);
+ return false;
+ }
+ *integer = d;
+ return true;
+}
+\f
+struct matrix_lvalue
+ {
+ struct matrix_var *var;
+ struct matrix_expr *indexes[2];
+ size_t n_indexes;
+ };
+
+static void
+matrix_lvalue_destroy (struct matrix_lvalue *lvalue)
+{
+ if (lvalue)
+ for (size_t i = 0; i < lvalue->n_indexes; i++)
+ matrix_expr_destroy (lvalue->indexes[i]);
+}
+
+static struct matrix_lvalue *
+matrix_lvalue_parse (struct matrix_state *s)
+{
+ struct matrix_lvalue *lvalue = xzalloc (sizeof *lvalue);
+ if (!lex_force_id (s->lexer))
+ goto error;
+ lvalue->var = matrix_var_lookup (s, lex_tokss (s->lexer));
+ if (lex_next_token (s->lexer, 1) == T_LPAREN)
+ {
+ if (!lvalue->var)
+ {
+ msg (SE, _("Undefined variable %s."), lex_tokcstr (s->lexer));
+ return NULL;
+ }
+
+ lex_get_n (s->lexer, 2);
+
+ if (!matrix_parse_index_expr (s, &lvalue->indexes[0]))
+ goto error;
+ lvalue->n_indexes++;
+
+ if (lex_match (s->lexer, T_COMMA))
+ {
+ if (!matrix_parse_index_expr (s, &lvalue->indexes[1]))
+ goto error;
+ lvalue->n_indexes++;
+ }
+ if (!lex_force_match (s->lexer, T_RPAREN))
+ goto error;
+ }
+ else
+ {
+ if (!lvalue->var)
+ lvalue->var = matrix_var_create (s, lex_tokss (s->lexer));
+ lex_get (s->lexer);
+ }
+ return lvalue;
+
+error:
+ matrix_lvalue_destroy (lvalue);
+ return NULL;
+}
+
+static bool
+matrix_lvalue_evaluate_vector (struct matrix_expr *e, size_t size,
+ enum index_type index_type, size_t other_size,
+ struct index_vector *iv)
+{
+ gsl_matrix *m;
+ if (e)
+ {
+ m = matrix_expr_evaluate (e);
+ if (!m)
+ return false;
+ }
+ else
+ m = NULL;
+
+ return matrix_normalize_index_vector (m, size, index_type, other_size, iv);
+}
+
+static bool
+matrix_lvalue_assign_vector (struct matrix_lvalue *lvalue,
+ struct index_vector *iv, gsl_matrix *sm)
+{
+ gsl_vector dv = to_vector (lvalue->var->value);
+
+ /* Convert source matrix 'sm' to source vector 'sv'. */
+ if (!is_vector (sm))
+ {
+ msg (SE, _("Can't assign matrix with dimensions (%zu,%zu) to subvector."),
+ sm->size1, sm->size2);
+ return false;
+ }
+ gsl_vector sv = to_vector (sm);
+ if (iv->n != sv.size)
+ {
+ msg (SE, _("Can't assign vector with %zu elements "
+ "to subvector with %zu."), sv.size, iv->n);
+ return false;
+ }
+
+ /* Assign elements. */
+ for (size_t x = 0; x < iv->n; x++)
+ gsl_vector_set (&dv, iv->indexes[x], gsl_vector_get (&sv, x));
+ return true;
+}
+
+static bool
+matrix_lvalue_assign_matrix (struct matrix_lvalue *lvalue,
+ struct index_vector *iv0,
+ struct index_vector *iv1, gsl_matrix *sm)
+{
+ gsl_matrix *dm = lvalue->var->value;
+
+ /* Convert source matrix 'sm' to source vector 'sv'. */
+ if (iv0->n != sm->size1)
+ {
+ msg (SE, _("Row index vector for assignment to %s has %zu elements "
+ "but source matrix has %zu rows."),
+ lvalue->var->name, iv0->n, sm->size1);
+ return false;
+ }
+ if (iv1->n != sm->size2)
+ {
+ msg (SE, _("Column index vector for assignment to %s has %zu elements "
+ "but source matrix has %zu columns."),
+ lvalue->var->name, iv1->n, sm->size2);
+ return false;
+ }
+
+ /* Assign elements. */
+ for (size_t y = 0; y < iv0->n; y++)
+ {
+ size_t f0 = iv0->indexes[y];
+ for (size_t x = 0; x < iv1->n; x++)
+ {
+ size_t f1 = iv1->indexes[x];
+ gsl_matrix_set (dm, f0, f1, gsl_matrix_get (sm, y, x));
+ }
+ }
+ return true;
+}
+
+/* Takes ownership of M. */
+static bool
+matrix_lvalue_assign (struct matrix_lvalue *lvalue,
+ struct index_vector *iv0, struct index_vector *iv1,
+ gsl_matrix *sm)
+{
+ if (!lvalue->n_indexes)
+ {
+ gsl_matrix_free (lvalue->var->value);
+ lvalue->var->value = sm;
+ return true;
+ }
+ else
+ {
+ bool ok = (lvalue->n_indexes == 1
+ ? matrix_lvalue_assign_vector (lvalue, iv0, sm)
+ : matrix_lvalue_assign_matrix (lvalue, iv0, iv1, sm));
+ free (iv0->indexes);
+ free (iv1->indexes);
+ gsl_matrix_free (sm);
+ return ok;
+ }
+}
+
+static bool
+matrix_lvalue_evaluate (struct matrix_lvalue *lvalue,
+ struct index_vector *iv0,
+ struct index_vector *iv1)
+{
+ *iv0 = INDEX_VECTOR_INIT;
+ *iv1 = INDEX_VECTOR_INIT;
+ if (!lvalue->n_indexes)
+ return true;
+
+ /* Validate destination matrix exists and has the right shape. */
+ gsl_matrix *dm = lvalue->var->value;
+ if (!dm)
+ {
+ msg (SE, _("Undefined variable %s."), lvalue->var->name);
+ return false;
+ }
+ else if (dm->size1 == 0 || dm->size2 == 0)
+ {
+ msg (SE, _("Cannot index matrix with dimensions (%zu,%zu)."),
+ dm->size1, dm->size2);
+ return false;
+ }
+ else if (lvalue->n_indexes == 1)
+ {
+ if (!is_vector (dm))
+ {
+ msg (SE, _("Can't use vector indexing on matrix %s with "
+ "dimensions (%zu,%zu)."),
+ lvalue->var->name, dm->size1, dm->size2);
+ return false;
+ }
+ return matrix_lvalue_evaluate_vector (lvalue->indexes[0],
+ MAX (dm->size1, dm->size2),
+ IV_VECTOR, 0, iv0);
+ }
+ else
+ {
+ assert (lvalue->n_indexes == 2);
+ if (!matrix_lvalue_evaluate_vector (lvalue->indexes[0], dm->size1,
+ IV_ROW, dm->size2, iv0))
+ return false;
+
+ if (!matrix_lvalue_evaluate_vector (lvalue->indexes[1], dm->size2,
+ IV_COLUMN, dm->size1, iv1))
+ {
+ free (iv0->indexes);
+ return false;
+ }
+ return true;
+ }
+}
+
+/* Takes ownership of M. */
+static bool
+matrix_lvalue_evaluate_and_assign (struct matrix_lvalue *lvalue, gsl_matrix *sm)
+{
+ struct index_vector iv0, iv1;
+ return (matrix_lvalue_evaluate (lvalue, &iv0, &iv1)
+ && matrix_lvalue_assign (lvalue, &iv0, &iv1, sm));
+}
+
+\f
+/* Matrix command. */
+
+struct matrix_cmds
+ {
+ struct matrix_cmd **commands;
+ size_t n;
+ };
+
+struct matrix_cmd
+ {
+ enum matrix_cmd_type
+ {
+ MCMD_COMPUTE,
+ MCMD_PRINT,
+ MCMD_DO_IF,
+ MCMD_LOOP,
+ MCMD_BREAK,
+ MCMD_DISPLAY,
+ MCMD_RELEASE,
+ MCMD_SAVE,
+ MCMD_READ,
+ MCMD_WRITE,
+ MCMD_GET,
+ MCMD_MSAVE,
+ MCMD_MGET,
+ MCMD_EIGEN,
+ MCMD_SETDIAG,
+ MCMD_SVD,
+ }
+ type;
+
+ union
+ {
+ struct compute_command
+ {
+ struct matrix_lvalue *lvalue;
+ struct matrix_expr *rvalue;
+ }
+ compute;
+
+ struct print_command
+ {
+ struct matrix_expr *expression;
+ bool use_default_format;
+ struct fmt_spec format;
+ char *title;
+ int space; /* -1 means NEWPAGE. */
+
+ struct print_labels
+ {
+ struct string_array literals; /* CLABELS/RLABELS. */
+ struct matrix_expr *expr; /* CNAMES/RNAMES. */
+ }
+ *rlabels, *clabels;
+ }
+ print;
+
+ struct do_if_command
+ {
+ struct do_if_clause
+ {
+ struct matrix_expr *condition;
+ struct matrix_cmds commands;
+ }
+ *clauses;
+ size_t n_clauses;
+ }
+ do_if;
+
+ struct loop_command
+ {
+ /* Index. */
+ struct matrix_var *var;
+ struct matrix_expr *start;
+ struct matrix_expr *end;
+ struct matrix_expr *increment;
+
+ /* Loop conditions. */
+ struct matrix_expr *top_condition;
+ struct matrix_expr *bottom_condition;
+
+ /* Commands. */
+ struct matrix_cmds commands;
+ }
+ loop;
+
+ struct save_command
+ {
+ struct matrix_expr *expression;
+ struct file_handle *outfile;
+ struct string_array *variables;
+ struct matrix_expr *names;
+ struct stringi_set strings;
+ }
+ save;
+
+ struct read_command
+ {
+ struct read_file *rf;
+ struct matrix_lvalue *dst;
+ struct matrix_expr *size;
+ int c1, c2;
+ enum fmt_type format;
+ int w;
+ int d;
+ bool symmetric;
+ bool reread;
+ }
+ read;
+
+ struct write_command
+ {
+ struct matrix_expr *expression;
+ struct file_handle *outfile;
+ char *encoding;
+ int c1, c2;
+ enum fmt_type format;
+ int w;
+ int d;
+ bool triangular;
+ bool hold;
+ }
+ write;
+
+ struct display_command
+ {
+ struct matrix_state *state;
+ bool dictionary;
+ bool status;
+ }
+ display;
+
+ struct release_command
+ {
+ struct matrix_var **vars;
+ size_t n_vars;
+ }
+ release;
+
+ struct get_command
+ {
+ struct matrix_lvalue *dst;
+ struct file_handle *file;
+ char *encoding;
+ struct string_array variables;
+ struct matrix_var *names;
+
+ /* Treatment of missing values. */
+ struct
+ {
+ enum
+ {
+ MGET_ERROR, /* Flag error on command. */
+ MGET_ACCEPT, /* Accept without change, user-missing only. */
+ MGET_OMIT, /* Drop this case. */
+ MGET_RECODE /* Recode to 'substitute'. */
+ }
+ treatment;
+ double substitute; /* MGET_RECODE only. */
+ }
+ user, system;
+ }
+ get;
+
+ struct msave_command
+ {
+ struct msave_common *common;
+ char *varname_;
+ struct matrix_expr *expr;
+ const char *rowtype;
+ struct matrix_expr *factors;
+ struct matrix_expr *splits;
+ }
+ msave;
+
+ struct mget_command
+ {
+ struct matrix_state *state;
+ struct file_handle *file;
+ struct stringi_set rowtypes;
+ }
+ mget;
+
+ struct eigen_command
+ {
+ struct matrix_expr *expr;
+ struct matrix_var *evec;
+ struct matrix_var *eval;
+ }
+ eigen;
+
+ struct setdiag_command
+ {
+ struct matrix_var *dst;
+ struct matrix_expr *expr;
+ }
+ setdiag;
+
+ struct svd_command
+ {
+ struct matrix_expr *expr;
+ struct matrix_var *u;
+ struct matrix_var *s;
+ struct matrix_var *v;
+ }
+ svd;
+ };
+ };
+
+static struct matrix_cmd *matrix_parse_command (struct matrix_state *);
+static bool matrix_cmd_execute (struct matrix_cmd *);
+
+static void
+matrix_cmd_destroy (struct matrix_cmd *cmd)
+{
+ /* XXX */
+ free (cmd);
+}
+\f
+static struct matrix_cmd *
+matrix_parse_compute (struct matrix_state *s)
+{
+ struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
+ *cmd = (struct matrix_cmd) {
+ .type = MCMD_COMPUTE,
+ .compute = { .lvalue = NULL },
+ };
+
+ struct compute_command *compute = &cmd->compute;
+ compute->lvalue = matrix_lvalue_parse (s);
+ if (!compute->lvalue)
+ goto error;
+
+ if (!lex_force_match (s->lexer, T_EQUALS))
+ goto error;
+
+ compute->rvalue = matrix_parse_expr (s);
+ if (!compute->rvalue)
+ goto error;
+
+ return cmd;
+
+error:
+ matrix_cmd_destroy (cmd);
+ return NULL;
+}
+
+static void
+matrix_cmd_execute_compute (struct compute_command *compute)
+{
+ gsl_matrix *value = matrix_expr_evaluate (compute->rvalue);
+ if (!value)
+ return;
+
+ matrix_lvalue_evaluate_and_assign (compute->lvalue, value);
+}
+\f
+static void
+print_labels_destroy (struct print_labels *labels)
+{
+ if (labels)
+ {
+ string_array_destroy (&labels->literals);
+ matrix_expr_destroy (labels->expr);
+ free (labels);
+ }
+}
+
+static void
+parse_literal_print_labels (struct matrix_state *s,
+ struct print_labels **labelsp)
+{
+ lex_match (s->lexer, T_EQUALS);
+ print_labels_destroy (*labelsp);
+ *labelsp = xzalloc (sizeof **labelsp);
+ while (lex_token (s->lexer) != T_SLASH
+ && lex_token (s->lexer) != T_ENDCMD
+ && lex_token (s->lexer) != T_STOP)
+ {
+ struct string label = DS_EMPTY_INITIALIZER;
+ while (lex_token (s->lexer) != T_COMMA
+ && lex_token (s->lexer) != T_SLASH
+ && lex_token (s->lexer) != T_ENDCMD
+ && lex_token (s->lexer) != T_STOP)
+ {
+ if (!ds_is_empty (&label))
+ ds_put_byte (&label, ' ');
+
+ if (lex_token (s->lexer) == T_STRING)
+ ds_put_cstr (&label, lex_tokcstr (s->lexer));
+ else
+ {
+ char *rep = lex_next_representation (s->lexer, 0, 0);
+ ds_put_cstr (&label, rep);
+ free (rep);
+ }
+ lex_get (s->lexer);
+ }
+ string_array_append_nocopy (&(*labelsp)->literals,
+ ds_steal_cstr (&label));
+
+ if (!lex_match (s->lexer, T_COMMA))
+ break;
+ }
+}
+
+static bool
+parse_expr_print_labels (struct matrix_state *s, struct print_labels **labelsp)
+{
+ lex_match (s->lexer, T_EQUALS);
+ struct matrix_expr *e = matrix_parse_exp (s);
+ if (!e)
+ return false;
+
+ print_labels_destroy (*labelsp);
+ *labelsp = xzalloc (sizeof **labelsp);
+ (*labelsp)->expr = e;
+ return true;
+}
+
+static struct matrix_cmd *
+matrix_parse_print (struct matrix_state *s)
+{
+ struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
+ *cmd = (struct matrix_cmd) {
+ .type = MCMD_PRINT,
+ .print = {
+ .use_default_format = true,
+ }
+ };
+
+ if (lex_token (s->lexer) != T_SLASH && lex_token (s->lexer) != T_ENDCMD)
+ {
+ size_t depth = 0;
+ for (size_t i = 0; ; i++)
+ {
+ enum token_type t = lex_next_token (s->lexer, i);
+ if (t == T_LPAREN || t == T_LBRACK || t == T_LCURLY)
+ depth++;
+ else if ((t == T_RPAREN || t == T_RBRACK || t == T_RCURLY) && depth)
+ depth--;
+ else if ((t == T_SLASH && !depth) || t == T_ENDCMD || t == T_STOP)
+ {
+ if (i > 0)
+ cmd->print.title = lex_next_representation (s->lexer, 0, i - 1);
+ break;
+ }
+ }
+
+ cmd->print.expression = matrix_parse_exp (s);
+ if (!cmd->print.expression)
+ goto error;
+ }
+
+ while (lex_match (s->lexer, T_SLASH))
+ {
+ if (lex_match_id (s->lexer, "FORMAT"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+ if (!parse_format_specifier (s->lexer, &cmd->print.format))
+ goto error;
+ cmd->print.use_default_format = false;
+ }
+ else if (lex_match_id (s->lexer, "TITLE"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+ if (!lex_force_string (s->lexer))
+ goto error;
+ free (cmd->print.title);
+ cmd->print.title = ss_xstrdup (lex_tokss (s->lexer));
+ lex_get (s->lexer);
+ }
+ else if (lex_match_id (s->lexer, "SPACE"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+ if (lex_match_id (s->lexer, "NEWPAGE"))
+ cmd->print.space = -1;
+ else if (lex_force_int_range (s->lexer, "SPACE", 1, INT_MAX))
+ {
+ cmd->print.space = lex_integer (s->lexer);
+ lex_get (s->lexer);
+ }
+ else
+ goto error;
+ }
+ else if (lex_match_id (s->lexer, "RLABELS"))
+ parse_literal_print_labels (s, &cmd->print.rlabels);
+ else if (lex_match_id (s->lexer, "CLABELS"))
+ parse_literal_print_labels (s, &cmd->print.clabels);
+ else if (lex_match_id (s->lexer, "RNAMES"))
+ {
+ if (!parse_expr_print_labels (s, &cmd->print.rlabels))
+ goto error;
+ }
+ else if (lex_match_id (s->lexer, "CNAMES"))
+ {
+ if (!parse_expr_print_labels (s, &cmd->print.clabels))
+ goto error;
+ }
+ else
+ {
+ lex_error_expecting (s->lexer, "FORMAT", "TITLE", "SPACE",
+ "RLABELS", "CLABELS", "RNAMES", "CNAMES");
+ goto error;
+ }
+
+ }
+ return cmd;
+
+error:
+ matrix_cmd_destroy (cmd);
+ return NULL;
+}
+
+static bool
+matrix_is_integer (const gsl_matrix *m)
+{
+ for (size_t y = 0; y < m->size1; y++)
+ for (size_t x = 0; x < m->size2; x++)
+ {
+ double d = gsl_matrix_get (m, y, x);
+ if (d != floor (d))
+ return false;
+ }
+ return true;
+}
+
+static double
+matrix_max_magnitude (const gsl_matrix *m)
+{
+ double max = 0.0;
+ for (size_t y = 0; y < m->size1; y++)
+ for (size_t x = 0; x < m->size2; x++)
+ {
+ double d = fabs (gsl_matrix_get (m, y, x));
+ if (d > max)
+ max = d;
+ }
+ return max;
+}
+
+static bool
+format_fits (struct fmt_spec format, double x)
+{
+ char *s = data_out (&(union value) { .f = x }, NULL,
+ &format, settings_get_fmt_settings ());
+ bool fits = *s != '*' && !strchr (s, 'E');
+ free (s);
+ return fits;
+}
+
+static struct fmt_spec
+default_format (const gsl_matrix *m, int *log_scale)
+{
+ *log_scale = 0;
+
+ double max = matrix_max_magnitude (m);
+
+ if (matrix_is_integer (m))
+ for (int w = 1; w <= 12; w++)
+ {
+ struct fmt_spec format = { .type = FMT_F, .w = w };
+ if (format_fits (format, -max))
+ return format;
+ }
+
+ if (max >= 1e9 || max <= 1e-4)
+ {
+ char s[64];
+ snprintf (s, sizeof s, "%.1e", max);
+
+ const char *e = strchr (s, 'e');
+ if (e)
+ *log_scale = atoi (e + 1);
+ }
+
+ return (struct fmt_spec) { .type = FMT_F, .w = 13, .d = 10 };
+}
+
+static char *
+trimmed_string (double d)
+{
+ struct substring s = ss_buffer ((char *) &d, sizeof d);
+ ss_rtrim (&s, ss_cstr (" "));
+ return ss_xstrdup (s);
+}
+
+static struct string_array *
+print_labels_get (const struct print_labels *labels, size_t n,
+ const char *prefix, bool truncate)
+{
+ if (!labels)
+ return NULL;
+
+ struct string_array *out = xzalloc (sizeof *out);
+ if (labels->literals.n)
+ string_array_clone (out, &labels->literals);
+ else if (labels->expr)
+ {
+ gsl_matrix *m = matrix_expr_evaluate (labels->expr);
+ if (m && is_vector (m))
+ {
+ gsl_vector v = to_vector (m);
+ for (size_t i = 0; i < v.size; i++)
+ string_array_append_nocopy (out, trimmed_string (
+ gsl_vector_get (&v, i)));
+ }
+ gsl_matrix_free (m);
+ }
+
+ while (out->n < n)
+ {
+ if (labels->expr)
+ string_array_append_nocopy (out, xasprintf ("%s%zu", prefix,
+ out->n + 1));
+ else
+ string_array_append (out, "");
+ }
+ while (out->n > n)
+ string_array_delete (out, out->n - 1);
+
+ if (truncate)
+ for (size_t i = 0; i < out->n; i++)
+ {
+ char *s = out->strings[i];
+ s[strnlen (s, 8)] = '\0';
+ }
+
+ return out;
+}
+
+static void
+matrix_cmd_print_space (int space)
+{
+ if (space < 0)
+ output_item_submit (page_break_item_create ());
+ for (int i = 0; i < space; i++)
+ output_log ("%s", "");
+}
+
+static void
+matrix_cmd_print_text (const struct print_command *print, const gsl_matrix *m,
+ struct fmt_spec format, int log_scale)
+{
+ matrix_cmd_print_space (print->space);
+ if (print->title)
+ output_log ("%s", print->title);
+ if (log_scale != 0)
+ output_log (" 10 ** %d X", log_scale);
+
+ struct string_array *clabels = print_labels_get (print->clabels,
+ m->size2, "col", true);
+ if (clabels && format.w < 8)
+ format.w = 8;
+ struct string_array *rlabels = print_labels_get (print->rlabels,
+ m->size1, "row", true);
+
+ if (clabels)
+ {
+ struct string line = DS_EMPTY_INITIALIZER;
+ if (rlabels)
+ ds_put_byte_multiple (&line, ' ', 8);
+ for (size_t x = 0; x < m->size2; x++)
+ ds_put_format (&line, " %*s", format.w, clabels->strings[x]);
+ output_log_nocopy (ds_steal_cstr (&line));
+ }
+
+ double scale = pow (10.0, log_scale);
+ bool numeric = fmt_is_numeric (format.type);
+ for (size_t y = 0; y < m->size1; y++)
+ {
+ struct string line = DS_EMPTY_INITIALIZER;
+ if (rlabels)
+ ds_put_format (&line, "%-8s", rlabels->strings[y]);
+
+ for (size_t x = 0; x < m->size2; x++)
+ {
+ double f = gsl_matrix_get (m, y, x);
+ char *s = (numeric
+ ? data_out (&(union value) { .f = f / scale}, NULL,
+ &format, settings_get_fmt_settings ())
+ : trimmed_string (f));
+ ds_put_format (&line, " %s", s);
+ free (s);
+ }
+ output_log_nocopy (ds_steal_cstr (&line));
+ }
+
+ string_array_destroy (rlabels);
+ string_array_destroy (clabels);
+}
+
+static void
+create_print_dimension (struct pivot_table *table, enum pivot_axis_type axis,
+ const struct print_labels *print_labels, size_t n,
+ const char *name, const char *prefix)
+{
+ struct string_array *labels = print_labels_get (print_labels, n, prefix,
+ false);
+ struct pivot_dimension *d = pivot_dimension_create (table, axis, name);
+ for (size_t i = 0; i < n; i++)
+ pivot_category_create_leaf (
+ d->root, (labels
+ ? pivot_value_new_user_text (labels->strings[i], SIZE_MAX)
+ : pivot_value_new_integer (i + 1)));
+ if (!labels)
+ d->hide_all_labels = true;
+ string_array_destroy (labels);
+}
+
+static void
+matrix_cmd_print_tables (const struct print_command *print, const gsl_matrix *m,
+ struct fmt_spec format, int log_scale)
+{
+ struct pivot_table *table = pivot_table_create__ (
+ pivot_value_new_user_text (print->title ? print->title : "", SIZE_MAX),
+ "Matrix Print");
+
+ create_print_dimension (table, PIVOT_AXIS_ROW, print->rlabels, m->size1,
+ N_("Rows"), "row");
+ create_print_dimension (table, PIVOT_AXIS_COLUMN, print->clabels, m->size2,
+ N_("Columns"), "col");
+
+ struct pivot_footnote *footnote = NULL;
+ if (log_scale != 0)
+ {
+ char *s = xasprintf ("× 10**%d", log_scale);
+ footnote = pivot_table_create_footnote (
+ table, pivot_value_new_user_text_nocopy (s));
+ }
+
+ double scale = pow (10.0, log_scale);
+ bool numeric = fmt_is_numeric (format.type);
+ for (size_t y = 0; y < m->size1; y++)
+ for (size_t x = 0; x < m->size2; x++)
+ {
+ double f = gsl_matrix_get (m, y, x);
+ struct pivot_value *v;
+ if (numeric)
+ {
+ v = pivot_value_new_number (f / scale);
+ v->numeric.format = format;
+ }
+ else
+ v = pivot_value_new_user_text_nocopy (trimmed_string (f));
+ if (footnote)
+ pivot_value_add_footnote (v, footnote);
+ pivot_table_put2 (table, y, x, v);
+ }
+
+ pivot_table_submit (table);
+}
+
+static void
+matrix_cmd_execute_print (const struct print_command *print)
+{
+ if (print->expression)
+ {
+ gsl_matrix *m = matrix_expr_evaluate (print->expression);
+ if (!m)
+ return;
+
+ int log_scale = 0;
+ struct fmt_spec format = (print->use_default_format
+ ? default_format (m, &log_scale)
+ : print->format);
+
+ if (settings_get_mdisplay () == SETTINGS_MDISPLAY_TEXT)
+ matrix_cmd_print_text (print, m, format, log_scale);
+ else
+ matrix_cmd_print_tables (print, m, format, log_scale);
+
+ gsl_matrix_free (m);
+ }
+ else
+ {
+ matrix_cmd_print_space (print->space);
+ if (print->title)
+ output_log ("%s", print->title);
+ }
+}
+\f
+/* DO IF. */
+
+static bool
+matrix_parse_commands (struct matrix_state *s, struct matrix_cmds *c,
+ const char *command_name,
+ const char *stop1, const char *stop2)
+{
+ lex_end_of_command (s->lexer);
+ lex_discard_rest_of_command (s->lexer);
+
+ size_t allocated = 0;
+ for (;;)
+ {
+ while (lex_token (s->lexer) == T_ENDCMD)
+ lex_get (s->lexer);
+
+ if (lex_at_phrase (s->lexer, stop1)
+ || (stop2 && lex_at_phrase (s->lexer, stop2)))
+ return true;
+
+ if (lex_at_phrase (s->lexer, "END MATRIX"))
+ {
+ msg (SE, _("Premature END MATRIX within %s."), command_name);
+ return false;
+ }
+
+ struct matrix_cmd *cmd = matrix_parse_command (s);
+ if (!cmd)
+ return false;
+
+ if (c->n >= allocated)
+ c->commands = x2nrealloc (c->commands, &allocated, sizeof *c->commands);
+ c->commands[c->n++] = cmd;
+ }
+}
+
+static bool
+matrix_parse_do_if_clause (struct matrix_state *s,
+ struct do_if_command *ifc,
+ bool parse_condition,
+ size_t *allocated_clauses)
+{
+ if (ifc->n_clauses >= *allocated_clauses)
+ ifc->clauses = x2nrealloc (ifc->clauses, allocated_clauses,
+ sizeof *ifc->clauses);
+ struct do_if_clause *c = &ifc->clauses[ifc->n_clauses++];
+ *c = (struct do_if_clause) { .condition = NULL };
+
+ if (parse_condition)
+ {
+ c->condition = matrix_parse_expr (s);
+ if (!c->condition)
+ return false;
+ }
+
+ return matrix_parse_commands (s, &c->commands, "DO IF", "ELSE", "END IF");
+}
+
+static struct matrix_cmd *
+matrix_parse_do_if (struct matrix_state *s)
+{
+ struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
+ *cmd = (struct matrix_cmd) {
+ .type = MCMD_DO_IF,
+ .do_if = { .n_clauses = 0 }
+ };
+
+ size_t allocated_clauses = 0;
+ do
+ {
+ if (!matrix_parse_do_if_clause (s, &cmd->do_if, true, &allocated_clauses))
+ goto error;
+ }
+ while (lex_match_phrase (s->lexer, "ELSE IF"));
+
+ if (lex_match_id (s->lexer, "ELSE")
+ && !matrix_parse_do_if_clause (s, &cmd->do_if, false, &allocated_clauses))
+ goto error;
+
+ if (!lex_match_phrase (s->lexer, "END IF"))
+ NOT_REACHED ();
+ return cmd;
+
+error:
+ matrix_cmd_destroy (cmd);
+ return NULL;
+}
+
+static bool
+matrix_cmd_execute_do_if (struct do_if_command *cmd)
+{
+ for (size_t i = 0; i < cmd->n_clauses; i++)
+ {
+ struct do_if_clause *c = &cmd->clauses[i];
+ if (c->condition)
+ {
+ double d;
+ if (!matrix_expr_evaluate_scalar (c->condition,
+ i ? "ELSE IF" : "DO IF",
+ &d) || d <= 0)
+ continue;
+ }
+
+ for (size_t j = 0; j < c->commands.n; j++)
+ if (!matrix_cmd_execute (c->commands.commands[j]))
+ return false;
+ return true;
+ }
+ return true;
+}
+\f
+static struct matrix_cmd *
+matrix_parse_loop (struct matrix_state *s)
+{
+ struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
+ *cmd = (struct matrix_cmd) { .type = MCMD_LOOP, .loop = { .var = NULL } };
+
+ struct loop_command *loop = &cmd->loop;
+ if (lex_token (s->lexer) == T_ID && lex_next_token (s->lexer, 1) == T_EQUALS)
+ {
+ struct substring name = lex_tokss (s->lexer);
+ loop->var = matrix_var_lookup (s, name);
+ if (!loop->var)
+ loop->var = matrix_var_create (s, name);
+
+ lex_get (s->lexer);
+ lex_get (s->lexer);
+
+ loop->start = matrix_parse_expr (s);
+ if (!loop->start || !lex_force_match (s->lexer, T_TO))
+ goto error;
+
+ loop->end = matrix_parse_expr (s);
+ if (!loop->end)
+ goto error;
+
+ if (lex_match (s->lexer, T_BY))
+ {
+ loop->increment = matrix_parse_expr (s);
+ if (!loop->increment)
+ goto error;
+ }
+ }
+
+ if (lex_match_id (s->lexer, "IF"))
+ {
+ loop->top_condition = matrix_parse_expr (s);
+ if (!loop->top_condition)
+ goto error;
+ }
+
+ bool was_in_loop = s->in_loop;
+ s->in_loop = true;
+ bool ok = matrix_parse_commands (s, &loop->commands, "LOOP",
+ "END LOOP", NULL);
+ s->in_loop = was_in_loop;
+ if (!ok)
+ goto error;
+
+ if (!lex_match_phrase (s->lexer, "END LOOP"))
+ NOT_REACHED ();
+
+ if (lex_match_id (s->lexer, "IF"))
+ {
+ loop->bottom_condition = matrix_parse_expr (s);
+ if (!loop->bottom_condition)
+ goto error;
+ }
+
+ return cmd;
+
+error:
+ matrix_cmd_destroy (cmd);
+ return NULL;
+}
+
+static void
+matrix_cmd_execute_loop (struct loop_command *cmd)
+{
+ long int value = 0;
+ long int end = 0;
+ long int increment = 1;
+ if (cmd->var)
+ {
+ if (!matrix_expr_evaluate_integer (cmd->start, "LOOP", &value)
+ || !matrix_expr_evaluate_integer (cmd->end, "TO", &end)
+ || (cmd->increment
+ && !matrix_expr_evaluate_integer (cmd->increment, "BY",
+ &increment)))
+ return;
+
+ if (increment > 0 ? value > end
+ : increment < 0 ? value < end
+ : true)
+ return;
+ }
+
+ int mxloops = settings_get_mxloops ();
+ for (int i = 0; i < mxloops; i++)
+ {
+ if (cmd->var)
+ {
+ if (cmd->var->value
+ && (cmd->var->value->size1 != 1 || cmd->var->value->size2 != 1))
+ {
+ gsl_matrix_free (cmd->var->value);
+ cmd->var->value = NULL;
+ }
+ if (!cmd->var->value)
+ cmd->var->value = gsl_matrix_alloc (1, 1);
+
+ gsl_matrix_set (cmd->var->value, 0, 0, value);
+ }
+
+ if (cmd->top_condition)
+ {
+ double d;
+ if (!matrix_expr_evaluate_scalar (cmd->top_condition, "LOOP IF",
+ &d) || d <= 0)
+ return;
+ }
+
+ for (size_t j = 0; j < cmd->commands.n; j++)
+ if (!matrix_cmd_execute (cmd->commands.commands[j]))
+ return;
+
+ if (cmd->bottom_condition)
+ {
+ double d;
+ if (!matrix_expr_evaluate_scalar (cmd->bottom_condition,
+ "END LOOP IF", &d) || d > 0)
+ return;
+ }
+
+ if (cmd->var)
+ {
+ value += increment;
+ if (increment > 0 ? value > end : value < end)
+ return;
+ }
+ }
+}
+\f
+static struct matrix_cmd *
+matrix_parse_break (struct matrix_state *s)
+{
+ if (!s->in_loop)
+ {
+ msg (SE, _("BREAK not inside LOOP."));
+ return NULL;
+ }
+
+ struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
+ *cmd = (struct matrix_cmd) { .type = MCMD_BREAK };
+ return cmd;
+}
+\f
+static struct matrix_cmd *
+matrix_parse_display (struct matrix_state *s)
+{
+ bool dictionary = false;
+ bool status = false;
+ while (lex_token (s->lexer) == T_ID)
+ {
+ if (lex_match_id (s->lexer, "DICTIONARY"))
+ dictionary = true;
+ else if (lex_match_id (s->lexer, "STATUS"))
+ status = true;
+ else
+ {
+ lex_error_expecting (s->lexer, "DICTIONARY", "STATUS");
+ return NULL;
+ }
+ }
+ if (!dictionary && !status)
+ dictionary = status = true;
+
+ struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
+ *cmd = (struct matrix_cmd) {
+ .type = MCMD_DISPLAY,
+ .display = {
+ .state = s,
+ .dictionary = dictionary,
+ .status = status,
+ }
+ };
+ return cmd;
+}
+
+static int
+compare_matrix_var_pointers (const void *a_, const void *b_)
+{
+ const struct matrix_var *const *ap = a_;
+ const struct matrix_var *const *bp = b_;
+ const struct matrix_var *a = *ap;
+ const struct matrix_var *b = *bp;
+ return strcmp (a->name, b->name);
+}
+
+static void
+matrix_cmd_execute_display (struct display_command *cmd)
+{
+ const struct matrix_state *s = cmd->state;
+
+ struct pivot_table *table = pivot_table_create (N_("Matrix Variables"));
+ pivot_dimension_create (
+ table, PIVOT_AXIS_COLUMN, N_("Property"),
+ N_("Rows"), N_("Columns"), N_("Size (kB)"));
+
+ const struct matrix_var **vars = xmalloc (hmap_count (&s->vars) * sizeof *vars);
+ size_t n_vars = 0;
+
+ const struct matrix_var *var;
+ HMAP_FOR_EACH (var, struct matrix_var, hmap_node, &s->vars)
+ if (var->value)
+ vars[n_vars++] = var;
+ qsort (vars, n_vars, sizeof *vars, compare_matrix_var_pointers);
+
+ struct pivot_dimension *rows = pivot_dimension_create (
+ table, PIVOT_AXIS_ROW, N_("Variable"));
+ for (size_t i = 0; i < n_vars; i++)
+ {
+ const struct matrix_var *var = vars[i];
+ pivot_category_create_leaf (
+ rows->root, pivot_value_new_user_text (var->name, SIZE_MAX));
+
+ size_t r = var->value->size1;
+ size_t c = var->value->size2;
+ double values[] = { r, c, r * c * sizeof (double) / 1024 };
+ for (size_t j = 0; j < sizeof values / sizeof *values; j++)
+ pivot_table_put2 (table, j, i, pivot_value_new_integer (values[j]));
+ }
+ pivot_table_submit (table);
+}
+\f
+static struct matrix_cmd *
+matrix_parse_release (struct matrix_state *s)
+{
+ struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
+ *cmd = (struct matrix_cmd) { .type = MCMD_RELEASE };
+
+ size_t allocated_vars = 0;
+ while (lex_token (s->lexer) == T_ID)
+ {
+ struct matrix_var *var = matrix_var_lookup (s, lex_tokss (s->lexer));
+ if (var)
+ {
+ if (cmd->release.n_vars >= allocated_vars)
+ cmd->release.vars = x2nrealloc (cmd->release.vars, &allocated_vars,
+ sizeof *cmd->release.vars);
+ cmd->release.vars[cmd->release.n_vars++] = var;
+ }
+ else
+ lex_error (s->lexer, _("Variable name expected."));
+ lex_get (s->lexer);
+
+ if (!lex_match (s->lexer, T_COMMA))
+ break;
+ }
+
+ return cmd;
+}
+
+static void
+matrix_cmd_execute_release (struct release_command *cmd)
+{
+ for (size_t i = 0; i < cmd->n_vars; i++)
+ {
+ struct matrix_var *var = cmd->vars[i];
+ gsl_matrix_free (var->value);
+ var->value = NULL;
+ }
+}
+\f
+static struct matrix_cmd *
+matrix_parse_save (struct matrix_state *s)
+{
+ struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
+ *cmd = (struct matrix_cmd) {
+ .type = MCMD_SAVE,
+ .save = {
+ .strings = STRINGI_SET_INITIALIZER (cmd->save.strings)
+ }
+ };
+
+ struct save_command *save = &cmd->save;
+ save->expression = matrix_parse_exp (s);
+ if (!save->expression)
+ goto error;
+
+ while (lex_match (s->lexer, T_SLASH))
+ {
+ if (lex_match_id (s->lexer, "OUTFILE"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+
+ fh_unref (save->outfile);
+ save->outfile = (lex_match (s->lexer, T_ASTERISK)
+ ? fh_inline_file ()
+ : fh_parse (s->lexer, FH_REF_FILE, s->session));
+ if (!save->outfile)
+ goto error;
+ }
+ else if (lex_match_id (s->lexer, "VARIABLES"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+
+ char **names;
+ size_t n;
+ struct dictionary *d = dict_create (get_default_encoding ());
+ bool ok = parse_DATA_LIST_vars (s->lexer, d, &names, &n,
+ PV_NO_SCRATCH | PV_NO_DUPLICATE);
+ dict_unref (d);
+ if (!ok)
+ goto error;
+
+ string_array_destroy (save->variables);
+ if (!save->variables)
+ save->variables = xmalloc (sizeof *save->variables);
+ *save->variables = (struct string_array) {
+ .strings = names,
+ .n = n,
+ .allocated = n,
+ };
+ }
+ else if (lex_match_id (s->lexer, "NAMES"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+ matrix_expr_destroy (save->names);
+ save->names = matrix_parse_exp (s);
+ if (!save->names)
+ goto error;
+ }
+ else if (lex_match_id (s->lexer, "STRINGS"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+ while (lex_token (s->lexer) == T_ID)
+ {
+ stringi_set_insert (&save->strings, lex_tokcstr (s->lexer));
+ lex_get (s->lexer);
+ if (!lex_match (s->lexer, T_COMMA))
+ break;
+ }
+ }
+ else
+ {
+ lex_error_expecting (s->lexer, "OUTFILE", "VARIABLES", "NAMES",
+ "STRINGS");
+ goto error;
+ }
+ }
+
+ if (!save->outfile)
+ {
+ if (s->prev_save_outfile)
+ save->outfile = fh_ref (s->prev_save_outfile);
+ else
+ {
+ lex_sbc_missing ("OUTFILE");
+ goto error;
+ }
+ }
+ fh_unref (s->prev_save_outfile);
+ s->prev_save_outfile = fh_ref (save->outfile);
+
+ if (save->variables && save->names)
+ {
+ msg (SW, _("VARIABLES and NAMES both specified; ignoring NAMES."));
+ matrix_expr_destroy (save->names);
+ save->names = NULL;
+ }
+
+ return cmd;
+
+error:
+ matrix_cmd_destroy (cmd);
+ return NULL;
+}
+
+static void
+matrix_cmd_execute_save (const struct save_command *save)
+{
+ assert (save->outfile != fh_inline_file ()); /* XXX not yet implemented */
+
+ gsl_matrix *m = matrix_expr_evaluate (save->expression);
+ if (!m)
+ return;
+
+ bool ok = true;
+ struct dictionary *dict = dict_create (get_default_encoding ());
+ struct string_array names = { .n = 0 };
+ if (save->variables)
+ string_array_clone (&names, save->variables);
+ else if (save->names)
+ {
+ gsl_matrix *nm = matrix_expr_evaluate (save->names);
+ if (nm && is_vector (nm))
+ {
+ gsl_vector nv = to_vector (nm);
+ for (size_t i = 0; i < nv.size; i++)
+ {
+ char *name = trimmed_string (gsl_vector_get (&nv, i));
+ if (dict_id_is_valid (dict, name, true))
+ string_array_append_nocopy (&names, name);
+ else
+ ok = false;
+ }
+ }
+ }
+
+ struct stringi_set strings;
+ stringi_set_clone (&strings, &save->strings);
+
+ for (size_t i = 0; dict_get_var_cnt (dict) < m->size2; i++)
+ {
+ char tmp_name[64];
+ const char *name;
+ if (i < names.n)
+ name = names.strings[i];
+ else
+ {
+ snprintf (tmp_name, sizeof tmp_name, "COL%zu", i + 1);
+ name = tmp_name;
+ }
+
+ int width = stringi_set_delete (&strings, name) ? 8 : 0;
+ struct variable *var = dict_create_var (dict, name, width);
+ if (!var)
+ {
+ msg (SE, _("Duplicate variable name %s in SAVE statement."),
+ name);
+ ok = false;
+ }
+ }
+
+ if (!stringi_set_is_empty (&strings))
+ {
+ const char *example = stringi_set_node_get_string (
+ stringi_set_first (&strings));
+ msg (SE, ngettext ("STRINGS specified a variable %s, but no variable "
+ "with that name was found on SAVE.",
+ "STRINGS specified %2$zu variables, including %1$s, "
+ "whose names were not found on SAVE.",
+ stringi_set_count (&strings)),
+ example, stringi_set_count (&strings));
+ ok = false;
+ }
+ stringi_set_destroy (&strings);
+ string_array_destroy (&names);
+
+ if (!ok)
+ {
+ gsl_matrix_free (m);
+ dict_unref (dict);
+ return;
+ }
+
+ struct casewriter *writer = any_writer_open (save->outfile, dict);
+ if (!writer)
+ {
+ gsl_matrix_free (m);
+ dict_unref (dict);
+ return;
+ }
+
+ const struct caseproto *proto = dict_get_proto (dict);
+ for (size_t y = 0; y < m->size1; y++)
+ {
+ struct ccase *c = case_create (proto);
+ for (size_t x = 0; x < m->size2; x++)
+ {
+ double d = gsl_matrix_get (m, y, x);
+ int width = caseproto_get_width (proto, x);
+ union value *value = case_data_rw_idx (c, x);
+ if (width == 0)
+ value->f = d;
+ else
+ memcpy (value->s, &d, width);
+ }
+ casewriter_write (writer, c);
+ }
+ casewriter_destroy (writer);
+
+ gsl_matrix_free (m);
+ dict_unref (dict);
+}
+\f
+static struct matrix_cmd *
+matrix_parse_read (struct matrix_state *s)
+{
+ struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
+ *cmd = (struct matrix_cmd) {
+ .type = MCMD_READ,
+ .read = { .format = FMT_F },
+ };
+
+ struct file_handle *fh = NULL;
+ char *encoding = NULL;
+ struct read_command *read = &cmd->read;
+ read->dst = matrix_lvalue_parse (s);
+ if (!read->dst)
+ goto error;
+
+ int by = 0;
+ int repetitions = 0;
+ int record_width = 0;
+ bool seen_format = false;
+ while (lex_match (s->lexer, T_SLASH))
+ {
+ if (lex_match_id (s->lexer, "FILE"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+
+ fh_unref (fh);
+ fh = fh_parse (s->lexer, FH_REF_FILE, NULL);
+ if (!fh)
+ goto error;
+ }
+ else if (lex_match_id (s->lexer, "ENCODING"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+ if (!lex_force_string (s->lexer))
+ goto error;
+
+ free (encoding);
+ encoding = ss_xstrdup (lex_tokss (s->lexer));
+
+ lex_get (s->lexer);
+ }
+ else if (lex_match_id (s->lexer, "FIELD"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+
+ if (!lex_force_int_range (s->lexer, "FIELD", 1, INT_MAX))
+ goto error;
+ read->c1 = lex_integer (s->lexer);
+ lex_get (s->lexer);
+ if (!lex_force_match (s->lexer, T_TO)
+ || !lex_force_int_range (s->lexer, "TO", read->c1, INT_MAX))
+ goto error;
+ read->c2 = lex_integer (s->lexer) + 1;
+ lex_get (s->lexer);
+
+ record_width = read->c2 - read->c1;
+ if (lex_match (s->lexer, T_BY))
+ {
+ if (!lex_force_int_range (s->lexer, "BY", 1,
+ read->c2 - read->c1))
+ goto error;
+ by = lex_integer (s->lexer);
+ lex_get (s->lexer);
+
+ if (record_width % by)
+ {
+ msg (SE, _("BY %d does not evenly divide record width %d."),
+ by, record_width);
+ goto error;
+ }
+ }
+ else
+ by = 0;
+ }
+ else if (lex_match_id (s->lexer, "SIZE"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+ read->size = matrix_parse_exp (s);
+ if (!read->size)
+ goto error;
+ }
+ else if (lex_match_id (s->lexer, "MODE"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+ if (lex_match_id (s->lexer, "RECTANGULAR"))
+ read->symmetric = false;
+ else if (lex_match_id (s->lexer, "SYMMETRIC"))
+ read->symmetric = true;
+ else
+ {
+ lex_error_expecting (s->lexer, "RECTANGULAR", "SYMMETRIC");
+ goto error;
+ }
+ }
+ else if (lex_match_id (s->lexer, "REREAD"))
+ read->reread = true;
+ else if (lex_match_id (s->lexer, "FORMAT"))
+ {
+ if (seen_format)
+ {
+ lex_sbc_only_once ("FORMAT");
+ goto error;
+ }
+ seen_format = true;
+
+ lex_match (s->lexer, T_EQUALS);
+
+ if (lex_token (s->lexer) != T_STRING && !lex_force_id (s->lexer))
+ goto error;
+
+ const char *p = lex_tokcstr (s->lexer);
+ if (c_isdigit (p[0]))
+ {
+ repetitions = atoi (p);
+ p += strspn (p, "0123456789");
+ if (!fmt_from_name (p, &read->format))
+ {
+ lex_error (s->lexer, _("Unknown format %s."), p);
+ goto error;
+ }
+ lex_get (s->lexer);
+ }
+ else if (!fmt_from_name (p, &read->format))
+ {
+ struct fmt_spec format;
+ if (!parse_format_specifier (s->lexer, &format))
+ goto error;
+ read->format = format.type;
+ read->w = format.w;
+ read->d = format.d;
+ }
+ }
+ else
+ {
+ lex_error_expecting (s->lexer, "FILE", "FIELD", "MODE",
+ "REREAD", "FORMAT");
+ goto error;
+ }
+ }
+
+ if (!read->c1)
+ {
+ lex_sbc_missing ("FIELD");
+ goto error;
+ }
+
+ if (!read->dst->n_indexes && !read->size)
+ {
+ msg (SE, _("SIZE is required for reading data into a full matrix "
+ "(as opposed to a submatrix)."));
+ goto error;
+ }
+
+ if (!fh)
+ {
+ if (s->prev_read_file)
+ fh = fh_ref (s->prev_read_file);
+ else
+ {
+ lex_sbc_missing ("FILE");
+ goto error;
+ }
+ }
+ fh_unref (s->prev_read_file);
+ s->prev_read_file = fh_ref (fh);
+
+ read->rf = read_file_create (s, fh);
+ if (encoding)
+ {
+ free (read->rf->encoding);
+ read->rf->encoding = encoding;
+ encoding = NULL;
+ }
+
+ /* Field width may be specified in multiple ways:
+
+ 1. BY on FIELD.
+ 2. The format on FORMAT.
+ 3. The repetition factor on FORMAT.
+
+ (2) and (3) are mutually exclusive.
+
+ If more than one of these is present, they must agree. If none of them is
+ present, then free-field format is used.
+ */
+ if (repetitions > record_width)
+ {
+ msg (SE, _("%d repetitions cannot fit in record width %d."),
+ repetitions, record_width);
+ goto error;
+ }
+ int w = (repetitions ? record_width / repetitions
+ : read->w ? read->w
+ : by);
+ if (by && w != by)
+ {
+ if (repetitions)
+ msg (SE, _("FORMAT specifies %d repetitions with record width %d, "
+ "which implies field width %d, "
+ "but BY specifies field width %d."),
+ repetitions, record_width, w, by);
+ else
+ msg (SE, _("FORMAT specifies field width %d but BY specifies %d."),
+ w, by);
+ goto error;
+ }
+ read->w = w;
+ return cmd;
+
+error:
+ matrix_cmd_destroy (cmd);
+ free (encoding);
+ return NULL;
+}
+
+static void
+matrix_read_set_field (struct read_command *read, struct dfm_reader *reader,
+ gsl_matrix *m, struct substring p, size_t y, size_t x)
+{
+ const char *input_encoding = dfm_reader_get_encoding (reader);
+ union value v;
+ char *error = data_in (p, input_encoding, read->format,
+ settings_get_fmt_settings (), &v, 0, NULL);
+ /* XXX report error if value is missing */
+ if (error)
+ msg (SW, _("GET parse error (%.*s): %s"), (int) p.length, p.string, error);
+ else
+ {
+ gsl_matrix_set (m, y, x, v.f);
+ if (read->symmetric && x != y)
+ gsl_matrix_set (m, x, y, v.f);
+ }
+}
+
+static bool
+matrix_read_line (struct read_command *read, struct dfm_reader *reader,
+ struct substring *line)
+{
+ if (dfm_eof (reader))
+ {
+ msg (SE, _("Unexpected end of file reading matrix data."));
+ return false;
+ }
+ dfm_expand_tabs (reader);
+ *line = ss_substr (dfm_get_record (reader),
+ read->c1 - 1, read->c2 - read->c1);
+ return true;
+}
+
+static void
+matrix_read (struct read_command *read, struct dfm_reader *reader,
+ gsl_matrix *m)
+{
+ for (size_t y = 0; y < m->size1; y++)
+ {
+ size_t nx = read->symmetric ? y + 1 : m->size2;
+
+ struct substring line = ss_empty ();
+ for (size_t x = 0; x < nx; x++)
+ {
+ struct substring p;
+ if (!read->w)
+ {
+ for (;;)
+ {
+ ss_ltrim (&line, ss_cstr (" ,"));
+ if (!ss_is_empty (line))
+ break;
+ if (!matrix_read_line (read, reader, &line))
+ return;
+ dfm_forward_record (reader);
+ }
+
+ ss_get_bytes (&line, ss_cspan (line, ss_cstr (" ,")), &p);
+ }
+ else
+ {
+ if (!matrix_read_line (read, reader, &line))
+ return;
+ size_t fields_per_line = (read->c2 - read->c1) / read->w;
+ int f = x % fields_per_line;
+ if (f == fields_per_line - 1)
+ dfm_forward_record (reader);
+
+ p = ss_substr (line, read->w * f, read->w);
+ }
+
+ matrix_read_set_field (read, reader, m, p, y, x);
+ }
+
+ if (read->w)
+ dfm_forward_record (reader);
+ else
+ {
+ ss_ltrim (&line, ss_cstr (" ,"));
+ if (!ss_is_empty (line))
+ msg (SW, _("Trailing garbage on line \"%.*s\""),
+ (int) line.length, line.string);
+ }
+ }
+}
+
+static void
+matrix_cmd_execute_read (struct read_command *read)
+{
+ struct index_vector iv0, iv1;
+ if (!matrix_lvalue_evaluate (read->dst, &iv0, &iv1))
+ return;
+
+ size_t size[2] = { SIZE_MAX, SIZE_MAX };
+ if (read->size)
+ {
+ gsl_matrix *m = matrix_expr_evaluate (read->size);
+ if (!m)
+ return;
+
+ if (!is_vector (m))
+ {
+ msg (SE, _("SIZE must evaluate to a scalar or a 2-element vector"));
+ gsl_matrix_free (m);
+ free (iv0.indexes);
+ free (iv1.indexes);
+ return;
+ }
+
+ gsl_vector v = to_vector (m);
+ double d[2];
+ if (v.size == 1)
+ {
+ d[0] = gsl_vector_get (&v, 0);
+ d[1] = 1;
+ }
+ else if (v.size == 2)
+ {
+ d[0] = gsl_vector_get (&v, 0);
+ d[1] = gsl_vector_get (&v, 1);
+ }
+ else
+ {
+ msg (SE, _("SIZE must evaluate to a scalar or a 2-element vector"));
+ gsl_matrix_free (m);
+ free (iv0.indexes);
+ free (iv1.indexes);
+ return;
+ }
+ gsl_matrix_free (m);
+
+ if (d[0] < 0 || d[0] > SIZE_MAX || d[1] < 0 || d[1] > SIZE_MAX)
+ {
+ msg (SE, _("SIZE (%g,%g) is outside valid range."), d[0], d[1]);
+ free (iv0.indexes);
+ free (iv1.indexes);
+ return;
+ }
+
+ size[0] = d[0];
+ size[1] = d[1];
+ }
+
+ if (read->dst->n_indexes)
+ {
+ size_t submatrix_size[2];
+ if (read->dst->n_indexes == 2)
+ {
+ submatrix_size[0] = iv0.n;
+ submatrix_size[1] = iv1.n;
+ }
+ else if (read->dst->var->value->size1 == 1)
+ {
+ submatrix_size[0] = 1;
+ submatrix_size[1] = iv0.n;
+ }
+ else
+ {
+ submatrix_size[0] = iv0.n;
+ submatrix_size[1] = 1;
+ }
+
+ if (read->size)
+ {
+ if (size[0] != submatrix_size[0] || size[1] != submatrix_size[1])
+ {
+ msg (SE, _("SIZE (%zu,%zu) differs from submatrix dimensions "
+ "(%zu,%zu)."),
+ size[0], size[1],
+ submatrix_size[0], submatrix_size[1]);
+ free (iv0.indexes);
+ free (iv1.indexes);
+ return;
+ }
+ }
+ else
+ {
+ size[0] = submatrix_size[0];
+ size[1] = submatrix_size[1];
+ }
+ }
+
+ struct dfm_reader *reader = read_file_open (read->rf);
+ if (read->reread)
+ dfm_reread_record (reader, 1);
+
+ if (read->symmetric && size[0] != size[1])
+ {
+ msg (SE, _("Cannot read matrix with non-square dimensions (%zu,%zu) "
+ "using READ with MODE=SYMMETRIC."),
+ size[0], size[1]);
+ free (iv0.indexes);
+ free (iv1.indexes);
+ return;
+ }
+ gsl_matrix *tmp = gsl_matrix_calloc (size[0], size[1]);
+ matrix_read (read, reader, tmp);
+ matrix_lvalue_assign (read->dst, &iv0, &iv1, tmp);
+}
+\f
+static struct matrix_cmd *
+matrix_parse_write (struct matrix_state *s)
+{
+ struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
+ *cmd = (struct matrix_cmd) {
+ .type = MCMD_WRITE,
+ .write = { .format = FMT_F },
+ };
+
+ struct write_command *write = &cmd->write;
+ write->expression = matrix_parse_exp (s);
+ if (!write->expression)
+ goto error;
+
+ int by = 0;
+ int repetitions = 0;
+ int record_width = 0;
+ bool seen_format = false;
+ while (lex_match (s->lexer, T_SLASH))
+ {
+ if (lex_match_id (s->lexer, "OUTFILE"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+
+ fh_unref (write->outfile);
+ write->outfile = fh_parse (s->lexer, FH_REF_FILE, NULL);
+ if (!write->outfile)
+ goto error;
+ }
+ else if (lex_match_id (s->lexer, "ENCODING"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+ if (!lex_force_string (s->lexer))
+ goto error;
+
+ free (write->encoding);
+ write->encoding = ss_xstrdup (lex_tokss (s->lexer));
+
+ lex_get (s->lexer);
+ }
+ else if (lex_match_id (s->lexer, "FIELD"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+
+ if (!lex_force_int_range (s->lexer, "FIELD", 1, INT_MAX))
+ goto error;
+ write->c1 = lex_integer (s->lexer);
+ lex_get (s->lexer);
+ if (!lex_force_match (s->lexer, T_TO)
+ || !lex_force_int_range (s->lexer, "TO", write->c1, INT_MAX))
+ goto error;
+ write->c2 = lex_integer (s->lexer) + 1;
+ lex_get (s->lexer);
+
+ record_width = write->c2 - write->c1;
+ if (lex_match (s->lexer, T_BY))
+ {
+ if (!lex_force_int_range (s->lexer, "BY", 1,
+ write->c2 - write->c1))
+ goto error;
+ by = lex_integer (s->lexer);
+ lex_get (s->lexer);
+
+ if (record_width % by)
+ {
+ msg (SE, _("BY %d does not evenly divide record width %d."),
+ by, record_width);
+ goto error;
+ }
+ }
+ else
+ by = 0;
+ }
+ else if (lex_match_id (s->lexer, "MODE"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+ if (lex_match_id (s->lexer, "RECTANGULAR"))
+ write->triangular = false;
+ else if (lex_match_id (s->lexer, "TRIANGULAR"))
+ write->triangular = true;
+ else
+ {
+ lex_error_expecting (s->lexer, "RECTANGULAR", "TRIANGULAR");
+ goto error;
+ }
+ }
+ else if (lex_match_id (s->lexer, "HOLD"))
+ write->hold = true;
+ else if (lex_match_id (s->lexer, "FORMAT"))
+ {
+ if (seen_format)
+ {
+ lex_sbc_only_once ("FORMAT");
+ goto error;
+ }
+ seen_format = true;
+
+ lex_match (s->lexer, T_EQUALS);
+
+ if (lex_token (s->lexer) != T_STRING && !lex_force_id (s->lexer))
+ goto error;
+
+ const char *p = lex_tokcstr (s->lexer);
+ if (c_isdigit (p[0]))
+ {
+ repetitions = atoi (p);
+ p += strspn (p, "0123456789");
+ if (!fmt_from_name (p, &write->format))
+ {
+ lex_error (s->lexer, _("Unknown format %s."), p);
+ goto error;
+ }
+ lex_get (s->lexer);
+ }
+ else if (!fmt_from_name (p, &write->format))
+ {
+ struct fmt_spec format;
+ if (!parse_format_specifier (s->lexer, &format))
+ goto error;
+ write->format = format.type;
+ write->w = format.w;
+ write->d = format.d;
+ }
+ }
+ else
+ {
+ lex_error_expecting (s->lexer, "OUTFILE", "FIELD", "MODE",
+ "HOLD", "FORMAT");
+ goto error;
+ }
+ }
+
+ if (!write->c1)
+ {
+ lex_sbc_missing ("FIELD");
+ goto error;
+ }
+
+ if (!write->outfile)
+ {
+ if (s->prev_write_outfile)
+ write->outfile = fh_ref (s->prev_write_outfile);
+ else
+ {
+ lex_sbc_missing ("OUTFILE");
+ goto error;
+ }
+ }
+ fh_unref (s->prev_write_outfile);
+ s->prev_write_outfile = fh_ref (write->outfile);
+
+ /* Field width may be specified in multiple ways:
+
+ 1. BY on FIELD.
+ 2. The format on FORMAT.
+ 3. The repetition factor on FORMAT.
+
+ (2) and (3) are mutually exclusive.
+
+ If more than one of these is present, they must agree. If none of them is
+ present, then free-field format is used.
+ */
+ if (repetitions > record_width)
+ {
+ msg (SE, _("%d repetitions cannot fit in record width %d."),
+ repetitions, record_width);
+ goto error;
+ }
+ int w = (repetitions ? record_width / repetitions
+ : write->w ? write->w
+ : by);
+ if (by && w != by)
+ {
+ if (repetitions)
+ msg (SE, _("FORMAT specifies %d repetitions with record width %d, "
+ "which implies field width %d, "
+ "but BY specifies field width %d."),
+ repetitions, record_width, w, by);
+ else
+ msg (SE, _("FORMAT specifies field width %d but BY specifies %d."),
+ w, by);
+ goto error;
+ }
+ write->w = w;
+ return cmd;
+
+error:
+ matrix_cmd_destroy (cmd);
+ return NULL;
+}
+
+static void
+matrix_cmd_execute_write (struct write_command *write)
+{
+ gsl_matrix *m = matrix_expr_evaluate (write->expression);
+ if (!m)
+ return;
+
+ if (write->triangular && m->size1 != m->size2)
+ {
+ msg (SE, _("WRITE with MODE=TRIANGULAR requires a square matrix but "
+ "the matrix to be written has dimensions (%zu,%zu)."),
+ m->size1, m->size2);
+ gsl_matrix_free (m);
+ return;
+ }
+
+ struct dfm_writer *writer = dfm_open_writer (write->outfile, write->encoding);
+ if (!writer)
+ {
+ gsl_matrix_free (m);
+ return;
+ }
+
+ const struct fmt_settings *settings = settings_get_fmt_settings ();
+ struct fmt_spec format = {
+ .type = write->format,
+ .w = write->w ? write->w : 40,
+ .d = write->d
+ };
+ struct u8_line line = U8_LINE_INITIALIZER;
+ for (size_t y = 0; y < m->size1; y++)
+ {
+ size_t nx = write->triangular ? y + 1 : m->size2;
+ int x0 = write->c1;
+ for (size_t x = 0; x < nx; x++)
+ {
+ /* XXX string values */
+ union value v = { .f = gsl_matrix_get (m, y, x) };
+ char *s = (write->w
+ ? data_out (&v, NULL, &format, settings)
+ : data_out_stretchy (&v, NULL, &format, settings, NULL));
+ size_t len = strlen (s);
+ int width = u8_width (CHAR_CAST (const uint8_t *, s), len, UTF8);
+ if (width + x0 > write->c2)
+ {
+ dfm_put_record_utf8 (writer, line.s.ss.string, line.s.ss.length);
+ u8_line_clear (&line);
+ x0 = write->c1;
+ }
+ u8_line_put (&line, x0, x0 + width, s, len);
+ free (s);
+
+ x0 += write->w ? write->w : width + 1;
+ }
+
+ dfm_put_record_utf8 (writer, line.s.ss.string, line.s.ss.length);
+ u8_line_clear (&line);
+ }
+ u8_line_destroy (&line);
+ dfm_close_writer (writer);
+
+ gsl_matrix_free (m);
+}
+\f
+static struct matrix_cmd *
+matrix_parse_get (struct matrix_state *s)
+{
+ struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
+ *cmd = (struct matrix_cmd) {
+ .type = MCMD_GET,
+ .get = {
+ .user = { .treatment = MGET_ERROR },
+ .system = { .treatment = MGET_ERROR },
+ }
+ };
+
+ struct get_command *get = &cmd->get;
+ get->dst = matrix_lvalue_parse (s);
+ if (!get->dst)
+ goto error;
+
+ while (lex_match (s->lexer, T_SLASH))
+ {
+ if (lex_match_id (s->lexer, "FILE"))
+ {
+ if (get->variables.n)
+ {
+ lex_error (s->lexer, _("FILE must precede VARIABLES"));
+ goto error;
+ }
+ lex_match (s->lexer, T_EQUALS);
+
+ fh_unref (get->file);
+ get->file = fh_parse (s->lexer, FH_REF_FILE, s->session);
+ if (!get->file)
+ goto error;
+ }
+ else if (lex_match_id (s->lexer, "ENCODING"))
+ {
+ if (get->variables.n)
+ {
+ lex_error (s->lexer, _("ENCODING must precede VARIABLES"));
+ goto error;
+ }
+ lex_match (s->lexer, T_EQUALS);
+ if (!lex_force_string (s->lexer))
+ goto error;
+
+ free (get->encoding);
+ get->encoding = ss_xstrdup (lex_tokss (s->lexer));
+
+ lex_get (s->lexer);
+ }
+ else if (lex_match_id (s->lexer, "VARIABLES"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+
+ struct dictionary *dict = NULL;
+ if (!get->file)
+ {
+ dict = dataset_dict (s->dataset);
+ if (dict_get_var_cnt (dict) == 0)
+ {
+ lex_error (s->lexer, _("GET cannot read empty active file."));
+ goto error;
+ }
+ }
+ else
+ {
+ struct casereader *reader = any_reader_open_and_decode (
+ get->file, get->encoding, &dict, NULL);
+ if (!reader)
+ goto error;
+ casereader_destroy (reader);
+ }
+
+ struct variable **vars;
+ size_t n_vars;
+ bool ok = parse_variables (s->lexer, dict, &vars, &n_vars,
+ PV_DUPLICATE | PV_NUMERIC | PV_NO_SCRATCH);
+ if (!ok)
+ {
+ dict_unref (dict);
+ goto error;
+ }
+
+ string_array_clear (&get->variables);
+ for (size_t i = 0; i < n_vars; i++)
+ string_array_append (&get->variables, var_get_name (vars[i]));
+ free (vars);
+ dict_unref (dict);
+ }
+ else if (lex_match_id (s->lexer, "NAMES"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+ if (!lex_force_id (s->lexer))
+ goto error;
+
+ struct substring name = lex_tokss (s->lexer);
+ get->names = matrix_var_lookup (s, name);
+ if (!get->names)
+ get->names = matrix_var_create (s, name);
+ lex_get (s->lexer);
+ }
+ else if (lex_match_id (s->lexer, "MISSING"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+ if (lex_match_id (s->lexer, "ACCEPT"))
+ get->user.treatment = MGET_ACCEPT;
+ else if (lex_match_id (s->lexer, "OMIT"))
+ get->user.treatment = MGET_OMIT;
+ else if (lex_is_number (s->lexer))
+ {
+ get->user.treatment = MGET_RECODE;
+ get->user.substitute = lex_number (s->lexer);
+ lex_get (s->lexer);
+ }
+ else
+ {
+ lex_error (s->lexer, NULL);
+ goto error;
+ }
+ }
+ else if (lex_match_id (s->lexer, "SYSMIS"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+ if (lex_match_id (s->lexer, "OMIT"))
+ get->user.treatment = MGET_OMIT;
+ else if (lex_is_number (s->lexer))
+ {
+ get->user.treatment = MGET_RECODE;
+ get->user.substitute = lex_number (s->lexer);
+ lex_get (s->lexer);
+ }
+ else
+ {
+ lex_error (s->lexer, NULL);
+ goto error;
+ }
+ }
+ else
+ {
+ lex_error_expecting (s->lexer, "FILE", "VARIABLES", "NAMES",
+ "MISSING", "SYSMIS");
+ goto error;
+ }
+ }
+ return cmd;
+
+error:
+ matrix_cmd_destroy (cmd);
+ return NULL;
+}
+
+static void
+matrix_cmd_execute_get (struct get_command *get)
+{
+ assert (get->file); /* XXX */
+
+ struct dictionary *dict;
+ struct casereader *reader = any_reader_open_and_decode (
+ get->file, get->encoding, &dict, NULL);
+ if (!reader)
+ return;
+
+ const struct variable **vars = xnmalloc (
+ get->variables.n ? get->variables.n : dict_get_var_cnt (dict),
+ sizeof *vars);
+ size_t n_vars = 0;
+
+ if (get->variables.n)
+ {
+ for (size_t i = 0; i < get->variables.n; i++)
+ {
+ const char *name = get->variables.strings[i];
+ const struct variable *var = dict_lookup_var (dict, name);
+ if (!var)
+ {
+ msg (SE, _("GET: Data file does not contain variable %s."),
+ name);
+ dict_unref (dict);
+ free (vars);
+ return;
+ }
+ if (!var_is_numeric (var))
+ {
+ msg (SE, _("GET: Variable %s is not numeric."), name);
+ dict_unref (dict);
+ free (vars);
+ return;
+ }
+ vars[n_vars++] = var;
+ }
+ }
+ else
+ {
+ for (size_t i = 0; i < dict_get_var_cnt (dict); i++)
+ {
+ const struct variable *var = dict_get_var (dict, i);
+ if (!var_is_numeric (var))
+ {
+ msg (SE, _("GET: Variable %s is not numeric."),
+ var_get_name (var));
+ dict_unref (dict);
+ free (vars);
+ return;
+ }
+ vars[n_vars++] = var;
+ }
+ }
+
+ size_t n_rows = 0;
+ gsl_matrix *m = gsl_matrix_alloc (4, n_vars);
+ long long int casenum = 1;
+ bool error = false;
+ for (struct ccase *c = casereader_read (reader); c;
+ c = casereader_read (reader), casenum++)
+ {
+ if (n_rows >= m->size1)
+ {
+ gsl_matrix *p = gsl_matrix_alloc (m->size1 * 2, n_vars);
+ for (size_t y = 0; y < n_rows; y++)
+ for (size_t x = 0; x < n_vars; x++)
+ gsl_matrix_set (p, y, x, gsl_matrix_get (m, y, x));
+ gsl_matrix_free (m);
+ m = p;
+ }
+
+ bool keep = true;
+ for (size_t x = 0; x < n_vars; x++)
+ {
+ const struct variable *var = vars[x];
+ double d = case_num (c, var);
+ if (d == SYSMIS)
+ {
+ if (get->system.treatment == MGET_RECODE)
+ d = get->system.substitute;
+ else if (get->system.treatment == MGET_OMIT)
+ keep = false;
+ else
+ {
+ msg (SE, _("GET: Variable %s in case %lld "
+ "is system-missing."),
+ var_get_name (var), casenum);
+ error = true;
+ }
+ }
+ else if (var_is_num_missing (var, d, MV_USER))
+ {
+ if (get->user.treatment == MGET_RECODE)
+ d = get->user.substitute;
+ else if (get->user.treatment == MGET_OMIT)
+ keep = false;
+ else if (get->user.treatment != MGET_ACCEPT)
+ {
+ msg (SE, _("GET: Variable %s in case %lld has user-missing "
+ "value %g."),
+ var_get_name (var), casenum, d);
+ error = true;
+ }
+ }
+ gsl_matrix_set (m, n_rows, x, d);
+ }
+ case_unref (c);
+ if (error)
+ break;
+ if (keep)
+ n_rows++;
+ }
+ casereader_destroy (reader);
+ if (!error)
+ {
+ m->size1 = n_rows;
+ matrix_lvalue_evaluate_and_assign (get->dst, m);
+ }
+ else
+ gsl_matrix_free (m);
+ dict_unref (dict);
+ free (vars);
+}
+\f
+static const char *
+match_rowtype (struct lexer *lexer)
+{
+ static const char *rowtypes[] = {
+ "COV", "CORR", "MEAN", "STDDEV", "N", "COUNT"
+ };
+ size_t n_rowtypes = sizeof rowtypes / sizeof *rowtypes;
+
+ for (size_t i = 0; i < n_rowtypes; i++)
+ if (lex_match_id (lexer, rowtypes[i]))
+ return rowtypes[i];
+
+ lex_error_expecting_array (lexer, rowtypes, n_rowtypes);
+ return NULL;
+}
+
+static bool
+parse_var_names (struct lexer *lexer, struct string_array *sa)
+{
+ lex_match (lexer, T_EQUALS);
+
+ string_array_clear (sa);
+
+ struct dictionary *dict = dict_create (get_default_encoding ());
+ dict_create_var_assert (dict, "ROWTYPE_", 8);
+ dict_create_var_assert (dict, "VARNAME_", 8);
+ char **names;
+ size_t n_names;
+ bool ok = parse_DATA_LIST_vars (lexer, dict, &names, &n_names,
+ PV_NO_DUPLICATE | PV_NO_SCRATCH);
+ dict_unref (dict);
+
+ if (ok)
+ {
+ string_array_clear (sa);
+ sa->strings = names;
+ sa->n = sa->allocated = n_names;
+ }
+ return ok;
+}
+
+static void
+msave_common_uninit (struct msave_common *common)
+{
+ if (common)
+ {
+ fh_unref (common->outfile);
+ string_array_destroy (&common->variables);
+ string_array_destroy (&common->fnames);
+ string_array_destroy (&common->snames);
+ }
+}
+
+static bool
+compare_variables (const char *keyword,
+ const struct string_array *new,
+ const struct string_array *old)
+{
+ if (new->n)
+ {
+ if (!old->n)
+ {
+ msg (SE, _("%s may only be specified on MSAVE if it was specified "
+ "on the first MSAVE within MATRIX."), keyword);
+ return false;
+ }
+ else if (!string_array_equal_case (old, new))
+ {
+ msg (SE, _("%s must specify the same variables each time within "
+ "a given MATRIX."), keyword);
+ return false;
+ }
+ }
+ return true;
+}
+
+static struct matrix_cmd *
+matrix_parse_msave (struct matrix_state *s)
+{
+ struct msave_common common = { .outfile = NULL };
+ struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
+ *cmd = (struct matrix_cmd) { .type = MCMD_MSAVE, .msave = { .expr = NULL } };
+
+ struct msave_command *msave = &cmd->msave;
+ if (lex_token (s->lexer) == T_ID)
+ msave->varname_ = ss_xstrdup (lex_tokss (s->lexer));
+ msave->expr = matrix_parse_exp (s);
+ if (!msave->expr)
+ return NULL;
+
+ while (lex_match (s->lexer, T_SLASH))
+ {
+ if (lex_match_id (s->lexer, "TYPE"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+
+ msave->rowtype = match_rowtype (s->lexer);
+ if (!msave->rowtype)
+ goto error;
+ }
+ else if (lex_match_id (s->lexer, "OUTFILE"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+
+ fh_unref (common.outfile);
+ common.outfile = fh_parse (s->lexer, FH_REF_FILE, NULL);
+ if (!common.outfile)
+ goto error;
+ }
+ else if (lex_match_id (s->lexer, "VARIABLES"))
+ {
+ if (!parse_var_names (s->lexer, &common.variables))
+ goto error;
+ }
+ else if (lex_match_id (s->lexer, "FNAMES"))
+ {
+ if (!parse_var_names (s->lexer, &common.fnames))
+ goto error;
+ }
+ else if (lex_match_id (s->lexer, "SNAMES"))
+ {
+ if (!parse_var_names (s->lexer, &common.snames))
+ goto error;
+ }
+ else if (lex_match_id (s->lexer, "SPLIT"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+
+ matrix_expr_destroy (msave->splits);
+ msave->splits = matrix_parse_exp (s);
+ if (!msave->splits)
+ goto error;
+ }
+ else if (lex_match_id (s->lexer, "FACTOR"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+
+ matrix_expr_destroy (msave->factors);
+ msave->factors = matrix_parse_exp (s);
+ if (!msave->factors)
+ goto error;
+ }
+ else
+ {
+ lex_error_expecting (s->lexer, "TYPE", "OUTFILE", "VARIABLES",
+ "FNAMES", "SNAMES", "SPLIT", "FACTOR");
+ goto error;
+ }
+ }
+ if (!msave->rowtype)
+ {
+ lex_sbc_missing ("TYPE");
+ goto error;
+ }
+ common.has_splits = msave->splits || common.snames.n;
+ common.has_factors = msave->factors || common.fnames.n;
+
+ struct msave_common *c = s->common ? s->common : &common;
+ if (c->fnames.n && !msave->factors)
+ {
+ msg (SE, _("FNAMES requires FACTOR."));
+ goto error;
+ }
+ if (c->snames.n && !msave->splits)
+ {
+ msg (SE, _("SNAMES requires SPLIT."));
+ goto error;
+ }
+ if (c->has_factors && !common.has_factors)
+ {
+ msg (SE, _("%s is required because it was present on the first "
+ "MSAVE in this MATRIX command."), "FACTOR");
+ goto error;
+ }
+ if (c->has_splits && !common.has_splits)
+ {
+ msg (SE, _("%s is required because it was present on the first "
+ "MSAVE in this MATRIX command."), "SPLIT");
+ goto error;
+ }
+
+ if (!s->common)
+ {
+ if (!common.outfile)
+ {
+ lex_sbc_missing ("OUTFILE");
+ goto error;
+ }
+ s->common = xmemdup (&common, sizeof common);
+ }
+ else
+ {
+ if (common.outfile)
+ {
+ bool same = common.outfile == s->common->outfile;
+ fh_unref (common.outfile);
+ if (!same)
+ {
+ msg (SE, _("OUTFILE must name the same file on each MSAVE "
+ "within a single MATRIX command."));
+ goto error;
+ }
+ }
+ if (!compare_variables ("VARIABLES",
+ &common.variables, &s->common->variables)
+ || !compare_variables ("FNAMES", &common.fnames, &s->common->fnames)
+ || !compare_variables ("SNAMES", &common.snames, &s->common->snames))
+ goto error;
+ msave_common_uninit (&common);
+ }
+ msave->common = s->common;
+ if (!msave->varname_)
+ msave->varname_ = xasprintf ("MAT%zu", ++s->common->n_varnames);
+ return cmd;
+
+error:
+ msave_common_uninit (&common);
+ matrix_cmd_destroy (cmd);
+ return NULL;
+}
+
+static gsl_vector *
+matrix_expr_evaluate_vector (struct matrix_expr *e, const char *name)
+{
+ gsl_matrix *m = matrix_expr_evaluate (e);
+ if (!m)
+ return NULL;
+
+ if (!is_vector (m))
+ {
+ msg (SE, _("%s expression must evaluate to vector, not a matrix with "
+ "dimensions (%zu,%zu)."),
+ name, m->size1, m->size2);
+ gsl_matrix_free (m);
+ return NULL;
+ }
+
+ return matrix_to_vector (m);
+}
+
+static const char *
+msave_add_vars (struct dictionary *d, const struct string_array *vars)
+{
+ for (size_t i = 0; i < vars->n; i++)
+ if (!dict_create_var (d, vars->strings[i], 0))
+ return vars->strings[i];
+ return NULL;
+}
+
+static struct dictionary *
+msave_create_dict (const struct msave_common *common)
+{
+ struct dictionary *dict = dict_create (get_default_encoding ());
+
+ const char *dup_split = msave_add_vars (dict, &common->snames);
+ if (dup_split)
+ {
+ msg (SE, _("Duplicate SPLIT variable name %s."), dup_split);
+ goto error;
+ }
+
+ dict_create_var_assert (dict, "ROWTYPE_", 8);
+
+ const char *dup_factor = msave_add_vars (dict, &common->fnames);
+ if (dup_factor)
+ {
+ msg (SE, _("Duplicate or invalid FACTOR variable name %s."), dup_factor);
+ goto error;
+ }
+
+ dict_create_var_assert (dict, "VARNAME_", 8);
+
+ const char *dup_var = msave_add_vars (dict, &common->variables);
+ if (dup_var)
+ {
+ msg (SE, _("Duplicate or invalid variable name %s."), dup_var);
+ goto error;
+ }
+
+ return dict;
+
+error:
+ dict_unref (dict);
+ return NULL;
+}
+
+static void
+matrix_cmd_execute_msave (struct msave_command *msave)
+{
+ struct msave_common *common = msave->common;
+ gsl_matrix *m = NULL;
+ gsl_vector *factors = NULL;
+ gsl_vector *splits = NULL;
+
+ m = matrix_expr_evaluate (msave->expr);
+ if (!m)
+ goto error;
+
+ if (!common->variables.n)
+ for (size_t i = 0; i < m->size2; i++)
+ string_array_append_nocopy (&common->variables,
+ xasprintf ("COL%zu", i + 1));
+
+ if (m->size2 != common->variables.n)
+ {
+ msg (SE, _("Matrix on MSAVE has %zu columns instead of required %zu."),
+ m->size2, common->variables.n);
+ goto error;
+ }
+
+ if (msave->factors)
+ {
+ factors = matrix_expr_evaluate_vector (msave->factors, "FACTOR");
+ if (!factors)
+ goto error;
+
+ if (!common->fnames.n)
+ for (size_t i = 0; i < factors->size; i++)
+ string_array_append_nocopy (&common->fnames,
+ xasprintf ("FAC%zu", i + 1));
+
+ if (factors->size != common->fnames.n)
+ {
+ msg (SE, _("There are %zu factor variables, "
+ "but %zu split values were supplied."),
+ common->fnames.n, factors->size);
+ goto error;
+ }
+ }
+
+ if (msave->splits)
+ {
+ splits = matrix_expr_evaluate_vector (msave->splits, "SPLIT");
+ if (!splits)
+ goto error;
+
+ if (!common->fnames.n)
+ for (size_t i = 0; i < splits->size; i++)
+ string_array_append_nocopy (&common->fnames,
+ xasprintf ("SPL%zu", i + 1));
+
+ if (splits->size != common->fnames.n)
+ {
+ msg (SE, _("There are %zu split variables, "
+ "but %zu split values were supplied."),
+ common->fnames.n, splits->size);
+ goto error;
+ }
+ }
+
+ if (!common->writer)
+ {
+ struct dictionary *dict = msave_create_dict (common);
+ if (!dict)
+ goto error;
+
+ common->writer = any_writer_open (common->outfile, dict);
+ if (!common->writer)
+ {
+ dict_unref (dict);
+ goto error;
+ }
+
+ common->dict = dict;
+ }
+
+ for (size_t y = 0; y < m->size1; y++)
+ {
+ struct ccase *c = case_create (dict_get_proto (common->dict));
+ size_t idx = 0;
+
+ /* Split variables */
+ if (splits)
+ for (size_t i = 0; i < splits->size; i++)
+ case_data_rw_idx (c, idx++)->f = gsl_vector_get (splits, i);
+
+ /* ROWTYPE_. */
+ buf_copy_str_rpad (CHAR_CAST (char *, case_data_rw_idx (c, idx++)->s), 8,
+ msave->rowtype, ' ');
+
+ /* Factors. */
+ if (factors)
+ for (size_t i = 0; i < factors->size; i++)
+ *case_num_rw_idx (c, idx++) = gsl_vector_get (factors, i);
+
+ /* VARNAME_. */
+ buf_copy_str_rpad (CHAR_CAST (char *, case_data_rw_idx (c, idx++)->s), 8,
+ msave->varname_, ' ');
+
+ /* Continuous variables. */
+ for (size_t x = 0; x < m->size2; x++)
+ case_data_rw_idx (c, idx++)->f = gsl_matrix_get (m, y, x);
+ casewriter_write (common->writer, c);
+ }
+
+error:
+ gsl_matrix_free (m);
+ gsl_vector_free (factors);
+ gsl_vector_free (splits);
+}
+\f
+static struct matrix_cmd *
+matrix_parse_mget (struct matrix_state *s)
+{
+ struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
+ *cmd = (struct matrix_cmd) { .type = MCMD_MGET, .mget = { .state = s } };
+
+ struct mget_command *mget = &cmd->mget;
+
+ for (;;)
+ {
+ if (lex_match_id (s->lexer, "FILE"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+
+ fh_unref (mget->file);
+ mget->file = fh_parse (s->lexer, FH_REF_FILE, s->session);
+ if (!mget->file)
+ goto error;
+ }
+ else if (lex_match_id (s->lexer, "TYPE"))
+ {
+ lex_match (s->lexer, T_EQUALS);
+ while (lex_token (s->lexer) != T_SLASH
+ && lex_token (s->lexer) != T_ENDCMD)
+ {
+ const char *rowtype = match_rowtype (s->lexer);
+ if (!rowtype)
+ goto error;
+
+ stringi_set_insert (&mget->rowtypes, rowtype);
+ }
+ }
+ else
+ {
+ lex_error_expecting (s->lexer, "FILE", "TYPE");
+ goto error;
+ }
+ if (lex_token (s->lexer) == T_ENDCMD)
+ break;
+
+ if (!lex_force_match (s->lexer, T_SLASH))
+ goto error;
+ }
+ return cmd;
+
+error:
+ matrix_cmd_destroy (cmd);
+ return NULL;
+}
+
+static const struct variable *
+get_a8_var (const struct dictionary *d, const char *name)
+{
+ const struct variable *v = dict_lookup_var (d, name);
+ if (!v)
+ {
+ msg (SE, _("Matrix data file lacks %s variable."), name);
+ return NULL;
+ }
+ if (var_get_width (v) != 8)
+ {
+ msg (SE, _("%s variable in matrix data file must be "
+ "8-byte string, but it has width %d."),
+ name, var_get_width (v));
+ return NULL;
+ }
+ return v;
+}
+
+static bool
+is_rowtype (const union value *v, const char *rowtype)
+{
+ struct substring vs = ss_buffer (CHAR_CAST (char *, v->s), 8);
+ ss_rtrim (&vs, ss_cstr (" "));
+ return ss_equals_case (vs, ss_cstr (rowtype));
+}
+
+static void
+matrix_mget_commit_var (struct ccase **rows, size_t n_rows,
+ const struct dictionary *d,
+ const struct variable *rowtype_var,
+ struct matrix_state *s, size_t si, size_t fi,
+ size_t cs, size_t cn)
+{
+ if (!n_rows)
+ return;
+
+ const union value *rowtype_ = case_data (rows[0], rowtype_var);
+ const char *name_prefix = (is_rowtype (rowtype_, "COV") ? "CV"
+ : is_rowtype (rowtype_, "CORR") ? "CR"
+ : is_rowtype (rowtype_, "MEAN") ? "MN"
+ : is_rowtype (rowtype_, "STDDEV") ? "SD"
+ : is_rowtype (rowtype_, "N") ? "NC"
+ : "CN");
+
+ struct string name = DS_EMPTY_INITIALIZER;
+ ds_put_cstr (&name, name_prefix);
+ if (fi > 0)
+ ds_put_format (&name, "F%zu", fi);
+ if (si > 0)
+ ds_put_format (&name, "S%zu", si);
+
+ struct matrix_var *mv = matrix_var_lookup (s, ds_ss (&name));
+ if (!mv)
+ mv = matrix_var_create (s, ds_ss (&name));
+ else if (mv->value)
+ {
+ msg (SW, _("Matrix data file contains variable with existing name %s."),
+ ds_cstr (&name));
+ goto exit;
+ }
+
+ gsl_matrix *m = gsl_matrix_alloc (n_rows, cn);
+ size_t n_missing = 0;
+ for (size_t y = 0; y < n_rows; y++)
+ {
+ for (size_t x = 0; x < cn; x++)
+ {
+ struct variable *var = dict_get_var (d, cs + x);
+ double value = case_num (rows[y], var);
+ if (var_is_num_missing (var, value, MV_ANY))
+ {
+ n_missing++;
+ value = 0.0;
+ }
+ gsl_matrix_set (m, y, x, value);
+ }
+ }
+
+ if (n_missing)
+ msg (SE, ngettext ("Matrix data file variable %s contains a missing "
+ "value, which was treated as zero.",
+ "Matrix data file variable %s contains %zu missing "
+ "values, which were treated as zero.", n_missing),
+ ds_cstr (&name), n_missing);
+ mv->value = m;
+
+exit:
+ ds_destroy (&name);
+ for (size_t y = 0; y < n_rows; y++)
+ case_unref (rows[y]);
+}
+
+static bool
+var_changed (const struct ccase *ca, const struct ccase *cb,
+ const struct variable *var)
+{
+ return !value_equal (case_data (ca, var), case_data (cb, var),
+ var_get_width (var));
+}
+
+static bool
+vars_changed (const struct ccase *ca, const struct ccase *cb,
+ const struct dictionary *d,
+ size_t first_var, size_t n_vars)
+{
+ for (size_t i = 0; i < n_vars; i++)
+ {
+ const struct variable *v = dict_get_var (d, first_var + i);
+ if (var_changed (ca, cb, v))
+ return true;
+ }
+ return false;
+}
+
+static void
+matrix_cmd_execute_mget (struct mget_command *mget)
+{
+ struct dictionary *d;
+ struct casereader *r = any_reader_open_and_decode (mget->file, "UTF-8",
+ &d, NULL);
+ if (!r)
+ return;
+
+ const struct variable *rowtype_ = get_a8_var (d, "ROWTYPE_");
+ const struct variable *varname_ = get_a8_var (d, "VARNAME_");
+ if (!rowtype_ || !varname_)
+ goto exit;
+
+ if (var_get_dict_index (rowtype_) >= var_get_dict_index (varname_))
+ {
+ msg (SE, _("ROWTYPE_ must precede VARNAME_ in matrix data file."));
+ goto exit;
+ }
+ if (var_get_dict_index (varname_) + 1 >= dict_get_var_cnt (d))
+ {
+ msg (SE, _("Matrix data file contains no continuous variables."));
+ goto exit;
+ }
+
+ for (size_t i = 0; i < dict_get_var_cnt (d); i++)
+ {
+ const struct variable *v = dict_get_var (d, i);
+ if (v != rowtype_ && v != varname_ && var_get_width (v) != 0)
+ {
+ msg (SE,
+ _("Matrix data file contains unexpected string variable %s."),
+ var_get_name (v));
+ goto exit;
+ }
+ }
+
+ /* SPLIT variables. */
+ size_t ss = 0;
+ size_t sn = var_get_dict_index (rowtype_);
+ struct ccase *sc = NULL;
+ size_t si = 0;
+
+ /* FACTOR variables. */
+ size_t fs = var_get_dict_index (rowtype_) + 1;
+ size_t fn = var_get_dict_index (varname_) - var_get_dict_index (rowtype_) - 1;
+ struct ccase *fc = NULL;
+ size_t fi = 0;
+
+ /* Continuous variables. */
+ size_t cs = var_get_dict_index (varname_) + 1;
+ size_t cn = dict_get_var_cnt (d) - cs;
+ struct ccase *cc = NULL;
+
+ /* Matrix. */
+ struct ccase **rows = NULL;
+ size_t allocated_rows = 0;
+ size_t n_rows = 0;
+
+ struct ccase *c;
+ while ((c = casereader_read (r)) != NULL)
+ {
+ bool sd = vars_changed (sc, c, d, ss, sn);
+ bool fd = sd || vars_changed (fc, c, d, fs, fn);
+ bool md = fd || !cc || var_changed (cc, c, rowtype_) || var_changed (cc, c, varname_);
+ if (sd)
+ {
+ si++;
+ case_unref (sc);
+ sc = case_ref (c);
+ }
+ if (fd)
+ {
+ fi++;
+ case_unref (fc);
+ fc = case_ref (c);
+ }
+ if (md)
+ {
+ matrix_mget_commit_var (rows, n_rows, d, rowtype_,
+ mget->state, si, fi, cs, cn);
+ n_rows = 0;
+ case_unref (cc);
+ cc = case_ref (c);
+ }
+
+ if (n_rows >= allocated_rows)
+ rows = x2nrealloc (rows, &allocated_rows, sizeof *rows);
+ rows[n_rows++] = c;
+ }
+ matrix_mget_commit_var (rows, n_rows, d, rowtype_,
+ mget->state, si, fi, cs, cn);
+ free (rows);
+
+exit:
+ casereader_destroy (r);
+}
+\f
+static bool
+matrix_parse_dst_var (struct matrix_state *s, struct matrix_var **varp)
+{
+ if (!lex_force_id (s->lexer))
+ return false;
+
+ *varp = matrix_var_lookup (s, lex_tokss (s->lexer));
+ if (!*varp)
+ *varp = matrix_var_create (s, lex_tokss (s->lexer));
+ lex_get (s->lexer);
+ return true;
+}
+
+static struct matrix_cmd *
+matrix_parse_eigen (struct matrix_state *s)
+{
+ struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
+ *cmd = (struct matrix_cmd) {
+ .type = MCMD_EIGEN,
+ .eigen = { .expr = NULL }
+ };
+
+ struct eigen_command *eigen = &cmd->eigen;
+ if (!lex_force_match (s->lexer, T_LPAREN))
+ goto error;
+ eigen->expr = matrix_parse_expr (s);
+ if (!eigen->expr
+ || !lex_force_match (s->lexer, T_COMMA)
+ || !matrix_parse_dst_var (s, &eigen->evec)
+ || !lex_force_match (s->lexer, T_COMMA)
+ || !matrix_parse_dst_var (s, &eigen->eval)
+ || !lex_force_match (s->lexer, T_RPAREN))
+ goto error;
+
+ return cmd;
+
+error:
+ matrix_cmd_destroy (cmd);
+ return NULL;
+}
+
+static void
+matrix_cmd_execute_eigen (struct eigen_command *eigen)
+{
+ gsl_matrix *A = matrix_expr_evaluate (eigen->expr);
+ if (!A)
+ return;
+ if (!is_symmetric (A))
+ {
+ msg (SE, _("Argument of EIGEN must be symmetric."));
+ gsl_matrix_free (A);
+ return;
+ }
+
+ gsl_eigen_symmv_workspace *w = gsl_eigen_symmv_alloc (A->size1);
+ gsl_matrix *eval = gsl_matrix_alloc (A->size1, 1);
+ gsl_vector v_eval = to_vector (eval);
+ gsl_matrix *evec = gsl_matrix_alloc (A->size1, A->size2);
+ gsl_eigen_symmv (A, &v_eval, evec, w);
+ gsl_eigen_symmv_free (w);
+
+ gsl_eigen_symmv_sort (&v_eval, evec, GSL_EIGEN_SORT_VAL_DESC);
+
+ gsl_matrix_free (A);
+
+ gsl_matrix_free (eigen->eval->value);
+ eigen->eval->value = eval;
+
+ gsl_matrix_free (eigen->evec->value);
+ eigen->evec->value = evec;
+}
+\f
+static struct matrix_cmd *
+matrix_parse_setdiag (struct matrix_state *s)
+{
+ struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
+ *cmd = (struct matrix_cmd) {
+ .type = MCMD_SETDIAG,
+ .setdiag = { .dst = NULL }
+ };
+
+ struct setdiag_command *setdiag = &cmd->setdiag;
+ if (!lex_force_match (s->lexer, T_LPAREN) || !lex_force_id (s->lexer))
+ goto error;
+
+ setdiag->dst = matrix_var_lookup (s, lex_tokss (s->lexer));
+ if (!setdiag->dst)
+ {
+ lex_error (s->lexer, _("Unknown variable %s."), lex_tokcstr (s->lexer));
+ goto error;
+ }
+ lex_get (s->lexer);
+
+ if (!lex_force_match (s->lexer, T_COMMA))
+ goto error;
+
+ setdiag->expr = matrix_parse_expr (s);
+ if (!setdiag->expr)
+ goto error;
+
+ if (!lex_force_match (s->lexer, T_RPAREN))
+ goto error;
+
+ return cmd;
+
+error:
+ matrix_cmd_destroy (cmd);
+ return NULL;
+}
+
+static void
+matrix_cmd_execute_setdiag (struct setdiag_command *setdiag)
+{
+ gsl_matrix *dst = setdiag->dst->value;
+ if (!dst)
+ {
+ msg (SE, _("SETDIAG destination matrix %s is uninitialized."),
+ setdiag->dst->name);
+ return;
+ }
+
+ gsl_matrix *src = matrix_expr_evaluate (setdiag->expr);
+ if (!src)
+ return;
+
+ size_t n = MIN (dst->size1, dst->size2);
+ if (is_scalar (src))
+ {
+ double d = to_scalar (src);
+ for (size_t i = 0; i < n; i++)
+ gsl_matrix_set (dst, i, i, d);
+ }
+ else if (is_vector (src))
+ {
+ gsl_vector v = to_vector (src);
+ for (size_t i = 0; i < n && i < v.size; i++)
+ gsl_matrix_set (dst, i, i, gsl_vector_get (&v, i));
+ }
+ else
+ msg (SE, _("SETDIAG argument 2 must be a scalar or a vector but it "
+ "has dimensions (%zu,%zu)."),
+ src->size1, src->size2);
+ gsl_matrix_free (src);
+}
+\f
+static struct matrix_cmd *
+matrix_parse_svd (struct matrix_state *s)
+{
+ struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
+ *cmd = (struct matrix_cmd) {
+ .type = MCMD_SVD,
+ .svd = { .expr = NULL }
+ };
+
+ struct svd_command *svd = &cmd->svd;
+ if (!lex_force_match (s->lexer, T_LPAREN))
+ goto error;
+ svd->expr = matrix_parse_expr (s);
+ if (!svd->expr
+ || !lex_force_match (s->lexer, T_COMMA)
+ || !matrix_parse_dst_var (s, &svd->u)
+ || !lex_force_match (s->lexer, T_COMMA)
+ || !matrix_parse_dst_var (s, &svd->s)
+ || !lex_force_match (s->lexer, T_COMMA)
+ || !matrix_parse_dst_var (s, &svd->v)
+ || !lex_force_match (s->lexer, T_RPAREN))
+ goto error;
+
+ return cmd;
+
+error:
+ matrix_cmd_destroy (cmd);
+ return NULL;
+}
+
+static void
+matrix_cmd_execute_svd (struct svd_command *svd)
+{
+ gsl_matrix *m = matrix_expr_evaluate (svd->expr);
+ if (!m)
+ return;
+
+ if (m->size1 >= m->size2)
+ {
+ gsl_matrix *A = m;
+ gsl_matrix *V = gsl_matrix_alloc (A->size2, A->size2);
+ gsl_matrix *S = gsl_matrix_calloc (A->size2, A->size2);
+ gsl_vector Sv = gsl_matrix_diagonal (S).vector;
+ gsl_vector *work = gsl_vector_alloc (A->size2);
+ gsl_linalg_SV_decomp (A, V, &Sv, work);
+ gsl_vector_free (work);
+
+ matrix_var_set (svd->u, A);
+ matrix_var_set (svd->s, S);
+ matrix_var_set (svd->v, V);
+ }
+ else
+ {
+ gsl_matrix *At = gsl_matrix_alloc (m->size2, m->size1);
+ gsl_matrix_transpose_memcpy (At, m);
+ gsl_matrix *Vt = gsl_matrix_alloc (At->size2, At->size2);
+ gsl_matrix *St = gsl_matrix_calloc (At->size2, At->size2);
+ gsl_vector Stv = gsl_matrix_diagonal (St).vector;
+ gsl_vector *work = gsl_vector_alloc (At->size2);
+ gsl_linalg_SV_decomp (At, Vt, &Stv, work);
+ gsl_vector_free (work);
+
+ matrix_var_set (svd->v, At);
+ matrix_var_set (svd->s, St);
+ matrix_var_set (svd->u, Vt);
+ }
+}
+\f
+static bool
+matrix_cmd_execute (struct matrix_cmd *cmd)
+{
+ switch (cmd->type)
+ {
+ case MCMD_COMPUTE:
+ matrix_cmd_execute_compute (&cmd->compute);
+ break;
+
+ case MCMD_PRINT:
+ matrix_cmd_execute_print (&cmd->print);
+ break;
+
+ case MCMD_DO_IF:
+ return matrix_cmd_execute_do_if (&cmd->do_if);
+
+ case MCMD_LOOP:
+ matrix_cmd_execute_loop (&cmd->loop);
+ break;
+
+ case MCMD_BREAK:
+ return false;
+
+ case MCMD_DISPLAY:
+ matrix_cmd_execute_display (&cmd->display);
+ break;
+
+ case MCMD_RELEASE:
+ matrix_cmd_execute_release (&cmd->release);
+ break;
+
+ case MCMD_SAVE:
+ matrix_cmd_execute_save (&cmd->save);
+ break;
+
+ case MCMD_READ:
+ matrix_cmd_execute_read (&cmd->read);
+ break;
+
+ case MCMD_WRITE:
+ matrix_cmd_execute_write (&cmd->write);
+ break;
+
+ case MCMD_GET:
+ matrix_cmd_execute_get (&cmd->get);
+ break;
+
+ case MCMD_MSAVE:
+ matrix_cmd_execute_msave (&cmd->msave);
+ break;
+
+ case MCMD_MGET:
+ matrix_cmd_execute_mget (&cmd->mget);
+ break;
+
+ case MCMD_EIGEN:
+ matrix_cmd_execute_eigen (&cmd->eigen);
+ break;
+
+ case MCMD_SETDIAG:
+ matrix_cmd_execute_setdiag (&cmd->setdiag);
+ break;
+
+ case MCMD_SVD:
+ matrix_cmd_execute_svd (&cmd->svd);
+ break;
+ }
+
+ return true;
+}
+
+struct matrix_command_name
+ {
+ const char *name;
+ struct matrix_cmd *(*parse) (struct matrix_state *);
+ };
+
+static const struct matrix_command_name *
+matrix_parse_command_name (struct lexer *lexer)
+{
+ static const struct matrix_command_name commands[] = {
+ { "COMPUTE", matrix_parse_compute },
+ { "CALL EIGEN", matrix_parse_eigen },
+ { "CALL SETDIAG", matrix_parse_setdiag },
+ { "CALL SVD", matrix_parse_svd },
+ { "PRINT", matrix_parse_print },
+ { "DO IF", matrix_parse_do_if },
+ { "LOOP", matrix_parse_loop },
+ { "BREAK", matrix_parse_break },
+ { "READ", matrix_parse_read },
+ { "WRITE", matrix_parse_write },
+ { "GET", matrix_parse_get },
+ { "SAVE", matrix_parse_save },
+ { "MGET", matrix_parse_mget },
+ { "MSAVE", matrix_parse_msave },
+ { "DISPLAY", matrix_parse_display },
+ { "RELEASE", matrix_parse_release },
+ };
+ static size_t n = sizeof commands / sizeof *commands;
+
+ for (const struct matrix_command_name *c = commands; c < &commands[n]; c++)
+ if (lex_match_phrase (lexer, c->name))
+ return c;
+ return NULL;
+}
+
+static struct matrix_cmd *
+matrix_parse_command (struct matrix_state *s)
+{
+ size_t nesting_level = SIZE_MAX;
+
+ struct matrix_cmd *c = NULL;
+ const struct matrix_command_name *cmd = matrix_parse_command_name (s->lexer);
+ if (!cmd)
+ lex_error (s->lexer, _("Unknown matrix command."));
+ else if (!cmd->parse)
+ lex_error (s->lexer, _("Matrix command %s is not yet implemented."),
+ cmd->name);
+ else
+ {
+ nesting_level = output_open_group (
+ group_item_create_nocopy (utf8_to_title (cmd->name),
+ utf8_to_title (cmd->name)));
+ c = cmd->parse (s);
+ }
+
+ if (c)
+ lex_end_of_command (s->lexer);
+ lex_discard_rest_of_command (s->lexer);
+ if (nesting_level != SIZE_MAX)
+ output_close_groups (nesting_level);
+
+ return c;
+}
+
+int
+cmd_matrix (struct lexer *lexer, struct dataset *ds)
+{
+ if (!lex_force_match (lexer, T_ENDCMD))
+ return CMD_FAILURE;
+
+ struct matrix_state state = {
+ .session = dataset_session (ds),
+ .lexer = lexer,
+ .vars = HMAP_INITIALIZER (state.vars),
+ };
+
+ for (;;)
+ {
+ while (lex_match (lexer, T_ENDCMD))
+ continue;
+ if (lex_token (lexer) == T_STOP)
+ {
+ msg (SE, _("Unexpected end of input expecting matrix command."));
+ break;
+ }
+
+ if (lex_match_phrase (lexer, "END MATRIX"))
+ break;
+
+ struct matrix_cmd *c = matrix_parse_command (&state);
+ if (c)
+ {
+ matrix_cmd_execute (c);
+ matrix_cmd_destroy (c);
+ }
+ }
+
+ if (state.common)
+ {
+ dict_unref (state.common->dict);
+ casewriter_destroy (state.common->writer);
+ free (state.common);
+ }
+
+ return CMD_SUCCESS;
+}
projects / pspp / blobdiff