#include <config.h>
#include <gsl/gsl_blas.h>
+#include <gsl/gsl_cdf.h>
#include <gsl/gsl_eigen.h>
#include <gsl/gsl_linalg.h>
#include <gsl/gsl_matrix.h>
#include "libpspp/string-array.h"
#include "libpspp/stringi-set.h"
#include "libpspp/u8-line.h"
+#include "math/distributions.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/c-strcase.h"
+#include "gl/ftoastr.h"
#include "gl/minmax.h"
#include "gl/xsize.h"
struct string_array variables;
struct string_array fnames;
struct string_array snames;
- bool has_factors;
- bool has_splits;
size_t n_varnames;
+ /* Collects and owns factors and splits. The individual msave_command
+ structs point to these but do not own them. */
+ struct matrix_expr **factors;
+ size_t n_factors, allocated_factors;
+ struct matrix_expr **splits;
+ size_t n_splits, allocated_splits;
+
/* Execution state. */
struct dictionary *dict;
struct casewriter *writer;
char *encoding;
};
+struct write_file
+ {
+ struct file_handle *file;
+ struct dfm_writer *writer;
+ char *encoding;
+ struct u8_line *held;
+ };
+
+struct save_file
+ {
+ struct file_handle *file;
+ struct dataset *dataset;
+
+ /* Parameters from parsing the first SAVE command for 'file'. */
+ struct string_array variables;
+ struct matrix_expr *names;
+ struct stringi_set strings;
+
+ /* Results from the first (only) attempt to open this save_file. */
+ bool error;
+ struct casewriter *writer;
+ struct dictionary *dict;
+ };
+
struct matrix_state
{
struct dataset *dataset;
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;
+
+ struct file_handle *prev_write_file;
+ struct write_file **write_files;
+ size_t n_write_files;
+
+ struct file_handle *prev_save_file;
+ struct save_file **save_files;
+ size_t n_save_files;
};
static struct matrix_var *
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)
+/* The third argument to F() is a "prototype". For most prototypes, the first
+ letter (before the _) represents the return type and each other letter
+ (after the _) is an argument type. The types are:
+
+ - "m": A matrix of unrestricted dimensions.
+
+ - "d": A scalar.
+
+ - "v": A row or column vector.
+
+ - "e": Primarily for the first argument, this is a matrix with
+ unrestricted dimensions treated elementwise. Each element in the matrix
+ is passed to the implementation function separately.
+
+ The fourth argument is an optional constraints string. For this purpose the
+ first argument is named "a", the second "b", and so on. The following kinds
+ of constraints are supported. For matrix arguments, the constraints are
+ applied to each value in the matrix separately:
+
+ - "a(0,1)" or "a[0,1]": 0 < a < 1 or 0 <= a <= 1, respectively. Any
+ integer may substitute for 0 and 1. Half-open constraints (] and [) are
+ also supported.
+
+ - "ai": Restrict a to integer values.
+
+ - "a>0", "a<0", "a>=0", "a<=0".
+
+ - "a<b", "a>b", "a<=b", "a>=b".
+*/
+#define MATRIX_FUNCTIONS \
+ F(ABS, "ABS", m_e, NULL) \
+ F(ALL, "ALL", d_m, NULL) \
+ F(ANY, "ANY", d_m, NULL) \
+ F(ARSIN, "ARSIN", m_e, "a[-1,1]") \
+ F(ARTAN, "ARTAN", m_e, NULL) \
+ F(BLOCK, "BLOCK", m_any, NULL) \
+ F(CHOL, "CHOL", m_m, NULL) \
+ F(CMIN, "CMIN", m_m, NULL) \
+ F(CMAX, "CMAX", m_m, NULL) \
+ F(COS, "COS", m_e, NULL) \
+ F(CSSQ, "CSSQ", m_m, NULL) \
+ F(CSUM, "CSUM", m_m, NULL) \
+ F(DESIGN, "DESIGN", m_m, NULL) \
+ F(DET, "DET", d_m, NULL) \
+ F(DIAG, "DIAG", m_m, NULL) \
+ F(EVAL, "EVAL", m_m, NULL) \
+ F(EXP, "EXP", m_e, NULL) \
+ F(GINV, "GINV", m_m, NULL) \
+ F(GRADE, "GRADE", m_m, NULL) \
+ F(GSCH, "GSCH", m_m, NULL) \
+ F(IDENT, "IDENT", IDENT, NULL) \
+ F(INV, "INV", m_m, NULL) \
+ F(KRONEKER, "KRONEKER", m_mm, NULL) \
+ F(LG10, "LG10", m_e, "a>0") \
+ F(LN, "LN", m_e, "a>0") \
+ F(MAGIC, "MAGIC", m_d, "ai>=3") \
+ F(MAKE, "MAKE", m_ddd, NULL) \
+ F(MDIAG, "MDIAG", m_v, NULL) \
+ F(MMAX, "MMAX", d_m, NULL) \
+ F(MMIN, "MMIN", d_m, NULL) \
+ F(MOD, "MOD", m_md, NULL) \
+ F(MSSQ, "MSSQ", d_m, NULL) \
+ F(MSUM, "MSUM", d_m, NULL) \
+ F(NCOL, "NCOL", d_m, NULL) \
+ F(NROW, "NROW", d_m, NULL) \
+ F(RANK, "RANK", d_m, NULL) \
+ F(RESHAPE, "RESHAPE", m_mdd, NULL) \
+ F(RMAX, "RMAX", m_m, NULL) \
+ F(RMIN, "RMIN", m_m, NULL) \
+ F(RND, "RND", m_e, NULL) \
+ F(RNKORDER, "RNKORDER", m_m, NULL) \
+ F(RSSQ, "RSSQ", m_m, NULL) \
+ F(RSUM, "RSUM", m_m, NULL) \
+ F(SIN, "SIN", m_e, NULL) \
+ F(SOLVE, "SOLVE", m_mm, NULL) \
+ F(SQRT, "SQRT", m_e, "a>=0") \
+ F(SSCP, "SSCP", m_m, NULL) \
+ F(SVAL, "SVAL", m_m, NULL) \
+ F(SWEEP, "SWEEP", m_md, NULL) \
+ F(T, "T", m_m, NULL) \
+ F(TRACE, "TRACE", d_m, NULL) \
+ F(TRANSPOS, "TRANSPOS", m_m, NULL) \
+ F(TRUNC, "TRUNC", m_e, NULL) \
+ F(UNIFORM, "UNIFORM", m_dd, "ai>=0 bi>=0") \
+ F(PDF_BETA, "PDF.BETA", m_edd, "a[0,1] b>0 c>0") \
+ F(CDF_BETA, "CDF.BETA", m_edd, "a[0,1] b>0 c>0") \
+ F(IDF_BETA, "IDF.BETA", m_edd, "a[0,1] b>0 c>0") \
+ F(RV_BETA, "RV.BETA", d_dd, "a>0 b>0") \
+ F(NCDF_BETA, "NCDF.BETA", m_eddd, "a>=0 b>0 c>0 d>0") \
+ F(NPDF_BETA, "NCDF.BETA", m_eddd, "a>=0 b>0 c>0 d>0") \
+ F(CDF_BVNOR, "CDF.BVNOR", m_eed, "c[-1,1]") \
+ F(PDF_BVNOR, "PDF.BVNOR", m_eed, "c[-1,1]") \
+ F(CDF_CAUCHY, "CDF.CAUCHY", m_edd, "c>0") \
+ F(IDF_CAUCHY, "IDF.CAUCHY", m_edd, "a(0,1) c>0") \
+ F(PDF_CAUCHY, "PDF.CAUCHY", m_edd, "c>0") \
+ F(RV_CAUCHY, "RV.CAUCHY", d_dd, "b>0") \
+ F(CDF_CHISQ, "CDF.CHISQ", m_ed, "a>=0 b>0") \
+ F(CHICDF, "CHICDF", m_ed, "a>=0 b>0") \
+ F(IDF_CHISQ, "IDF.CHISQ", m_ed, "a[0,1) b>0") \
+ F(PDF_CHISQ, "PDF.CHISQ", m_ed, "a>=0 b>0") \
+ F(RV_CHISQ, "RV.CHISQ", d_d, "a>0") \
+ F(SIG_CHISQ, "SIG.CHISQ", m_ed, "a>=0 b>0") \
+ F(CDF_EXP, "CDF.EXP", m_ed, "a>=0 b>=0") \
+ F(IDF_EXP, "IDF.EXP", m_ed, "a[0,1) b>0") \
+ F(PDF_EXP, "PDF.EXP", m_ed, "a>=0 b>0") \
+ F(RV_EXP, "RV.EXP", d_d, "a>0") \
+ F(PDF_XPOWER, "PDF.XPOWER", m_edd, "b>0 c>=0") \
+ F(RV_XPOWER, "RV.XPOWER", d_dd, "a>0 c>=0") \
+ F(CDF_F, "CDF.F", m_edd, "a>=0 b>0 c>0") \
+ F(FCDF, "FCDF", m_edd, "a>=0 b>0 c>0") \
+ F(IDF_F, "IDF.F", m_edd, "a[0,1) b>0 c>0") \
+ F(PDF_F, "PDF.F", m_edd, "a>=0 b>0 c>0") \
+ F(RV_F, "RV.F", d_dd, "a>0 b>0") \
+ F(SIG_F, "SIG.F", m_edd, "a>=0 b>0 c>0") \
+ F(CDF_GAMMA, "CDF.GAMMA", m_edd, "a>=0 b>0 c>0") \
+ F(IDF_GAMMA, "IDF.GAMMA", m_edd, "a[0,1] b>0 c>0") \
+ F(PDF_GAMMA, "PDF.GAMMA", m_edd, "a>=0 b>0 c>0") \
+ F(RV_GAMMA, "RV.GAMMA", d_dd, "a>0 b>0") \
+ F(PDF_LANDAU, "PDF.LANDAU", m_e, NULL) \
+ F(RV_LANDAU, "RV.LANDAU", d_none, NULL) \
+ F(CDF_LAPLACE, "CDF.LAPLACE", m_edd, "c>0") \
+ F(IDF_LAPLACE, "IDF.LAPLACE", m_edd, "a(0,1) c>0") \
+ F(PDF_LAPLACE, "PDF.LAPLACE", m_edd, "c>0") \
+ F(RV_LAPLACE, "RV.LAPLACE", d_dd, "b>0") \
+ F(RV_LEVY, "RV.LEVY", d_dd, "b(0,2]") \
+ F(RV_LVSKEW, "RV.LVSKEW", d_ddd, "b(0,2] c[-1,1]") \
+ F(CDF_LOGISTIC, "CDF.LOGISTIC", m_edd, "c>0") \
+ F(IDF_LOGISTIC, "IDF.LOGISTIC", m_edd, "a(0,1) c>0") \
+ F(PDF_LOGISTIC, "PDF.LOGISTIC", m_edd, "c>0") \
+ F(RV_LOGISTIC, "RV.LOGISTIC", d_dd, "b>0") \
+ F(CDF_LNORMAL, "CDF.LNORMAL", m_edd, "a>=0 b>0 c>0") \
+ F(IDF_LNORMAL, "IDF.LNORMAL", m_edd, "a[0,1) b>0 c>0") \
+ F(PDF_LNORMAL, "PDF.LNORMAL", m_edd, "a>=0 b>0 c>0") \
+ F(RV_LNORMAL, "RV.LNORMAL", d_dd, "a>0 b>0") \
+ F(CDF_NORMAL, "CDF.NORMAL", m_edd, "c>0") \
+ F(IDF_NORMAL, "IDF.NORMAL", m_edd, "a(0,1) c>0") \
+ F(PDF_NORMAL, "PDF.NORMAL", m_edd, "c>0") \
+ F(RV_NORMAL, "RV.NORMAL", d_dd, "b>0") \
+ F(CDFNORM, "CDFNORM", m_e, NULL) \
+ F(PROBIT, "PROBIT", m_e, "a(0,1)") \
+ F(NORMAL, "NORMAL", m_e, "a>0") \
+ F(PDF_NTAIL, "PDF.NTAIL", m_edd, "b>0 c>0") \
+ F(RV_NTAIL, "RV.NTAIL", d_dd, "a>0 b>0") \
+ F(CDF_PARETO, "CDF.PARETO", m_edd, "a>=b b>0 c>0") \
+ F(IDF_PARETO, "IDF.PARETO", m_edd, "a[0,1) b>0 c>0") \
+ F(PDF_PARETO, "PDF.PARETO", m_edd, "a>=b b>0 c>0") \
+ F(RV_PARETO, "RV.PARETO", d_dd, "a>0 b>0") \
+ F(CDF_RAYLEIGH, "CDF.RAYLEIGH", m_ed, "b>0") \
+ F(IDF_RAYLEIGH, "IDF.RAYLEIGH", m_ed, "a[0,1] b>0") \
+ F(PDF_RAYLEIGH, "PDF.RAYLEIGH", m_ed, "b>0") \
+ F(RV_RAYLEIGH, "RV.RAYLEIGH", d_d, "a>0") \
+ F(PDF_RTAIL, "PDF.RTAIL", m_edd, NULL) \
+ F(RV_RTAIL, "RV.RTAIL", d_dd, NULL) \
+ F(CDF_T, "CDF.T", m_ed, "b>0") \
+ F(TCDF, "TCDF", m_ed, "b>0") \
+ F(IDF_T, "IDF.T", m_ed, "a(0,1) b>0") \
+ F(PDF_T, "PDF.T", m_ed, "b>0") \
+ F(RV_T, "RV.T", d_d, "a>0") \
+ F(CDF_T1G, "CDF.T1G", m_edd, NULL) \
+ F(IDF_T1G, "IDF.T1G", m_edd, "a(0,1)") \
+ F(PDF_T1G, "PDF.T1G", m_edd, NULL) \
+ F(RV_T1G, "RV.T1G", d_dd, NULL) \
+ F(CDF_T2G, "CDF.T2G", m_edd, NULL) \
+ F(IDF_T2G, "IDF.T2G", m_edd, "a(0,1)") \
+ F(PDF_T2G, "PDF.T2G", m_edd, NULL) \
+ F(RV_T2G, "RV.T2G", d_dd, NULL) \
+ F(CDF_UNIFORM, "CDF.UNIFORM", m_edd, "a<=c b<=c") \
+ F(IDF_UNIFORM, "IDF.UNIFORM", m_edd, "a[0,1] b<=c") \
+ F(PDF_UNIFORM, "PDF.UNIFORM", m_edd, "a<=c b<=c") \
+ F(RV_UNIFORM, "RV.UNIFORM", d_dd, "a<=b") \
+ F(CDF_WEIBULL, "CDF.WEIBULL", m_edd, "a>=0 b>0 c>0") \
+ F(IDF_WEIBULL, "IDF.WEIBULL", m_edd, "a[0,1) b>0 c>0") \
+ F(PDF_WEIBULL, "PDF.WEIBULL", m_edd, "a>=0 b>0 c>0") \
+ F(RV_WEIBULL, "RV.WEIBULL", d_dd, "a>0 b>0") \
+ F(CDF_BERNOULLI, "CDF.BERNOULLI", m_ed, "ai[0,1] b[0,1]") \
+ F(PDF_BERNOULLI, "PDF.BERNOULLI", m_ed, "ai[0,1] b[0,1]") \
+ F(RV_BERNOULLI, "RV.BERNOULLI", d_d, "a[0,1]") \
+ F(CDF_BINOM, "CDF.BINOM", m_edd, "bi>0 c[0,1]") \
+ F(PDF_BINOM, "PDF.BINOM", m_edd, "ai>=0<=b bi>0 c[0,1]") \
+ F(RV_BINOM, "RV.BINOM", d_dd, "ai>0 b[0,1]") \
+ F(CDF_GEOM, "CDF.GEOM", m_ed, "ai>=1 b[0,1]") \
+ F(PDF_GEOM, "PDF.GEOM", m_ed, "ai>=1 b[0,1]") \
+ F(RV_GEOM, "RV.GEOM", d_d, "a[0,1]") \
+ F(CDF_HYPER, "CDF.HYPER", m_eddd, "ai>=0<=d bi>0 ci>0<=b di>0<=b") \
+ F(PDF_HYPER, "PDF.HYPER", m_eddd, "ai>=0<=d bi>0 ci>0<=b di>0<=b") \
+ F(RV_HYPER, "RV.HYPER", d_ddd, "ai>0 bi>0<=a ci>0<=a") \
+ F(PDF_LOG, "PDF.LOG", m_ed, "a>=1 b(0,1]") \
+ F(RV_LOG, "RV.LOG", d_d, "a(0,1]") \
+ F(CDF_NEGBIN, "CDF.NEGBIN", m_edd, "a>=1 bi c(0,1]") \
+ F(PDF_NEGBIN, "PDF.NEGBIN", m_edd, "a>=1 bi c(0,1]") \
+ F(RV_NEGBIN, "RV.NEGBIN", d_dd, "ai b(0,1]") \
+ F(CDF_POISSON, "CDF.POISSON", m_ed, "ai>=0 b>0") \
+ F(PDF_POISSON, "PDF.POISSON", m_ed, "ai>=0 b>0") \
+ F(RV_POISSON, "RV.POISSON", d_d, "a>0")
+
+struct matrix_function_properties
+ {
+ const char *name;
+ const char *constraints;
+ };
+enum { d_none_MIN_ARGS = 0, d_none_MAX_ARGS = 0 };
+enum { d_d_MIN_ARGS = 1, d_d_MAX_ARGS = 1 };
+enum { d_dd_MIN_ARGS = 2, d_dd_MAX_ARGS = 2 };
+enum { d_ddd_MIN_ARGS = 3, d_ddd_MAX_ARGS = 3 };
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_e_MIN_ARGS = 1, m_e_MAX_ARGS = 1 };
enum { m_md_MIN_ARGS = 2, m_md_MAX_ARGS = 2 };
+enum { m_ed_MIN_ARGS = 2, m_ed_MAX_ARGS = 2 };
enum { m_mdd_MIN_ARGS = 3, m_mdd_MAX_ARGS = 3 };
+enum { m_edd_MIN_ARGS = 3, m_edd_MAX_ARGS = 3 };
+enum { m_eddd_MIN_ARGS = 4, m_eddd_MAX_ARGS = 4 };
+enum { m_eed_MIN_ARGS = 3, m_eed_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 double matrix_proto_d_none (void);
+typedef double matrix_proto_d_d (double);
+typedef double matrix_proto_d_dd (double, double);
+typedef double matrix_proto_d_dd (double, double);
+typedef double matrix_proto_d_ddd (double, double, double);
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 double matrix_proto_m_e (double);
typedef gsl_matrix *matrix_proto_m_md (gsl_matrix *, double);
+typedef double matrix_proto_m_ed (double, double);
typedef gsl_matrix *matrix_proto_m_mdd (gsl_matrix *, double, double);
+typedef double matrix_proto_m_edd (double, double, double);
+typedef double matrix_proto_m_eddd (double, double, double, double);
+typedef double matrix_proto_m_eed (double, 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;
+#define F(ENUM, STRING, PROTO, CONSTRAINTS) \
+ static matrix_proto_##PROTO matrix_eval_##ENUM;
MATRIX_FUNCTIONS
#undef F
\f
enum matrix_op
{
/* Functions. */
-#define F(NAME, PROTOTYPE) MOP_F_##NAME,
+#define F(ENUM, STRING, PROTO, CONSTRAINTS) MOP_F_##ENUM,
MATRIX_FUNCTIONS
#undef F
struct matrix_var *variable;
struct read_file *eof;
};
+
+ struct msg_location *location;
};
static void
switch (e->op)
{
-#define F(NAME, PROTOTYPE) case MOP_F_##NAME:
+#define F(ENUM, STRING, PROTO, CONSTRAINTS) case MOP_F_##ENUM:
MATRIX_FUNCTIONS
#undef F
case MOP_NEGATE:
case MOP_EOF:
break;
}
+ msg_location_destroy (e->location);
free (e);
}
.subs = xmemdup (subs, n_subs * sizeof *subs),
.n_subs = n_subs
};
+
+ for (size_t i = 0; i < n_subs; i++)
+ msg_location_merge (&e->location, subs[i]->location);
return e;
}
}
-static gsl_matrix *
-matrix_eval_ABS (gsl_matrix *m)
+static double
+matrix_eval_ABS (double d)
{
- MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
- *d = fabs (*d);
- return m;
+ return fabs (d);
}
static double
return 0.0;
}
-static gsl_matrix *
-matrix_eval_ARSIN (gsl_matrix *m)
+static double
+matrix_eval_ARSIN (double d)
{
- MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
- *d = asin (*d);
- return m;
+ return asin (d);
}
-static gsl_matrix *
-matrix_eval_ARTAN (gsl_matrix *m)
+static double
+matrix_eval_ARTAN (double d)
{
- MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
- *d = atan (*d);
- return m;
+ return atan (d);
}
static gsl_matrix *
return matrix_eval_col_extremum (m, true);
}
-static gsl_matrix *
-matrix_eval_COS (gsl_matrix *m)
+static double
+matrix_eval_COS (double d)
{
- MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
- *d = cos (*d);
- return m;
+ return cos (d);
}
static gsl_matrix *
return eval;
}
-static gsl_matrix *
-matrix_eval_EXP (gsl_matrix *m)
+static double
+matrix_eval_EXP (double d)
{
- MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
- *d = exp (*d);
- return m;
+ return exp (d);
}
/* From https://gist.github.com/turingbirds/5e99656e08dbe1324c99, where it was
return k;
}
-static gsl_matrix *
-matrix_eval_LG10 (gsl_matrix *m)
+static double
+matrix_eval_LG10 (double d)
{
- MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
- *d = log10 (*d);
- return m;
+ return log10 (d);
}
-static gsl_matrix *
-matrix_eval_LN (gsl_matrix *m)
+static double
+matrix_eval_LN (double d)
{
- MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
- *d = log (*d);
- return m;
+ return log (d);
}
static void
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);
return matrix_eval_row_extremum (m, true);
}
-static gsl_matrix *
-matrix_eval_RND (gsl_matrix *m)
+static double
+matrix_eval_RND (double d)
{
- MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
- *d = rint (*d);
- return m;
+ return rint (d);
}
struct rank
return matrix_eval_row_sum (m, false);
}
-static gsl_matrix *
-matrix_eval_SIN (gsl_matrix *m)
+static double
+matrix_eval_SIN (double d)
{
- MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
- *d = sin (*d);
- return m;
+ return sin (d);
}
static gsl_matrix *
return x;
}
-static gsl_matrix *
-matrix_eval_SQRT (gsl_matrix *m)
+static double
+matrix_eval_SQRT (double d)
{
- 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;
+ return sqrt (d);
}
static gsl_matrix *
}
}
-static gsl_matrix *
-matrix_eval_TRUNC (gsl_matrix *m)
+static double
+matrix_eval_TRUNC (double d)
{
- MATRIX_FOR_ALL_ELEMENTS (d, y, x, m)
- *d = trunc (*d);
- return m;
+ return trunc (d);
}
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))))
return m;
}
-struct matrix_function
- {
- const char *name;
- enum matrix_op op;
- size_t min_args, max_args;
- };
+static double
+matrix_eval_PDF_BETA (double x, double a, double b)
+{
+ return gsl_ran_beta_pdf (x, a, b);
+}
-static struct matrix_expr *matrix_parse_expr (struct matrix_state *);
+static double
+matrix_eval_CDF_BETA (double x, double a, double b)
+{
+ return gsl_cdf_beta_P (x, a, b);
+}
-static const struct matrix_function *
-matrix_parse_function_name (const char *token)
+static double
+matrix_eval_IDF_BETA (double P, double a, double b)
{
- 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 };
+ return gsl_cdf_beta_Pinv (P, a, b);
+}
- 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 double
+matrix_eval_RV_BETA (double a, double b)
+{
+ return gsl_ran_beta (get_rng (), a, b);
}
-static struct read_file *
-read_file_create (struct matrix_state *s, struct file_handle *fh)
+static double
+matrix_eval_NCDF_BETA (double x, double a, double b, double lambda)
{
- 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;
- }
- }
+ return ncdf_beta (x, a, b, lambda);
+}
- struct read_file *rf = xmalloc (sizeof *rf);
- *rf = (struct read_file) { .file = fh };
+static double
+matrix_eval_NPDF_BETA (double x, double a, double b, double lambda)
+{
+ return npdf_beta (x, a, b, lambda);
+}
- 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 double
+matrix_eval_CDF_BVNOR (double x0, double x1, double r)
+{
+ return cdf_bvnor (x0, x1, r);
}
-static struct dfm_reader *
-read_file_open (struct read_file *rf)
+static double
+matrix_eval_PDF_BVNOR (double x0, double x1, double r)
{
- if (!rf->reader)
- rf->reader = dfm_open_reader (rf->file, NULL, rf->encoding);
- return rf->reader;
+ return gsl_ran_bivariate_gaussian_pdf (x0, x1, 1, 1, r);
}
-static void
-read_file_destroy (struct read_file *rf)
+static double
+matrix_eval_CDF_CAUCHY (double x, double a, double b)
{
- if (rf)
- {
- fh_unref (rf->file);
- dfm_close_reader (rf->reader);
- free (rf->encoding);
- free (rf);
- }
+ return gsl_cdf_cauchy_P ((x - a) / b, 1);
}
-static bool
-matrix_parse_function (struct matrix_state *s, const char *token,
- struct matrix_expr **exprp)
+static double
+matrix_eval_IDF_CAUCHY (double P, double a, double b)
{
- *exprp = NULL;
- if (lex_next_token (s->lexer, 1) != T_LPAREN)
- return false;
+ return a + b * gsl_cdf_cauchy_Pinv (P, 1);
+}
- 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;
+static double
+matrix_eval_PDF_CAUCHY (double x, double a, double b)
+{
+ return gsl_ran_cauchy_pdf ((x - a) / b, 1) / b;
+}
- if (!lex_force_match (s->lexer, T_RPAREN))
- {
- fh_unref (fh);
- return true;
- }
+static double
+matrix_eval_RV_CAUCHY (double a, double b)
+{
+ return a + b * gsl_ran_cauchy (get_rng (), 1);
+}
- struct read_file *rf = read_file_create (s, fh);
+static double
+matrix_eval_CDF_CHISQ (double x, double df)
+{
+ return gsl_cdf_chisq_P (x, df);
+}
- struct matrix_expr *e = xmalloc (sizeof *e);
- *e = (struct matrix_expr) { .op = MOP_EOF, .eof = rf };
- *exprp = e;
- return true;
- }
+static double
+matrix_eval_CHICDF (double x, double df)
+{
+ return matrix_eval_CDF_CHISQ (x, df);
+}
- const struct matrix_function *f = matrix_parse_function_name (token);
- if (!f)
- return false;
+static double
+matrix_eval_IDF_CHISQ (double P, double df)
+{
+ return gsl_cdf_chisq_Pinv (P, df);
+}
- lex_get_n (s->lexer, 2);
+static double
+matrix_eval_PDF_CHISQ (double x, double df)
+{
+ return gsl_ran_chisq_pdf (x, df);
+}
- struct matrix_expr *e = xmalloc (sizeof *e);
- *e = (struct matrix_expr) { .op = f->op, .subs = NULL };
+static double
+matrix_eval_RV_CHISQ (double df)
+{
+ return gsl_ran_chisq (get_rng (), df);
+}
- size_t allocated_subs = 0;
- do
- {
- struct matrix_expr *sub = matrix_parse_expr (s);
- if (!sub)
- goto error;
+static double
+matrix_eval_SIG_CHISQ (double x, double df)
+{
+ return gsl_cdf_chisq_Q (x, df);
+}
- 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;
+static double
+matrix_eval_CDF_EXP (double x, double a)
+{
+ return gsl_cdf_exponential_P (x, 1. / a);
+}
- *exprp = e;
- return true;
+static double
+matrix_eval_IDF_EXP (double P, double a)
+{
+ return gsl_cdf_exponential_Pinv (P, 1. / a);
+}
-error:
- matrix_expr_destroy (e);
- return true;
+static double
+matrix_eval_PDF_EXP (double x, double a)
+{
+ return gsl_ran_exponential_pdf (x, 1. / a);
}
-static struct matrix_expr *
-matrix_parse_primary (struct matrix_state *s)
+static double
+matrix_eval_RV_EXP (double a)
{
- 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);
+ return gsl_ran_exponential (get_rng (), 1. / a);
+}
- 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))
+static double
+matrix_eval_PDF_XPOWER (double x, double a, double b)
+{
+ return gsl_ran_exppow_pdf (x, a, b);
+}
+
+static double
+matrix_eval_RV_XPOWER (double a, double b)
+{
+ return gsl_ran_exppow (get_rng (), a, b);
+}
+
+static double
+matrix_eval_CDF_F (double x, double df1, double df2)
+{
+ return gsl_cdf_fdist_P (x, df1, df2);
+}
+
+static double
+matrix_eval_FCDF (double x, double df1, double df2)
+{
+ return matrix_eval_CDF_F (x, df1, df2);
+}
+
+static double
+matrix_eval_IDF_F (double P, double df1, double df2)
+{
+ return idf_fdist (P, df1, df2);
+}
+
+static double
+matrix_eval_RV_F (double df1, double df2)
+{
+ return gsl_ran_fdist (get_rng (), df1, df2);
+}
+
+static double
+matrix_eval_PDF_F (double x, double df1, double df2)
+{
+ return gsl_ran_fdist_pdf (x, df1, df2);
+}
+
+static double
+matrix_eval_SIG_F (double x, double df1, double df2)
+{
+ return gsl_cdf_fdist_Q (x, df1, df2);
+}
+
+static double
+matrix_eval_CDF_GAMMA (double x, double a, double b)
+{
+ return gsl_cdf_gamma_P (x, a, 1. / b);
+}
+
+static double
+matrix_eval_IDF_GAMMA (double P, double a, double b)
+{
+ return gsl_cdf_gamma_Pinv (P, a, 1. / b);
+}
+
+static double
+matrix_eval_PDF_GAMMA (double x, double a, double b)
+{
+ return gsl_ran_gamma_pdf (x, a, 1. / b);
+}
+
+static double
+matrix_eval_RV_GAMMA (double a, double b)
+{
+ return gsl_ran_gamma (get_rng (), a, 1. / b);
+}
+
+static double
+matrix_eval_PDF_LANDAU (double x)
+{
+ return gsl_ran_landau_pdf (x);
+}
+
+static double
+matrix_eval_RV_LANDAU (void)
+{
+ return gsl_ran_landau (get_rng ());
+}
+
+static double
+matrix_eval_CDF_LAPLACE (double x, double a, double b)
+{
+ return gsl_cdf_laplace_P ((x - a) / b, 1);
+}
+
+static double
+matrix_eval_IDF_LAPLACE (double P, double a, double b)
+{
+ return a + b * gsl_cdf_laplace_Pinv (P, 1);
+}
+
+static double
+matrix_eval_PDF_LAPLACE (double x, double a, double b)
+{
+ return gsl_ran_laplace_pdf ((x - a) / b, 1);
+}
+
+static double
+matrix_eval_RV_LAPLACE (double a, double b)
+{
+ return a + b * gsl_ran_laplace (get_rng (), 1);
+}
+
+static double
+matrix_eval_RV_LEVY (double c, double alpha)
+{
+ return gsl_ran_levy (get_rng (), c, alpha);
+}
+
+static double
+matrix_eval_RV_LVSKEW (double c, double alpha, double beta)
+{
+ return gsl_ran_levy_skew (get_rng (), c, alpha, beta);
+}
+
+static double
+matrix_eval_CDF_LOGISTIC (double x, double a, double b)
+{
+ return gsl_cdf_logistic_P ((x - a) / b, 1);
+}
+
+static double
+matrix_eval_IDF_LOGISTIC (double P, double a, double b)
+{
+ return a + b * gsl_cdf_logistic_Pinv (P, 1);
+}
+
+static double
+matrix_eval_PDF_LOGISTIC (double x, double a, double b)
+{
+ return gsl_ran_logistic_pdf ((x - a) / b, 1) / b;
+}
+
+static double
+matrix_eval_RV_LOGISTIC (double a, double b)
+{
+ return a + b * gsl_ran_logistic (get_rng (), 1);
+}
+
+static double
+matrix_eval_CDF_LNORMAL (double x, double m, double s)
+{
+ return gsl_cdf_lognormal_P (x, log (m), s);
+}
+
+static double
+matrix_eval_IDF_LNORMAL (double P, double m, double s)
+{
+ return gsl_cdf_lognormal_Pinv (P, log (m), s);;
+}
+
+static double
+matrix_eval_PDF_LNORMAL (double x, double m, double s)
+{
+ return gsl_ran_lognormal_pdf (x, log (m), s);
+}
+
+static double
+matrix_eval_RV_LNORMAL (double m, double s)
+{
+ return gsl_ran_lognormal (get_rng (), log (m), s);
+}
+
+static double
+matrix_eval_CDF_NORMAL (double x, double u, double s)
+{
+ return gsl_cdf_gaussian_P (x - u, s);
+}
+
+static double
+matrix_eval_IDF_NORMAL (double P, double u, double s)
+{
+ return u + gsl_cdf_gaussian_Pinv (P, s);
+}
+
+static double
+matrix_eval_PDF_NORMAL (double x, double u, double s)
+{
+ return gsl_ran_gaussian_pdf ((x - u) / s, 1) / s;
+}
+
+static double
+matrix_eval_RV_NORMAL (double u, double s)
+{
+ return u + gsl_ran_gaussian (get_rng (), s);
+}
+
+static double
+matrix_eval_CDFNORM (double x)
+{
+ return gsl_cdf_ugaussian_P (x);
+}
+
+static double
+matrix_eval_PROBIT (double P)
+{
+ return gsl_cdf_ugaussian_Pinv (P);
+}
+
+static double
+matrix_eval_NORMAL (double s)
+{
+ return gsl_ran_gaussian (get_rng (), s);
+}
+
+static double
+matrix_eval_PDF_NTAIL (double x, double a, double sigma)
+{
+ return gsl_ran_gaussian_tail_pdf (x, a, sigma);;
+}
+
+static double
+matrix_eval_RV_NTAIL (double a, double sigma)
+{
+ return gsl_ran_gaussian_tail (get_rng (), a, sigma);
+}
+
+static double
+matrix_eval_CDF_PARETO (double x, double a, double b)
+{
+ return gsl_cdf_pareto_P (x, b, a);
+}
+
+static double
+matrix_eval_IDF_PARETO (double P, double a, double b)
+{
+ return gsl_cdf_pareto_Pinv (P, b, a);
+}
+
+static double
+matrix_eval_PDF_PARETO (double x, double a, double b)
+{
+ return gsl_ran_pareto_pdf (x, b, a);
+}
+
+static double
+matrix_eval_RV_PARETO (double a, double b)
+{
+ return gsl_ran_pareto (get_rng (), b, a);
+}
+
+static double
+matrix_eval_CDF_RAYLEIGH (double x, double sigma)
+{
+ return gsl_cdf_rayleigh_P (x, sigma);
+}
+
+static double
+matrix_eval_IDF_RAYLEIGH (double P, double sigma)
+{
+ return gsl_cdf_rayleigh_Pinv (P, sigma);
+}
+
+static double
+matrix_eval_PDF_RAYLEIGH (double x, double sigma)
+{
+ return gsl_ran_rayleigh_pdf (x, sigma);
+}
+
+static double
+matrix_eval_RV_RAYLEIGH (double sigma)
+{
+ return gsl_ran_rayleigh (get_rng (), sigma);
+}
+
+static double
+matrix_eval_PDF_RTAIL (double x, double a, double sigma)
+{
+ return gsl_ran_rayleigh_tail_pdf (x, a, sigma);
+}
+
+static double
+matrix_eval_RV_RTAIL (double a, double sigma)
+{
+ return gsl_ran_rayleigh_tail (get_rng (), a, sigma);
+}
+
+static double
+matrix_eval_CDF_T (double x, double df)
+{
+ return gsl_cdf_tdist_P (x, df);
+}
+
+static double
+matrix_eval_TCDF (double x, double df)
+{
+ return matrix_eval_CDF_T (x, df);
+}
+
+static double
+matrix_eval_IDF_T (double P, double df)
+{
+ return gsl_cdf_tdist_Pinv (P, df);
+}
+
+static double
+matrix_eval_PDF_T (double x, double df)
+{
+ return gsl_ran_tdist_pdf (x, df);
+}
+
+static double
+matrix_eval_RV_T (double df)
+{
+ return gsl_ran_tdist (get_rng (), df);
+}
+
+static double
+matrix_eval_CDF_T1G (double x, double a, double b)
+{
+ return gsl_cdf_gumbel1_P (x, a, b);
+}
+
+static double
+matrix_eval_IDF_T1G (double P, double a, double b)
+{
+ return gsl_cdf_gumbel1_Pinv (P, a, b);
+}
+
+static double
+matrix_eval_PDF_T1G (double x, double a, double b)
+{
+ return gsl_ran_gumbel1_pdf (x, a, b);
+}
+
+static double
+matrix_eval_RV_T1G (double a, double b)
+{
+ return gsl_ran_gumbel1 (get_rng (), a, b);
+}
+
+static double
+matrix_eval_CDF_T2G (double x, double a, double b)
+{
+ return gsl_cdf_gumbel1_P (x, a, b);
+}
+
+static double
+matrix_eval_IDF_T2G (double P, double a, double b)
+{
+ return gsl_cdf_gumbel1_Pinv (P, a, b);
+}
+
+static double
+matrix_eval_PDF_T2G (double x, double a, double b)
+{
+ return gsl_ran_gumbel1_pdf (x, a, b);
+}
+
+static double
+matrix_eval_RV_T2G (double a, double b)
+{
+ return gsl_ran_gumbel1 (get_rng (), a, b);
+}
+
+static double
+matrix_eval_CDF_UNIFORM (double x, double a, double b)
+{
+ return gsl_cdf_flat_P (x, a, b);
+}
+
+static double
+matrix_eval_IDF_UNIFORM (double P, double a, double b)
+{
+ return gsl_cdf_flat_Pinv (P, a, b);
+}
+
+static double
+matrix_eval_PDF_UNIFORM (double x, double a, double b)
+{
+ return gsl_ran_flat_pdf (x, a, b);
+}
+
+static double
+matrix_eval_RV_UNIFORM (double a, double b)
+{
+ return gsl_ran_flat (get_rng (), a, b);
+}
+
+static double
+matrix_eval_CDF_WEIBULL (double x, double a, double b)
+{
+ return gsl_cdf_weibull_P (x, a, b);
+}
+
+static double
+matrix_eval_IDF_WEIBULL (double P, double a, double b)
+{
+ return gsl_cdf_weibull_Pinv (P, a, b);
+}
+
+static double
+matrix_eval_PDF_WEIBULL (double x, double a, double b)
+{
+ return gsl_ran_weibull_pdf (x, a, b);
+}
+
+static double
+matrix_eval_RV_WEIBULL (double a, double b)
+{
+ return gsl_ran_weibull (get_rng (), a, b);
+}
+
+static double
+matrix_eval_CDF_BERNOULLI (double k, double p)
+{
+ return k ? 1 : 1 - p;
+}
+
+static double
+matrix_eval_PDF_BERNOULLI (double k, double p)
+{
+ return gsl_ran_bernoulli_pdf (k, p);
+}
+
+static double
+matrix_eval_RV_BERNOULLI (double p)
+{
+ return gsl_ran_bernoulli (get_rng (), p);
+}
+
+static double
+matrix_eval_CDF_BINOM (double k, double n, double p)
+{
+ return gsl_cdf_binomial_P (k, p, n);
+}
+
+static double
+matrix_eval_PDF_BINOM (double k, double n, double p)
+{
+ return gsl_ran_binomial_pdf (k, p, n);
+}
+
+static double
+matrix_eval_RV_BINOM (double n, double p)
+{
+ return gsl_ran_binomial (get_rng (), p, n);
+}
+
+static double
+matrix_eval_CDF_GEOM (double k, double p)
+{
+ return gsl_cdf_geometric_P (k, p);
+}
+
+static double
+matrix_eval_PDF_GEOM (double k, double p)
+{
+ return gsl_ran_geometric_pdf (k, p);
+}
+
+static double
+matrix_eval_RV_GEOM (double p)
+{
+ return gsl_ran_geometric (get_rng (), p);
+}
+
+static double
+matrix_eval_CDF_HYPER (double k, double a, double b, double c)
+{
+ return gsl_cdf_hypergeometric_P (k, c, a - c, b);
+}
+
+static double
+matrix_eval_PDF_HYPER (double k, double a, double b, double c)
+{
+ return gsl_ran_hypergeometric_pdf (k, c, a - c, b);
+}
+
+static double
+matrix_eval_RV_HYPER (double a, double b, double c)
+{
+ return gsl_ran_hypergeometric (get_rng (), c, a - c, b);
+}
+
+static double
+matrix_eval_PDF_LOG (double k, double p)
+{
+ return gsl_ran_logarithmic_pdf (k, p);
+}
+
+static double
+matrix_eval_RV_LOG (double p)
+{
+ return gsl_ran_logarithmic (get_rng (), p);
+}
+
+static double
+matrix_eval_CDF_NEGBIN (double k, double n, double p)
+{
+ return gsl_cdf_negative_binomial_P (k, p, n);
+}
+
+static double
+matrix_eval_PDF_NEGBIN (double k, double n, double p)
+{
+ return gsl_ran_negative_binomial_pdf (k, p, n);
+}
+
+static double
+matrix_eval_RV_NEGBIN (double n, double p)
+{
+ return gsl_ran_negative_binomial (get_rng (), p, n);
+}
+
+static double
+matrix_eval_CDF_POISSON (double k, double mu)
+{
+ return gsl_cdf_poisson_P (k, mu);
+}
+
+static double
+matrix_eval_PDF_POISSON (double k, double mu)
+{
+ return gsl_ran_poisson_pdf (k, mu);
+}
+
+static double
+matrix_eval_RV_POISSON (double mu)
+{
+ return gsl_ran_poisson (get_rng (), mu);
+}
+
+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 bool
+word_matches (const char **test, const char **name)
+{
+ size_t test_len = strcspn (*test, ".");
+ size_t name_len = strcspn (*name, ".");
+ if (test_len == name_len)
+ {
+ if (buf_compare_case (*test, *name, test_len))
+ return false;
+ }
+ else if (test_len < 3 || test_len > name_len)
+ return false;
+ else
+ {
+ if (buf_compare_case (*test, *name, test_len))
+ return false;
+ }
+
+ *test += test_len;
+ *name += name_len;
+ if (**test != **name)
+ return false;
+
+ if (**test == '.')
+ {
+ (*test)++;
+ (*name)++;
+ }
+ return true;
+}
+
+/* Returns 0 if TOKEN and FUNC do not match,
+ 1 if TOKEN is an acceptable abbreviation for FUNC,
+ 2 if TOKEN equals FUNC. */
+static int
+compare_function_names (const char *token_, const char *func_)
+{
+ const char *token = token_;
+ const char *func = func_;
+ while (*token || *func)
+ if (!word_matches (&token, &func))
+ return 0;
+ return !c_strcasecmp (token_, func_) ? 2 : 1;
+}
+
+static const struct matrix_function *
+matrix_parse_function_name (const char *token)
+{
+ static const struct matrix_function functions[] =
+ {
+#define F(ENUM, STRING, PROTO, CONSTRAINTS) \
+ { STRING, MOP_F_##ENUM, 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 (compare_function_names (token, functions[i].name) > 0)
+ 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 void
+read_file_destroy (struct read_file *rf)
+{
+ if (rf)
+ {
+ fh_unref (rf->file);
+ dfm_close_reader (rf->reader);
+ free (rf->encoding);
+ free (rf);
+ }
+}
+
+static struct write_file *
+write_file_create (struct matrix_state *s, struct file_handle *fh)
+{
+ for (size_t i = 0; i < s->n_write_files; i++)
+ {
+ struct write_file *wf = s->write_files[i];
+ if (wf->file == fh)
+ {
+ fh_unref (fh);
+ return wf;
+ }
+ }
+
+ struct write_file *wf = xmalloc (sizeof *wf);
+ *wf = (struct write_file) { .file = fh };
+
+ s->write_files = xrealloc (s->write_files,
+ (s->n_write_files + 1) * sizeof *s->write_files);
+ s->write_files[s->n_write_files++] = wf;
+ return wf;
+}
+
+static struct dfm_writer *
+write_file_open (struct write_file *wf)
+{
+ if (!wf->writer)
+ wf->writer = dfm_open_writer (wf->file, wf->encoding);
+ return wf->writer;
+}
+
+static void
+write_file_destroy (struct write_file *wf)
+{
+ if (wf)
+ {
+ if (wf->held)
+ {
+ dfm_put_record_utf8 (wf->writer, wf->held->s.ss.string,
+ wf->held->s.ss.length);
+ u8_line_destroy (wf->held);
+ free (wf->held);
+ }
+
+ fh_unref (wf->file);
+ dfm_close_writer (wf->writer);
+ free (wf->encoding);
+ free (wf);
+ }
+}
+
+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;
+
+ struct matrix_expr *e = xmalloc (sizeof *e);
+ *e = (struct matrix_expr) {
+ .op = f->op,
+ .location = lex_get_location (s->lexer, 0, 0)
+ };
+
+ lex_get_n (s->lexer, 2);
+ if (lex_token (s->lexer) != T_RPAREN)
+ {
+ size_t allocated_subs = 0;
+ do
+ {
+ struct msg_location *arg_location = lex_get_location (s->lexer, 0, 0);
+ struct matrix_expr *sub = matrix_parse_expr (s);
+ if (!sub)
+ {
+ msg_location_destroy (arg_location);
+ goto error;
+ }
+ if (!sub->location)
+ {
+ lex_extend_location (s->lexer, 0, arg_location);
+ sub->location = arg_location;
+ }
+ else
+ msg_location_destroy (arg_location);
+
+ 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;
+
+ if (e->n_subs < f->min_args || e->n_subs > f->max_args)
+ {
+ if (f->min_args == f->max_args)
+ msg (SE, ngettext ("Matrix function %s requires %zu argument.",
+ "Matrix function %s requires %zu arguments.",
+ f->min_args),
+ f->name, f->min_args);
+ else if (f->min_args == 1 && f->max_args == 2)
+ msg (SE, ngettext ("Matrix function %s requires 1 or 2 arguments, "
+ "but %zu was provided.",
+ "Matrix function %s requires 1 or 2 arguments, "
+ "but %zu were provided.",
+ e->n_subs),
+ f->name, e->n_subs);
+ else if (f->min_args == 1 && f->max_args == INT_MAX)
+ msg (SE, _("Matrix function %s requires at least one argument."),
+ f->name);
+ else
+ NOT_REACHED ();
+
+ 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;
case MOP_OR: return (a > 0) || (b > 0);
case MOP_XOR: return (a > 0) != (b > 0);
-#define F(NAME, PROTOTYPE) case MOP_F_##NAME:
+#define F(ENUM, STRING, PROTO, CONSTRAINTS) case MOP_F_##ENUM:
MATRIX_FUNCTIONS
#undef F
case MOP_NEGATE:
case MOP_OR: return "OR";
case MOP_XOR: return "XOR";
-#define F(NAME, PROTOTYPE) case MOP_F_##NAME:
+#define F(ENUM, STRING, PROTO, CONSTRAINTS) case MOP_F_##ENUM:
MATRIX_FUNCTIONS
#undef F
case MOP_NEGATE:
}
long int n = (end >= start && by > 0 ? (end - start + by) / by
- : end < start && by < 0 ? (start - end - 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++)
assert (!v.owner);
v.owner = 1;
m->owner = 0;
+ gsl_matrix_free (m);
return xmemdup (&v, sizeof v);
}
return dm;
}
-#define F(NAME, PROTOTYPE) \
- static gsl_matrix *matrix_expr_evaluate_##PROTOTYPE ( \
- const char *name, gsl_matrix *[], size_t, \
- matrix_proto_##PROTOTYPE *);
+#define F(ENUM, STRING, PROTO, CONSTRAINTS) \
+ static gsl_matrix *matrix_expr_evaluate_##PROTO ( \
+ const struct matrix_function_properties *, gsl_matrix *[], size_t, \
+ matrix_proto_##PROTO *);
MATRIX_FUNCTIONS
#undef F
return true;
}
+static int
+parse_constraint_value (const char **constraintsp)
+{
+ char *tail;
+ long retval = strtol (*constraintsp, &tail, 10);
+ assert (tail > *constraintsp);
+ *constraintsp = tail;
+ return retval;
+}
+
+static void
+argument_invalid (const struct matrix_function_properties *props,
+ size_t arg_index, gsl_matrix *a, size_t y, size_t x,
+ struct string *out)
+{
+ if (is_scalar (a))
+ ds_put_format (out, _("Argument %zu to matrix function %s "
+ "has invalid value %g."),
+ arg_index, props->name, gsl_matrix_get (a, y, x));
+ else
+ ds_put_format (out, _("Row %zu, column %zu of argument %zu "
+ "to matrix function %s has "
+ "invalid value %g."),
+ y + 1, x + 1, arg_index, props->name,
+ gsl_matrix_get (a, y, x));
+}
+
+static void
+argument_inequality_error (const struct matrix_function_properties *props,
+ size_t a_index, gsl_matrix *a, size_t y, size_t x,
+ size_t b_index, double b,
+ bool greater, bool equal)
+{
+ struct string s = DS_EMPTY_INITIALIZER;
+
+ argument_invalid (props, a_index, a, y, x, &s);
+ ds_put_cstr (&s, " ");
+ if (greater && equal)
+ ds_put_format (&s, _("This argument must be greater than or "
+ "equal to argument %zu, but that has value %g."),
+ b_index, b);
+ else if (greater && !equal)
+ ds_put_format (&s, _("This argument must be greater than argument %zu, "
+ "but that has value %g."),
+ b_index, b);
+ else if (equal)
+ ds_put_format (&s, _("This argument must be less than or "
+ "equal to argument %zu, but that has value %g."),
+ b_index, b);
+ else
+ ds_put_format (&s, _("This argument must be less than argument %zu, "
+ "but that has value %g."),
+ b_index, b);
+ msg (ME, ds_cstr (&s));
+ ds_destroy (&s);
+}
+
+static void
+argument_value_error (const struct matrix_function_properties *props,
+ size_t a_index, gsl_matrix *a, size_t y, size_t x,
+ double b,
+ bool greater, bool equal)
+{
+ struct string s = DS_EMPTY_INITIALIZER;
+ argument_invalid (props, a_index, a, y, x, &s);
+ ds_put_cstr (&s, " ");
+ if (greater && equal)
+ ds_put_format (&s, _("This argument must be greater than or equal to %g."),
+ b);
+ else if (greater && !equal)
+ ds_put_format (&s, _("This argument must be greater than %g."), b);
+ else if (equal)
+ ds_put_format (&s, _("This argument must be less than or equal to %g."), b);
+ else
+ ds_put_format (&s, _("This argument must be less than %g."), b);
+ msg (ME, ds_cstr (&s));
+ ds_destroy (&s);
+}
+
+static bool
+check_constraints (const struct matrix_function_properties *props,
+ gsl_matrix *args[], size_t n_args)
+{
+ const char *constraints = props->constraints;
+ if (!constraints)
+ return true;
+
+ size_t arg_index = SIZE_MAX;
+ while (*constraints)
+ {
+ if (*constraints >= 'a' && *constraints <= 'd')
+ {
+ arg_index = *constraints++ - 'a';
+ assert (arg_index < n_args);
+ }
+ else if (*constraints == '[' || *constraints == '(')
+ {
+ assert (arg_index < n_args);
+ bool open_lower = *constraints++ == '(';
+ int minimum = parse_constraint_value (&constraints);
+ assert (*constraints == ',');
+ constraints++;
+ int maximum = parse_constraint_value (&constraints);
+ assert (*constraints == ']' || *constraints == ')');
+ bool open_upper = *constraints++ == ')';
+
+ MATRIX_FOR_ALL_ELEMENTS (d, y, x, args[arg_index])
+ if ((open_lower ? *d <= minimum : *d < minimum)
+ || (open_upper ? *d >= maximum : *d > maximum))
+ {
+ if (!is_scalar (args[arg_index]))
+ msg (ME, _("Row %zu, column %zu of argument %zu to matrix "
+ "function %s has value %g, which is outside "
+ "the valid range %c%d,%d%c."),
+ y + 1, x + 1, arg_index + 1, props->name, *d,
+ open_lower ? '(' : '[',
+ minimum, maximum,
+ open_upper ? ')' : ']');
+ else
+ msg (ME, _("Argument %zu to matrix function %s has value %g, "
+ "which is outside the valid range %c%d,%d%c."),
+ arg_index + 1, props->name, *d,
+ open_lower ? '(' : '[',
+ minimum, maximum,
+ open_upper ? ')' : ']');
+ return false;
+ }
+ }
+ else if (*constraints == '>' || *constraints == '<')
+ {
+ bool greater = *constraints++ == '>';
+ bool equal;
+ if (*constraints == '=')
+ {
+ equal = true;
+ constraints++;
+ }
+ else
+ equal = false;
+
+ if (*constraints >= 'a' && *constraints <= 'd')
+ {
+ size_t a_index = arg_index;
+ size_t b_index = *constraints - 'a';
+ assert (a_index < n_args);
+ assert (b_index < n_args);
+
+ /* We only support one of the two arguments being non-scalar.
+ It's easier to support only the first one being non-scalar, so
+ flip things around if it's the other way. */
+ if (!is_scalar (args[b_index]))
+ {
+ assert (is_scalar (args[a_index]));
+ size_t tmp_index = a_index;
+ a_index = b_index;
+ b_index = tmp_index;
+
+ greater = !greater;
+ }
+
+ double b = to_scalar (args[b_index]);
+ MATRIX_FOR_ALL_ELEMENTS (a, y, x, args[a_index])
+ if (greater
+ ? (equal ? !(*a >= b) : !(*a > b))
+ : (equal ? !(*a <= b) : !(*a < b)))
+ {
+ argument_inequality_error (props,
+ a_index + 1, args[a_index], y, x,
+ b_index + 1, b,
+ greater, equal);
+ return false;
+ }
+ }
+ else
+ {
+ int comparand = parse_constraint_value (&constraints);
+
+ MATRIX_FOR_ALL_ELEMENTS (d, y, x, args[arg_index])
+ if (greater
+ ? (equal ? !(*d >= comparand) : !(*d > comparand))
+ : (equal ? !(*d <= comparand) : !(*d < comparand)))
+ {
+ argument_value_error (props,
+ arg_index + 1, args[arg_index], y, x,
+ comparand,
+ greater, equal);
+ return false;
+ }
+ }
+ }
+ else
+ {
+ assert (*constraints == ' ');
+ constraints++;
+ arg_index = SIZE_MAX;
+ }
+ }
+ return true;
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_d_none (
+ const struct matrix_function_properties *props UNUSED,
+ gsl_matrix *subs[] UNUSED, size_t n_subs,
+ matrix_proto_d_none *f)
+{
+ assert (n_subs == 0);
+
+ gsl_matrix *m = gsl_matrix_alloc (1, 1);
+ gsl_matrix_set (m, 0, 0, f ());
+ return m;
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_d_d (const struct matrix_function_properties *props,
+ gsl_matrix *subs[], size_t n_subs,
+ matrix_proto_d_d *f)
+{
+ assert (n_subs == 1);
+
+ double d;
+ if (!to_scalar_args (props->name, subs, n_subs, &d))
+ return NULL;
+
+ if (!check_constraints (props, subs, n_subs))
+ return NULL;
+
+ gsl_matrix *m = gsl_matrix_alloc (1, 1);
+ gsl_matrix_set (m, 0, 0, f (d));
+ return m;
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_d_dd (const struct matrix_function_properties *props,
+ gsl_matrix *subs[], size_t n_subs,
+ matrix_proto_d_dd *f)
+{
+ assert (n_subs == 2);
+
+ double d[2];
+ if (!to_scalar_args (props->name, subs, n_subs, d))
+ return NULL;
+
+ if (!check_constraints (props, subs, n_subs))
+ return NULL;
+
+ gsl_matrix *m = gsl_matrix_alloc (1, 1);
+ gsl_matrix_set (m, 0, 0, f (d[0], d[1]));
+ return m;
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_d_ddd (const struct matrix_function_properties *props,
+ gsl_matrix *subs[], size_t n_subs,
+ matrix_proto_d_ddd *f)
+{
+ assert (n_subs == 3);
+
+ double d[3];
+ if (!to_scalar_args (props->name, subs, n_subs, d))
+ return NULL;
+
+ if (!check_constraints (props, subs, n_subs))
+ return NULL;
+
+ gsl_matrix *m = gsl_matrix_alloc (1, 1);
+ gsl_matrix_set (m, 0, 0, f (d[0], d[1], d[2]));
+ return m;
+}
+
static gsl_matrix *
-matrix_expr_evaluate_m_d (const char *name,
+matrix_expr_evaluate_m_d (const struct matrix_function_properties *props,
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;
+ return to_scalar_args (props->name, subs, n_subs, &d) ? f (d) : NULL;
}
static gsl_matrix *
-matrix_expr_evaluate_m_dd (const char *name,
+matrix_expr_evaluate_m_dd (const struct matrix_function_properties *props,
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;
+ return to_scalar_args (props->name, subs, n_subs, d) ? f(d[0], d[1]) : NULL;
}
static gsl_matrix *
-matrix_expr_evaluate_m_ddd (const char *name,
+matrix_expr_evaluate_m_ddd (const struct matrix_function_properties *props,
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;
+ return to_scalar_args (props->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,
+matrix_expr_evaluate_m_m (const struct matrix_function_properties *props UNUSED,
gsl_matrix *subs[], size_t n_subs,
matrix_proto_m_m *f)
{
}
static gsl_matrix *
-matrix_expr_evaluate_m_md (const char *name UNUSED,
+matrix_expr_evaluate_m_e (const struct matrix_function_properties *props,
+ gsl_matrix *subs[], size_t n_subs,
+ matrix_proto_m_e *f)
+{
+ assert (n_subs == 1);
+
+ if (!check_constraints (props, subs, n_subs))
+ return NULL;
+
+ MATRIX_FOR_ALL_ELEMENTS (a, y, x, subs[0])
+ *a = f (*a);
+ return subs[0];
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_m_md (const struct matrix_function_properties *props UNUSED,
gsl_matrix *subs[], size_t n_subs,
matrix_proto_m_md *f)
{
assert (n_subs == 2);
- if (!check_scalar_arg (name, subs, 1))
+ if (!check_scalar_arg (props->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,
+matrix_expr_evaluate_m_ed (const struct matrix_function_properties *props,
+ gsl_matrix *subs[], size_t n_subs,
+ matrix_proto_m_ed *f)
+{
+ assert (n_subs == 2);
+ if (!check_scalar_arg (props->name, subs, 1))
+ return NULL;
+
+ if (!check_constraints (props, subs, n_subs))
+ return NULL;
+
+ double b = to_scalar (subs[1]);
+ MATRIX_FOR_ALL_ELEMENTS (a, y, x, subs[0])
+ *a = f (*a, b);
+ return subs[0];
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_m_mdd (const struct matrix_function_properties *props 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))
+ if (!check_scalar_arg (props->name, subs, 1) || !check_scalar_arg (props->name, subs, 2))
+ return NULL;
+ return f (subs[0], to_scalar (subs[1]), to_scalar (subs[2]));
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_m_edd (const struct matrix_function_properties *props,
+ gsl_matrix *subs[], size_t n_subs,
+ matrix_proto_m_edd *f)
+{
+ assert (n_subs == 3);
+ if (!check_scalar_arg (props->name, subs, 1) || !check_scalar_arg (props->name, subs, 2))
+ return NULL;
+
+ if (!check_constraints (props, subs, n_subs))
+ return NULL;
+
+ double b = to_scalar (subs[1]);
+ double c = to_scalar (subs[2]);
+ MATRIX_FOR_ALL_ELEMENTS (a, y, x, subs[0])
+ *a = f (*a, b, c);
+ return subs[0];
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_m_eddd (const struct matrix_function_properties *props,
+ gsl_matrix *subs[], size_t n_subs,
+ matrix_proto_m_eddd *f)
+{
+ assert (n_subs == 4);
+ for (size_t i = 1; i < 4; i++)
+ if (!check_scalar_arg (props->name, subs, i))
+ return NULL;
+
+ if (!check_constraints (props, subs, n_subs))
+ return NULL;
+
+ double b = to_scalar (subs[1]);
+ double c = to_scalar (subs[2]);
+ double d = to_scalar (subs[3]);
+ MATRIX_FOR_ALL_ELEMENTS (a, y, x, subs[0])
+ *a = f (*a, b, c, d);
+ return subs[0];
+}
+
+static gsl_matrix *
+matrix_expr_evaluate_m_eed (const struct matrix_function_properties *props,
+ gsl_matrix *subs[], size_t n_subs,
+ matrix_proto_m_eed *f)
+{
+ assert (n_subs == 3);
+ if (!check_scalar_arg (props->name, subs, 2))
return NULL;
- return f (subs[0], to_scalar (subs[1]), to_scalar (subs[2]));
+
+ if (!is_scalar (subs[0]) && !is_scalar (subs[1])
+ && (subs[0]->size1 != subs[1]->size1 || subs[0]->size2 != subs[1]->size2))
+ {
+ msg (ME, _("Arguments 1 and 2 to %s have dimensions %zu×%zu and "
+ "%zu×%zu, but %s requires these arguments either to have "
+ "the same dimensions or for one of them to be a scalar."),
+ props->name,
+ subs[0]->size1, subs[0]->size2,
+ subs[1]->size1, subs[1]->size2,
+ props->name);
+ return NULL;
+ }
+
+ if (!check_constraints (props, subs, n_subs))
+ return NULL;
+
+ double c = to_scalar (subs[2]);
+
+ if (is_scalar (subs[0]))
+ {
+ double a = to_scalar (subs[0]);
+ MATRIX_FOR_ALL_ELEMENTS (b, y, x, subs[1])
+ *b = f (a, *b, c);
+ return subs[1];
+ }
+ else
+ {
+ double b = to_scalar (subs[1]);
+ MATRIX_FOR_ALL_ELEMENTS (a, y, x, subs[0])
+ *a = f (*a, b, c);
+ return subs[0];
+ }
}
static gsl_matrix *
-matrix_expr_evaluate_m_mm (const char *name UNUSED,
+matrix_expr_evaluate_m_mm (const struct matrix_function_properties *props UNUSED,
gsl_matrix *subs[], size_t n_subs,
matrix_proto_m_mm *f)
{
}
static gsl_matrix *
-matrix_expr_evaluate_m_v (const char *name,
+matrix_expr_evaluate_m_v (const struct matrix_function_properties *props,
gsl_matrix *subs[], size_t n_subs,
matrix_proto_m_v *f)
{
assert (n_subs == 1);
- if (!check_vector_arg (name, subs, 0))
+ if (!check_vector_arg (props->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,
+matrix_expr_evaluate_d_m (const struct matrix_function_properties *props UNUSED,
gsl_matrix *subs[], size_t n_subs,
matrix_proto_d_m *f)
{
}
static gsl_matrix *
-matrix_expr_evaluate_m_any (const char *name UNUSED,
+matrix_expr_evaluate_m_any (const struct matrix_function_properties *props UNUSED,
gsl_matrix *subs[], size_t n_subs,
matrix_proto_m_any *f)
{
}
static gsl_matrix *
-matrix_expr_evaluate_IDENT (const char *name,
+matrix_expr_evaluate_IDENT (const struct matrix_function_properties *props,
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))
+ if (!to_scalar_args (props->name, subs, n_subs, d))
return NULL;
return f (d[0], d[n_subs - 1]);
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); \
+#define F(ENUM, STRING, PROTO, CONSTRAINTS) \
+ case MOP_F_##ENUM: \
+ { \
+ static const struct matrix_function_properties props = { \
+ .name = STRING, \
+ .constraints = CONSTRAINTS, \
+ }; \
+ result = matrix_expr_evaluate_##PROTO (&props, subs, e->n_subs, \
+ matrix_eval_##ENUM); \
+ } \
break;
MATRIX_FUNCTIONS
#undef F
struct matrix_lvalue
{
struct matrix_var *var;
+ struct msg_location *var_location;
struct matrix_expr *indexes[2];
size_t n_indexes;
};
struct matrix_lvalue *lvalue = xzalloc (sizeof *lvalue);
if (!lex_force_id (s->lexer))
goto error;
+ lvalue->var_location = lex_get_location (s->lexer, 0, 0);
lvalue->var = matrix_var_lookup (s, lex_tokss (s->lexer));
if (lex_next_token (s->lexer, 1) == T_LPAREN)
{
gsl_matrix *dm = lvalue->var->value;
if (!dm)
{
- msg (SE, _("Undefined variable %s."), lvalue->var->name);
+ msg_at (SE, lvalue->var_location,
+ _("Undefined variable %s."), lvalue->var->name);
return false;
}
else if (dm->size1 == 0 || dm->size2 == 0)
{
- msg (SE, _("Cannot index %zu×%zu matrix."),
- dm->size1, dm->size2);
+ msg_at (SE, lvalue->var_location,
+ _("Cannot index %zu×%zu matrix."), dm->size1, dm->size2);
return false;
}
else if (lvalue->n_indexes == 1)
{
if (!is_vector (dm))
{
- msg (SE, _("Can't use vector indexing on %zu×%zu matrix %s."),
- dm->size1, dm->size2, lvalue->var->name);
+ msg_at (SE, lvalue->var_location,
+ _("Can't use vector indexing on %zu×%zu matrix %s."),
+ dm->size1, dm->size2, lvalue->var->name);
return false;
}
return matrix_lvalue_evaluate_vector (lvalue->indexes[0],
struct display_command
{
struct matrix_state *state;
- bool dictionary;
- bool status;
}
display;
struct save_command
{
struct matrix_expr *expression;
- struct file_handle *outfile;
- struct string_array *variables;
- struct matrix_expr *names;
- struct stringi_set strings;
+ struct save_file *sf;
}
save;
int c1, c2;
enum fmt_type format;
int w;
- int d;
bool symmetric;
bool reread;
}
struct write_command
{
+ struct write_file *wf;
struct matrix_expr *expression;
- struct file_handle *outfile;
- char *encoding;
int c1, c2;
- enum fmt_type format;
- int w;
- int d;
+
+ /* If this is nonnull, WRITE uses this format.
+
+ If this is NULL, WRITE uses free-field format with as many
+ digits of precision as needed. */
+ struct fmt_spec *format;
+
bool triangular;
- bool hold; /* XXX */
+ bool hold;
}
write;
struct get_command
{
struct matrix_lvalue *dst;
+ struct dataset *dataset;
struct file_handle *file;
char *encoding;
- struct string_array variables;
+ struct var_syntax *vars;
+ size_t n_vars;
struct matrix_var *names;
/* Treatment of missing values. */
struct msave_command
{
struct msave_common *common;
- char *varname_;
struct matrix_expr *expr;
const char *rowtype;
- struct matrix_expr *factors;
- struct matrix_expr *splits;
+ const struct matrix_expr *factors;
+ const struct matrix_expr *splits;
}
msave;
{
struct matrix_state *state;
struct file_handle *file;
+ char *encoding;
struct stringi_set rowtypes;
}
mget;
static struct matrix_cmd *
matrix_parse_display (struct matrix_state *s)
{
- bool dictionary = false;
- bool status = false;
- while (lex_token (s->lexer) == T_ID)
+ while (lex_token (s->lexer) != T_ENDCMD)
{
- if (lex_match_id (s->lexer, "DICTIONARY"))
- dictionary = true;
- else if (lex_match_id (s->lexer, "STATUS"))
- status = true;
- else
+ if (!lex_match_id (s->lexer, "DICTIONARY")
+ && !lex_match_id (s->lexer, "STATUS"))
{
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,
- }
- };
+ *cmd = (struct matrix_cmd) { .type = MCMD_DISPLAY, .display = { s } };
return 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)"));
+ struct pivot_dimension *attr_dimension
+ = pivot_dimension_create (table, PIVOT_AXIS_COLUMN, N_("Attribute"));
+ pivot_category_create_group (attr_dimension->root, N_("Dimension"),
+ N_("Rows"), N_("Columns"));
+ pivot_category_create_leaves (attr_dimension->root, N_("Size (kB)"));
const struct matrix_var **vars = xmalloc (hmap_count (&s->vars) * sizeof *vars);
size_t n_vars = 0;
for (size_t j = 0; j < sizeof values / sizeof *values; j++)
pivot_table_put2 (table, j, i, pivot_value_new_integer (values[j]));
}
+ free (vars);
pivot_table_submit (table);
}
\f
}
}
\f
+static struct save_file *
+save_file_create (struct matrix_state *s, struct file_handle *fh,
+ struct string_array *variables,
+ struct matrix_expr *names,
+ struct stringi_set *strings)
+{
+ for (size_t i = 0; i < s->n_save_files; i++)
+ {
+ struct save_file *sf = s->save_files[i];
+ if (fh_equal (sf->file, fh))
+ {
+ fh_unref (fh);
+
+ string_array_destroy (variables);
+ matrix_expr_destroy (names);
+ stringi_set_destroy (strings);
+
+ return sf;
+ }
+ }
+
+ struct save_file *sf = xmalloc (sizeof *sf);
+ *sf = (struct save_file) {
+ .file = fh,
+ .dataset = s->dataset,
+ .variables = *variables,
+ .names = names,
+ .strings = STRINGI_SET_INITIALIZER (sf->strings),
+ };
+
+ stringi_set_swap (&sf->strings, strings);
+ stringi_set_destroy (strings);
+
+ s->save_files = xrealloc (s->save_files,
+ (s->n_save_files + 1) * sizeof *s->save_files);
+ s->save_files[s->n_save_files++] = sf;
+ return sf;
+}
+
+static struct casewriter *
+save_file_open (struct save_file *sf, gsl_matrix *m)
+{
+ if (sf->writer || sf->error)
+ {
+ if (sf->writer)
+ {
+ size_t n_variables = caseproto_get_n_widths (
+ casewriter_get_proto (sf->writer));
+ if (m->size2 != n_variables)
+ {
+ msg (ME, _("The first SAVE to %s within this matrix program "
+ "had %zu columns, so a %zu×%zu matrix cannot be "
+ "saved to it."),
+ sf->file == fh_inline_file () ? "*" : fh_get_name (sf->file),
+ n_variables, m->size1, m->size2);
+ return NULL;
+ }
+ }
+ return sf->writer;
+ }
+
+ bool ok = true;
+ struct dictionary *dict = dict_create (get_default_encoding ());
+
+ /* Fill 'names' with user-specified names if there were any, either from
+ sf->variables or sf->names. */
+ struct string_array names = { .n = 0 };
+ if (sf->variables.n)
+ string_array_clone (&names, &sf->variables);
+ else if (sf->names)
+ {
+ gsl_matrix *nm = matrix_expr_evaluate (sf->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;
+ }
+ }
+ gsl_matrix_free (nm);
+ }
+
+ struct stringi_set strings;
+ stringi_set_clone (&strings, &sf->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 (ME, _("Duplicate variable name %s in SAVE statement."),
+ name);
+ ok = false;
+ }
+ }
+
+ if (!stringi_set_is_empty (&strings))
+ {
+ size_t count = stringi_set_count (&strings);
+ const char *example = stringi_set_node_get_string (
+ stringi_set_first (&strings));
+
+ if (count == 1)
+ msg (ME, _("The SAVE command STRINGS subcommand specifies an unknown "
+ "variable %s."), example);
+ else
+ msg (ME, ngettext ("The SAVE command STRINGS subcommand specifies %zu "
+ "unknown variable: %s.",
+ "The SAVE command STRINGS subcommand specifies %zu "
+ "unknown variables, including %s.",
+ count),
+ count, example);
+ ok = false;
+ }
+ stringi_set_destroy (&strings);
+ string_array_destroy (&names);
+
+ if (!ok)
+ {
+ dict_unref (dict);
+ sf->error = true;
+ return NULL;
+ }
+
+ if (sf->file == fh_inline_file ())
+ sf->writer = autopaging_writer_create (dict_get_proto (dict));
+ else
+ sf->writer = any_writer_open (sf->file, dict);
+ if (sf->writer)
+ sf->dict = dict;
+ else
+ {
+ dict_unref (dict);
+ sf->error = true;
+ }
+ return sf->writer;
+}
+
+static void
+save_file_destroy (struct save_file *sf)
+{
+ if (sf)
+ {
+ if (sf->file == fh_inline_file () && sf->writer && sf->dict)
+ {
+ dataset_set_dict (sf->dataset, sf->dict);
+ dataset_set_source (sf->dataset, casewriter_make_reader (sf->writer));
+ }
+ else
+ {
+ casewriter_destroy (sf->writer);
+ dict_unref (sf->dict);
+ }
+ fh_unref (sf->file);
+ string_array_destroy (&sf->variables);
+ matrix_expr_destroy (sf->names);
+ stringi_set_destroy (&sf->strings);
+ free (sf);
+ }
+}
+
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)
- }
+ .save = { .expression = NULL },
};
+ struct file_handle *fh = NULL;
struct save_command *save = &cmd->save;
+
+ struct string_array variables = STRING_ARRAY_INITIALIZER;
+ struct matrix_expr *names = NULL;
+ struct stringi_set strings = STRINGI_SET_INITIALIZER (strings);
+
save->expression = matrix_parse_exp (s);
if (!save->expression)
goto error;
{
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)
+ fh_unref (fh);
+ fh = (lex_match (s->lexer, T_ASTERISK)
+ ? fh_inline_file ()
+ : fh_parse (s->lexer, FH_REF_FILE, s->session));
+ if (!fh)
goto error;
}
else if (lex_match_id (s->lexer, "VARIABLES"))
if (!ok)
goto error;
- string_array_destroy (save->variables);
- if (!save->variables)
- save->variables = xmalloc (sizeof *save->variables);
- *save->variables = (struct string_array) {
+ string_array_clear (&variables);
+ 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)
+ matrix_expr_destroy (names);
+ names = matrix_parse_exp (s);
+ if (!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));
+ stringi_set_insert (&strings, lex_tokcstr (s->lexer));
lex_get (s->lexer);
if (!lex_match (s->lexer, T_COMMA))
break;
}
}
- if (!save->outfile)
+ if (!fh)
{
- if (s->prev_save_outfile)
- save->outfile = fh_ref (s->prev_save_outfile);
+ if (s->prev_save_file)
+ fh = fh_ref (s->prev_save_file);
else
{
lex_sbc_missing ("OUTFILE");
goto error;
}
}
- fh_unref (s->prev_save_outfile);
- s->prev_save_outfile = fh_ref (save->outfile);
+ fh_unref (s->prev_save_file);
+ s->prev_save_file = fh_ref (fh);
- if (save->variables && save->names)
+ if (variables.n && names)
{
msg (SW, _("VARIABLES and NAMES both specified; ignoring NAMES."));
- matrix_expr_destroy (save->names);
- save->names = NULL;
+ matrix_expr_destroy (names);
+ names = NULL;
}
+ save->sf = save_file_create (s, fh, &variables, names, &strings);
return cmd;
error:
+ string_array_destroy (&variables);
+ matrix_expr_destroy (names);
+ stringi_set_destroy (&strings);
+ fh_unref (fh);
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);
+ struct casewriter *writer = save_file_open (save->sf, m);
if (!writer)
{
gsl_matrix_free (m);
- dict_unref (dict);
return;
}
- const struct caseproto *proto = dict_get_proto (dict);
+ const struct caseproto *proto = casewriter_get_proto (writer);
for (size_t y = 0; y < m->size1; y++)
{
struct ccase *c = case_create (proto);
}
casewriter_write (writer, c);
}
- casewriter_destroy (writer);
-
gsl_matrix_free (m);
- dict_unref (dict);
}
\f
static struct matrix_cmd *
else if (lex_match_id (s->lexer, "SIZE"))
{
lex_match (s->lexer, T_EQUALS);
+ matrix_expr_destroy (read->size);
read->size = matrix_parse_exp (s);
if (!read->size)
goto error;
}
lex_get (s->lexer);
}
- else if (!fmt_from_name (p, &read->format))
+ else if (fmt_from_name (p, &read->format))
+ lex_get (s->lexer);
+ else
{
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
s->prev_read_file = fh_ref (fh);
read->rf = read_file_create (s, fh);
+ fh = NULL;
if (encoding)
{
free (read->rf->encoding);
return cmd;
error:
+ fh_unref (fh);
matrix_cmd_destroy (cmd);
free (encoding);
return NULL;
}
+static void
+parse_error (const struct dfm_reader *reader, enum fmt_type format,
+ struct substring data, size_t y, size_t x,
+ int first_column, int last_column, char *error)
+{
+ int line_number = dfm_get_line_number (reader);
+ struct msg_location *location = xmalloc (sizeof *location);
+ *location = (struct msg_location) {
+ .file_name = xstrdup (dfm_get_file_name (reader)),
+ .first_line = line_number,
+ .last_line = line_number + 1,
+ .first_column = first_column,
+ .last_column = last_column,
+ };
+ struct msg *m = xmalloc (sizeof *m);
+ *m = (struct msg) {
+ .category = MSG_C_DATA,
+ .severity = MSG_S_WARNING,
+ .location = location,
+ .text = xasprintf (_("Error reading \"%.*s\" as format %s "
+ "for matrix row %zu, column %zu: %s"),
+ (int) data.length, data.string, fmt_name (format),
+ y + 1, x + 1, error),
+ };
+ msg_emit (m);
+
+ free (error);
+}
+
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)
+ gsl_matrix *m, struct substring p, size_t y, size_t x,
+ const char *line_start)
{
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 */
+ char *error;
+ double f;
+ if (fmt_is_numeric (read->format))
+ {
+ union value v;
+ error = data_in (p, input_encoding, read->format,
+ settings_get_fmt_settings (), &v, 0, NULL);
+ if (!error && v.f == SYSMIS)
+ error = xstrdup (_("Matrix data may not contain missing value."));
+ f = v.f;
+ }
+ else
+ {
+ uint8_t s[sizeof (double)];
+ union value v = { .s = s };
+ error = data_in (p, input_encoding, read->format,
+ settings_get_fmt_settings (), &v, sizeof s, "UTF-8");
+ memcpy (&f, s, sizeof f);
+ }
+
if (error)
- msg (SW, _("GET parse error (%.*s): %s"), (int) p.length, p.string, error);
+ {
+ int c1 = utf8_count_columns (line_start, p.string - line_start) + 1;
+ int c2 = c1 + ss_utf8_count_columns (p) - 1;
+ parse_error (reader, read->format, p, y, x, c1, c2, error);
+ }
else
{
- gsl_matrix_set (m, y, x, v.f);
+ gsl_matrix_set (m, y, x, f);
if (read->symmetric && x != y)
- gsl_matrix_set (m, x, y, v.f);
+ gsl_matrix_set (m, x, y, f);
}
}
static bool
matrix_read_line (struct read_command *read, struct dfm_reader *reader,
- struct substring *line)
+ struct substring *line, const char **startp)
{
if (dfm_eof (reader))
{
return false;
}
dfm_expand_tabs (reader);
- *line = ss_substr (dfm_get_record (reader),
- read->c1 - 1, read->c2 - read->c1);
+ struct substring record = dfm_get_record (reader);
+ /* XXX need to recode record into UTF-8 */
+ *startp = record.string;
+ *line = ss_utf8_columns (record, read->c1 - 1, read->c2 - read->c1);
return true;
}
size_t nx = read->symmetric ? y + 1 : m->size2;
struct substring line = ss_empty ();
+ const char *line_start = line.string;
for (size_t x = 0; x < nx; x++)
{
struct substring p;
ss_ltrim (&line, ss_cstr (" ,"));
if (!ss_is_empty (line))
break;
- if (!matrix_read_line (read, reader, &line))
+ if (!matrix_read_line (read, reader, &line, &line_start))
return;
dfm_forward_record (reader);
}
}
else
{
- if (!matrix_read_line (read, reader, &line))
+ if (!matrix_read_line (read, reader, &line, &line_start))
return;
size_t fields_per_line = (read->c2 - read->c1) / read->w;
int f = x % fields_per_line;
p = ss_substr (line, read->w * f, read->w);
}
- matrix_read_set_field (read, reader, m, p, y, x);
+ matrix_read_set_field (read, reader, m, p, y, x, line_start);
}
if (read->w)
{
ss_ltrim (&line, ss_cstr (" ,"));
if (!ss_is_empty (line))
- msg (SW, _("Trailing garbage on line \"%.*s\""),
- (int) line.length, line.string);
+ {
+ /* XXX */
+ msg (SW, _("Trailing garbage on line \"%.*s\""),
+ (int) line.length, line.string);
+ }
}
}
}
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]);
+ msg (SE, _("Matrix dimensions %g×%g specified on SIZE "
+ "are outside valid range."),
+ d[0], d[1]);
free (iv0.indexes);
free (iv1.indexes);
return;
{
if (size[0] != submatrix_size[0] || size[1] != submatrix_size[1])
{
- msg (SE, _("SIZE (%zu,%zu) differs from submatrix dimensions "
- "%zu×%zu."),
+ msg (SE, _("Matrix dimensions %zu×%zu specified on SIZE "
+ "differ from submatrix dimensions %zu×%zu."),
size[0], size[1],
submatrix_size[0], submatrix_size[1]);
free (iv0.indexes);
struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
*cmd = (struct matrix_cmd) {
.type = MCMD_WRITE,
- .write = { .format = FMT_F },
};
+ struct file_handle *fh = NULL;
+ char *encoding = NULL;
struct write_command *write = &cmd->write;
write->expression = matrix_parse_exp (s);
if (!write->expression)
int by = 0;
int repetitions = 0;
int record_width = 0;
- bool seen_format = false;
+ enum fmt_type format = FMT_F;
+ bool has_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)
+ fh_unref (fh);
+ fh = fh_parse (s->lexer, FH_REF_FILE, NULL);
+ if (!fh)
goto error;
}
else if (lex_match_id (s->lexer, "ENCODING"))
if (!lex_force_string (s->lexer))
goto error;
- free (write->encoding);
- write->encoding = ss_xstrdup (lex_tokss (s->lexer));
+ free (encoding);
+ encoding = ss_xstrdup (lex_tokss (s->lexer));
lex_get (s->lexer);
}
write->hold = true;
else if (lex_match_id (s->lexer, "FORMAT"))
{
- if (seen_format)
+ if (has_format || write->format)
{
lex_sbc_only_once ("FORMAT");
goto error;
}
- seen_format = true;
lex_match (s->lexer, T_EQUALS);
{
repetitions = atoi (p);
p += strspn (p, "0123456789");
- if (!fmt_from_name (p, &write->format))
+ if (!fmt_from_name (p, &format))
{
lex_error (s->lexer, _("Unknown format %s."), p);
goto error;
}
+ has_format = true;
lex_get (s->lexer);
}
- else if (!fmt_from_name (p, &write->format))
+ else if (fmt_from_name (p, &format))
{
- struct fmt_spec format;
- if (!parse_format_specifier (s->lexer, &format))
+ has_format = true;
+ lex_get (s->lexer);
+ }
+ else
+ {
+ struct fmt_spec spec;
+ if (!parse_format_specifier (s->lexer, &spec))
goto error;
- write->format = format.type;
- write->w = format.w;
- write->d = format.d;
+ write->format = xmemdup (&spec, sizeof spec);
}
}
else
goto error;
}
- if (!write->outfile)
+ if (!fh)
{
- if (s->prev_write_outfile)
- write->outfile = fh_ref (s->prev_write_outfile);
+ if (s->prev_write_file)
+ fh = fh_ref (s->prev_write_file);
else
{
lex_sbc_missing ("OUTFILE");
goto error;
}
}
- fh_unref (s->prev_write_outfile);
- s->prev_write_outfile = fh_ref (write->outfile);
+ fh_unref (s->prev_write_file);
+ s->prev_write_file = fh_ref (fh);
+
+ write->wf = write_file_create (s, fh);
+ fh = NULL;
+ if (encoding)
+ {
+ free (write->wf->encoding);
+ write->wf->encoding = encoding;
+ encoding = NULL;
+ }
/* Field width may be specified in multiple ways:
goto error;
}
int w = (repetitions ? record_width / repetitions
- : write->w ? write->w
+ : write->format ? write->format->w
: by);
if (by && w != by)
{
w, by);
goto error;
}
- write->w = w;
+ if (w && !write->format)
+ {
+ write->format = xmalloc (sizeof *write->format);
+ *write->format = (struct fmt_spec) { .type = format, .w = w };
+
+ if (!fmt_check_output (write->format))
+ goto error;
+ };
+
+ if (write->format && fmt_var_width (write->format) > sizeof (double))
+ {
+ char s[FMT_STRING_LEN_MAX + 1];
+ fmt_to_string (write->format, s);
+ msg (SE, _("Format %s is too wide for %zu-byte matrix eleemnts."),
+ s, sizeof (double));
+ goto error;
+ }
+
return cmd;
error:
+ fh_unref (fh);
matrix_cmd_destroy (cmd);
return NULL;
}
return;
}
- struct dfm_writer *writer = dfm_open_writer (write->outfile, write->encoding);
- if (!writer)
+ struct dfm_writer *writer = write_file_open (write->wf);
+ if (!writer || !m->size1)
{
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;
+ struct u8_line *line = write->wf->held;
for (size_t y = 0; y < m->size1; y++)
{
+ if (!line)
+ {
+ line = xmalloc (sizeof *line);
+ u8_line_init (line);
+ }
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));
+ char *s;
+ double f = gsl_matrix_get (m, y, x);
+ if (write->format)
+ {
+ union value v;
+ if (fmt_is_numeric (write->format->type))
+ v.f = f;
+ else
+ v.s = (uint8_t *) &f;
+ s = data_out (&v, NULL, write->format, settings);
+ }
+ else
+ {
+ s = xmalloc (DBL_BUFSIZE_BOUND);
+ if (c_dtoastr (s, DBL_BUFSIZE_BOUND, FTOASTR_UPPER_E, 0, f)
+ >= DBL_BUFSIZE_BOUND)
+ abort ();
+ }
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);
+ 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);
+ u8_line_put (line, x0, x0 + width, s, len);
free (s);
- x0 += write->w ? write->w : width + 1;
+ x0 += write->format ? write->format->w : width + 1;
}
- dfm_put_record_utf8 (writer, line.s.ss.string, line.s.ss.length);
- u8_line_clear (&line);
+ if (y + 1 >= m->size1 && write->hold)
+ break;
+ dfm_put_record_utf8 (writer, line->s.ss.string, line->s.ss.length);
+ u8_line_clear (line);
+ }
+ if (!write->hold)
+ {
+ u8_line_destroy (line);
+ free (line);
+ line = NULL;
}
- u8_line_destroy (&line);
- dfm_close_writer (writer);
+ write->wf->held = line;
gsl_matrix_free (m);
}
*cmd = (struct matrix_cmd) {
.type = MCMD_GET,
.get = {
+ .dataset = s->dataset,
.user = { .treatment = MGET_ERROR },
.system = { .treatment = MGET_ERROR },
}
{
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;
+ if (lex_match (s->lexer, T_ASTERISK))
+ get->file = NULL;
+ else
+ {
+ 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;
{
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)
+ if (get->n_vars)
{
- dict_unref (dict);
+ lex_sbc_only_once ("VARIABLES");
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);
+ if (!var_syntax_parse (s->lexer, &get->vars, &get->n_vars))
+ goto error;
}
else if (lex_match_id (s->lexer, "NAMES"))
{
{
lex_match (s->lexer, T_EQUALS);
if (lex_match_id (s->lexer, "OMIT"))
- get->user.treatment = MGET_OMIT;
+ get->system.treatment = MGET_OMIT;
else if (lex_is_number (s->lexer))
{
- get->user.treatment = MGET_RECODE;
- get->user.substitute = lex_number (s->lexer);
+ get->system.treatment = MGET_RECODE;
+ get->system.substitute = lex_number (s->lexer);
lex_get (s->lexer);
}
else
goto error;
}
}
+
+ if (get->user.treatment != MGET_ACCEPT)
+ get->system.treatment = MGET_ERROR;
+
return cmd;
error:
}
static void
-matrix_cmd_execute_get (struct get_command *get)
+matrix_cmd_execute_get__ (struct get_command *get, struct casereader *reader,
+ const struct dictionary *dict)
{
- 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);
+ struct variable **vars;
size_t n_vars = 0;
- if (get->variables.n)
+ if (get->n_vars)
{
- 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;
- }
+ if (!var_syntax_evaluate (get->vars, get->n_vars, dict,
+ &vars, &n_vars, PV_NUMERIC))
+ return;
}
else
{
- for (size_t i = 0; i < dict_get_var_cnt (dict); i++)
+ n_vars = dict_get_var_cnt (dict);
+ vars = xnmalloc (n_vars, sizeof *vars);
+ for (size_t i = 0; i < n_vars; i++)
{
- const struct variable *var = dict_get_var (dict, i);
+ 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;
+ vars[i] = var;
}
}
+ if (get->names)
+ {
+ gsl_matrix *names = gsl_matrix_alloc (n_vars, 1);
+ for (size_t i = 0; i < n_vars; i++)
+ {
+ char s[sizeof (double)];
+ double f;
+ buf_copy_str_rpad (s, sizeof s, var_get_name (vars[i]), ' ');
+ memcpy (&f, s, sizeof f);
+ gsl_matrix_set (names, i, 0, f);
+ }
+
+ gsl_matrix_free (get->names->value);
+ get->names->value = names;
+ }
+
size_t n_rows = 0;
gsl_matrix *m = gsl_matrix_alloc (4, n_vars);
long long int casenum = 1;
if (keep)
n_rows++;
}
- casereader_destroy (reader);
if (!error)
{
m->size1 = n_rows;
}
else
gsl_matrix_free (m);
- dict_unref (dict);
free (vars);
}
+
+static bool
+matrix_open_casereader (const char *command_name,
+ struct file_handle *file, const char *encoding,
+ struct dataset *dataset,
+ struct casereader **readerp, struct dictionary **dictp)
+{
+ if (file)
+ {
+ *readerp = any_reader_open_and_decode (file, encoding, dictp, NULL);
+ return *readerp != NULL;
+ }
+ else
+ {
+ if (dict_get_var_cnt (dataset_dict (dataset)) == 0)
+ {
+ msg (ME, _("The %s command cannot read an empty active file."),
+ command_name);
+ return false;
+ }
+ *readerp = proc_open (dataset);
+ *dictp = dict_ref (dataset_dict (dataset));
+ return true;
+ }
+}
+
+static void
+matrix_close_casereader (struct file_handle *file, struct dataset *dataset,
+ struct casereader *reader, struct dictionary *dict)
+{
+ dict_unref (dict);
+ casereader_destroy (reader);
+ if (!file)
+ proc_commit (dataset);
+}
+
+static void
+matrix_cmd_execute_get (struct get_command *get)
+{
+ struct casereader *r;
+ struct dictionary *d;
+ if (matrix_open_casereader ("GET", get->file, get->encoding, get->dataset,
+ &r, &d))
+ {
+ matrix_cmd_execute_get__ (get, r, d);
+ matrix_close_casereader (get->file, get->dataset, r, d);
+ }
+}
\f
static const char *
match_rowtype (struct lexer *lexer)
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,
if (ok)
{
+ for (size_t i = 0; i < n_names; i++)
+ if (ss_equals_case (ss_cstr (names[i]), ss_cstr ("ROWTYPE_"))
+ || ss_equals_case (ss_cstr (names[i]), ss_cstr ("VARNAME_")))
+ {
+ msg (SE, _("Variable name %s is reserved."), names[i]);
+ for (size_t j = 0; j < n_names; j++)
+ free (names[i]);
+ free (names);
+ return false;
+ }
+
string_array_clear (sa);
sa->strings = names;
sa->n = sa->allocated = n_names;
}
static void
-msave_common_uninit (struct msave_common *common)
+msave_common_destroy (struct msave_common *common)
{
if (common)
{
string_array_destroy (&common->variables);
string_array_destroy (&common->fnames);
string_array_destroy (&common->snames);
+
+ for (size_t i = 0; i < common->n_factors; i++)
+ matrix_expr_destroy (common->factors[i]);
+ free (common->factors);
+
+ for (size_t i = 0; i < common->n_splits; i++)
+ matrix_expr_destroy (common->splits[i]);
+ free (common->splits);
+
+ dict_unref (common->dict);
+ casewriter_destroy (common->writer);
+
+ free (common);
}
}
static struct matrix_cmd *
matrix_parse_msave (struct matrix_state *s)
{
- struct msave_common common = { .outfile = NULL };
+ struct msave_common *common = xmalloc (sizeof *common);
+ *common = (struct msave_common) { .outfile = NULL };
+
struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
*cmd = (struct matrix_cmd) { .type = MCMD_MSAVE, .msave = { .expr = NULL } };
+ struct matrix_expr *splits = NULL;
+ struct matrix_expr *factors = 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;
+ goto error;
while (lex_match (s->lexer, T_SLASH))
{
{
lex_match (s->lexer, T_EQUALS);
- fh_unref (common.outfile);
- common.outfile = fh_parse (s->lexer, FH_REF_FILE, NULL);
- if (!common.outfile)
+ 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))
+ 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))
+ 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))
+ 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)
+ matrix_expr_destroy (splits);
+ splits = matrix_parse_exp (s);
+ if (!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)
+ matrix_expr_destroy (factors);
+ factors = matrix_parse_exp (s);
+ if (!factors)
goto error;
}
else
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)
+ if (common->fnames.n && !factors)
+ {
+ msg (SE, _("FNAMES requires FACTOR."));
+ goto error;
+ }
+ if (common->snames.n && !splits)
+ {
+ msg (SE, _("SNAMES requires SPLIT."));
+ goto error;
+ }
+ if (!common->outfile)
{
lex_sbc_missing ("OUTFILE");
goto error;
}
- s->common = xmemdup (&common, sizeof common);
+ s->common = common;
}
else
{
- if (common.outfile)
+ if (common->outfile)
{
- bool same = common.outfile == s->common->outfile;
- fh_unref (common.outfile);
- if (!same)
+ if (!fh_equal (common->outfile, s->common->outfile))
{
msg (SE, _("OUTFILE must name the same file on each MSAVE "
"within a single MATRIX command."));
}
}
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))
+ &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_destroy (common);
}
msave->common = s->common;
- if (!msave->varname_)
- msave->varname_ = xasprintf ("MAT%zu", ++s->common->n_varnames);
+
+ struct msave_common *c = s->common;
+ if (factors)
+ {
+ if (c->n_factors >= c->allocated_factors)
+ c->factors = x2nrealloc (c->factors, &c->allocated_factors,
+ sizeof *c->factors);
+ c->factors[c->n_factors++] = factors;
+ }
+ if (c->n_factors > 0)
+ msave->factors = c->factors[c->n_factors - 1];
+
+ if (splits)
+ {
+ if (c->n_splits >= c->allocated_splits)
+ c->splits = x2nrealloc (c->splits, &c->allocated_splits,
+ sizeof *c->splits);
+ c->splits[c->n_splits++] = splits;
+ }
+ if (c->n_splits > 0)
+ msave->splits = c->splits[c->n_splits - 1];
+
return cmd;
error:
- msave_common_uninit (&common);
+ matrix_expr_destroy (splits);
+ matrix_expr_destroy (factors);
+ msave_common_destroy (common);
matrix_cmd_destroy (cmd);
return NULL;
}
static gsl_vector *
-matrix_expr_evaluate_vector (struct matrix_expr *e, const char *name)
+matrix_expr_evaluate_vector (const struct matrix_expr *e, const char *name)
{
gsl_matrix *m = matrix_expr_evaluate (e);
if (!m)
const char *dup_split = msave_add_vars (dict, &common->snames);
if (dup_split)
{
- msg (SE, _("Duplicate SPLIT variable name %s."), dup_split);
- goto error;
+ /* Should not be possible because the parser ensures that the names are
+ unique. */
+ NOT_REACHED ();
}
dict_create_var_assert (dict, "ROWTYPE_", 8);
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)
+ else if (m->size2 != common->variables.n)
{
- msg (SE, _("Matrix on MSAVE has %zu columns instead of required %zu."),
+ msg (SE,
+ _("Matrix on MSAVE has %zu columns but there are %zu variables."),
m->size2, common->variables.n);
goto error;
}
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)
+ else if (factors->size != common->fnames.n)
{
msg (SE, _("There are %zu factor variables, "
- "but %zu split values were supplied."),
+ "but %zu factor values were supplied."),
common->fnames.n, factors->size);
goto error;
}
if (!splits)
goto error;
- if (!common->fnames.n)
+ if (!common->snames.n)
for (size_t i = 0; i < splits->size; i++)
- string_array_append_nocopy (&common->fnames,
+ string_array_append_nocopy (&common->snames,
xasprintf ("SPL%zu", i + 1));
-
- if (splits->size != common->fnames.n)
+ else if (splits->size != common->snames.n)
{
msg (SE, _("There are %zu split variables, "
"but %zu split values were supplied."),
- common->fnames.n, splits->size);
+ common->snames.n, splits->size);
goto error;
}
}
common->dict = dict;
}
+ bool matrix = (!strcmp (msave->rowtype, "COV")
+ || !strcmp (msave->rowtype, "CORR"));
for (size_t y = 0; y < m->size1; y++)
{
struct ccase *c = case_create (dict_get_proto (common->dict));
*case_num_rw_idx (c, idx++) = gsl_vector_get (factors, i);
/* VARNAME_. */
+ const char *varname_ = (matrix && y < common->variables.n
+ ? common->variables.strings[y]
+ : "");
buf_copy_str_rpad (CHAR_CAST (char *, case_data_rw_idx (c, idx++)->s), 8,
- msave->varname_, ' ');
+ varname_, ' ');
/* Continuous variables. */
for (size_t x = 0; x < m->size2; x++)
matrix_parse_mget (struct matrix_state *s)
{
struct matrix_cmd *cmd = xmalloc (sizeof *cmd);
- *cmd = (struct matrix_cmd) { .type = MCMD_MGET, .mget = { .state = s } };
+ *cmd = (struct matrix_cmd) {
+ .type = MCMD_MGET,
+ .mget = {
+ .state = s,
+ .rowtypes = STRINGI_SET_INITIALIZER (cmd->mget.rowtypes),
+ },
+ };
struct mget_command *mget = &cmd->mget;
- for (;;)
+ lex_match (s->lexer, T_SLASH);
+ while (lex_token (s->lexer) != T_ENDCMD)
{
if (lex_match_id (s->lexer, "FILE"))
{
if (!mget->file)
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 (mget->encoding);
+ mget->encoding = ss_xstrdup (lex_tokss (s->lexer));
+
+ lex_get (s->lexer);
+ }
else if (lex_match_id (s->lexer, "TYPE"))
{
lex_match (s->lexer, T_EQUALS);
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;
+ lex_match (s->lexer, T_SLASH);
}
return cmd;
}
static bool
-is_rowtype (const union value *v, const char *rowtype)
+var_changed (const struct ccase *ca, const struct ccase *cb,
+ const struct variable *var)
+{
+ return (ca && cb
+ ? !value_equal (case_data (ca, var), case_data (cb, var),
+ var_get_width (var))
+ : ca || cb);
+}
+
+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 bool
+vars_all_missing (const struct ccase *c, const struct dictionary *d,
+ size_t first_var, size_t n_vars)
{
- struct substring vs = ss_buffer (CHAR_CAST (char *, v->s), 8);
- ss_rtrim (&vs, ss_cstr (" "));
- return ss_equals_case (vs, ss_cstr (rowtype));
+ for (size_t i = 0; i < n_vars; i++)
+ if (case_num (c, dict_get_var (d, first_var + i)) != SYSMIS)
+ return false;
+ return true;
}
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)
+ const struct stringi_set *accepted_rowtypes,
+ struct matrix_state *s,
+ size_t ss, size_t sn, size_t si,
+ size_t fs, size_t fn, size_t fi,
+ size_t cs, size_t cn,
+ struct pivot_table *pt,
+ struct pivot_dimension *var_dimension)
{
if (!n_rows)
- return;
+ goto exit;
+
+ /* Is this a matrix for pooled data, either where there are no factor
+ variables or the factor variables are missing? */
+ bool pooled = !fn || vars_all_missing (rows[0], d, fs, fn);
- 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 substring rowtype = case_ss (rows[0], rowtype_var);
+ ss_rtrim (&rowtype, ss_cstr (" "));
+ if (!stringi_set_is_empty (accepted_rowtypes)
+ && !stringi_set_contains_len (accepted_rowtypes,
+ rowtype.string, rowtype.length))
+ goto exit;
+
+ const char *prefix = (ss_equals_case (rowtype, ss_cstr ("COV")) ? "CV"
+ : ss_equals_case (rowtype, ss_cstr ("CORR")) ? "CR"
+ : ss_equals_case (rowtype, ss_cstr ("MEAN")) ? "MN"
+ : ss_equals_case (rowtype, ss_cstr ("STDDEV")) ? "SD"
+ : ss_equals_case (rowtype, ss_cstr ("N")) ? "NC"
+ : ss_equals_case (rowtype, ss_cstr ("COUNT")) ? "CN"
+ : NULL);
+ if (!prefix)
+ {
+ msg (SE, _("Matrix data file contains unknown ROWTYPE_ \"%.*s\"."),
+ (int) rowtype.length, rowtype.string);
+ goto exit;
+ }
struct string name = DS_EMPTY_INITIALIZER;
- ds_put_cstr (&name, name_prefix);
- if (fi > 0)
+ ds_put_cstr (&name, prefix);
+ if (!pooled)
ds_put_format (&name, "F%zu", fi);
if (si > 0)
ds_put_format (&name, "S%zu", si);
{
msg (SW, _("Matrix data file contains variable with existing name %s."),
ds_cstr (&name));
- goto exit;
+ goto exit_free_name;
}
gsl_matrix *m = gsl_matrix_alloc (n_rows, cn);
}
}
+ int var_index = pivot_category_create_leaf (
+ var_dimension->root, pivot_value_new_user_text (ds_cstr (&name), SIZE_MAX));
+ double values[] = { n_rows, cn };
+ for (size_t j = 0; j < sn; j++)
+ {
+ struct variable *var = dict_get_var (d, ss + j);
+ const union value *value = case_data (rows[0], var);
+ pivot_table_put2 (pt, j, var_index,
+ pivot_value_new_var_value (var, value));
+ }
+ for (size_t j = 0; j < fn; j++)
+ {
+ struct variable *var = dict_get_var (d, fs + j);
+ const union value sysmis = { .f = SYSMIS };
+ const union value *value = pooled ? &sysmis : case_data (rows[0], var);
+ pivot_table_put2 (pt, j + sn, var_index,
+ pivot_value_new_var_value (var, value));
+ }
+ for (size_t j = 0; j < sizeof values / sizeof *values; j++)
+ pivot_table_put2 (pt, j + sn + fn, var_index,
+ pivot_value_new_integer (values[j]));
+
if (n_missing)
msg (SE, ngettext ("Matrix data file variable %s contains a missing "
"value, which was treated as zero.",
ds_cstr (&name), n_missing);
mv->value = m;
-exit:
+exit_free_name:
ds_destroy (&name);
+
+exit:
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)
+matrix_cmd_execute_mget__ (struct mget_command *mget,
+ struct casereader *r, const struct dictionary *d)
{
- 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;
+ return;
if (var_get_dict_index (rowtype_) >= var_get_dict_index (varname_))
{
msg (SE, _("ROWTYPE_ must precede VARNAME_ in matrix data file."));
- goto exit;
+ return;
}
if (var_get_dict_index (varname_) + 1 >= dict_get_var_cnt (d))
{
msg (SE, _("Matrix data file contains no continuous variables."));
- goto exit;
+ return;
}
for (size_t i = 0; i < dict_get_var_cnt (d); i++)
msg (SE,
_("Matrix data file contains unexpected string variable %s."),
var_get_name (v));
- goto exit;
+ return;
}
}
size_t cn = dict_get_var_cnt (d) - cs;
struct ccase *cc = NULL;
+ /* Pivot table. */
+ struct pivot_table *pt = pivot_table_create (
+ N_("Matrix Variables Created by MGET"));
+ struct pivot_dimension *attr_dimension = pivot_dimension_create (
+ pt, PIVOT_AXIS_COLUMN, N_("Attribute"));
+ struct pivot_dimension *var_dimension = pivot_dimension_create (
+ pt, PIVOT_AXIS_ROW, N_("Variable"));
+ if (sn > 0)
+ {
+ struct pivot_category *splits = pivot_category_create_group (
+ attr_dimension->root, N_("Split Values"));
+ for (size_t i = 0; i < sn; i++)
+ pivot_category_create_leaf (splits, pivot_value_new_variable (
+ dict_get_var (d, ss + i)));
+ }
+ if (fn > 0)
+ {
+ struct pivot_category *factors = pivot_category_create_group (
+ attr_dimension->root, N_("Factors"));
+ for (size_t i = 0; i < fn; i++)
+ pivot_category_create_leaf (factors, pivot_value_new_variable (
+ dict_get_var (d, fs + i)));
+ }
+ pivot_category_create_group (attr_dimension->root, N_("Dimensions"),
+ N_("Rows"), N_("Columns"));
+
/* Matrix. */
struct ccase **rows = NULL;
size_t allocated_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)
+ bool row_has_factors = fn && !vars_all_missing (c, d, fs, fn);
+
+ enum
{
- fi++;
- case_unref (fc);
- fc = case_ref (c);
+ SPLITS_CHANGED,
+ FACTORS_CHANGED,
+ ROWTYPE_CHANGED,
+ NOTHING_CHANGED
}
- if (md)
+ change
+ = (sn && (!sc || vars_changed (sc, c, d, ss, sn)) ? SPLITS_CHANGED
+ : fn && (!fc || vars_changed (fc, c, d, fs, fn)) ? FACTORS_CHANGED
+ : !cc || var_changed (cc, c, rowtype_) ? ROWTYPE_CHANGED
+ : NOTHING_CHANGED);
+
+ if (change != NOTHING_CHANGED)
{
- matrix_mget_commit_var (rows, n_rows, d, rowtype_,
- mget->state, si, fi, cs, cn);
+ matrix_mget_commit_var (rows, n_rows, d,
+ rowtype_, &mget->rowtypes,
+ mget->state,
+ ss, sn, si,
+ fs, fn, fi,
+ cs, cn,
+ pt, var_dimension);
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;
+
+ if (change == SPLITS_CHANGED)
+ {
+ si++;
+ case_unref (sc);
+ sc = case_ref (c);
+
+ /* Reset the factor number, if there are factors. */
+ if (fn)
+ {
+ fi = 0;
+ if (row_has_factors)
+ fi++;
+ case_unref (fc);
+ fc = case_ref (c);
+ }
+ }
+ else if (change == FACTORS_CHANGED)
+ {
+ if (row_has_factors)
+ fi++;
+ case_unref (fc);
+ fc = case_ref (c);
+ }
}
- matrix_mget_commit_var (rows, n_rows, d, rowtype_,
- mget->state, si, fi, cs, cn);
+ matrix_mget_commit_var (rows, n_rows, d,
+ rowtype_, &mget->rowtypes,
+ mget->state,
+ ss, sn, si,
+ fs, fn, fi,
+ cs, cn,
+ pt, var_dimension);
free (rows);
-exit:
- casereader_destroy (r);
+ case_unref (sc);
+ case_unref (fc);
+ case_unref (cc);
+
+ if (var_dimension->n_leaves)
+ pivot_table_submit (pt);
+ else
+ pivot_table_unref (pt);
+}
+
+static void
+matrix_cmd_execute_mget (struct mget_command *mget)
+{
+ struct casereader *r;
+ struct dictionary *d;
+ if (matrix_open_casereader ("MGET", mget->file, mget->encoding,
+ mget->state->dataset, &r, &d))
+ {
+ matrix_cmd_execute_mget__ (mget, r, d);
+ matrix_close_casereader (mget->file, mget->state->dataset, r, d);
+ }
}
\f
static bool
case MCMD_SAVE:
matrix_expr_destroy (cmd->save.expression);
- fh_unref (cmd->save.outfile);
- string_array_destroy (cmd->save.variables);
- matrix_expr_destroy (cmd->save.names);
- stringi_set_destroy (&cmd->save.strings);
break;
case MCMD_READ:
case MCMD_WRITE:
matrix_expr_destroy (cmd->write.expression);
- free (cmd->write.encoding);
+ free (cmd->write.format);
break;
case MCMD_GET:
matrix_lvalue_destroy (cmd->get.dst);
fh_unref (cmd->get.file);
free (cmd->get.encoding);
- string_array_destroy (&cmd->get.variables);
+ var_syntax_destroy (cmd->get.vars, cmd->get.n_vars);
break;
case MCMD_MSAVE:
- free (cmd->msave.varname_);
matrix_expr_destroy (cmd->msave.expr);
- matrix_expr_destroy (cmd->msave.factors);
- matrix_expr_destroy (cmd->msave.splits);
break;
case MCMD_MGET:
return CMD_FAILURE;
struct matrix_state state = {
+ .dataset = ds,
.session = dataset_session (ds),
.lexer = lexer,
.vars = HMAP_INITIALIZER (state.vars),
free (var);
}
hmap_destroy (&state.vars);
- fh_unref (state.prev_save_outfile);
- fh_unref (state.prev_write_outfile);
- if (state.common)
- {
- dict_unref (state.common->dict);
- casewriter_destroy (state.common->writer);
- free (state.common);
- }
+ msave_common_destroy (state.common);
fh_unref (state.prev_read_file);
for (size_t i = 0; i < state.n_read_files; i++)
read_file_destroy (state.read_files[i]);
free (state.read_files);
+ fh_unref (state.prev_write_file);
+ for (size_t i = 0; i < state.n_write_files; i++)
+ write_file_destroy (state.write_files[i]);
+ free (state.write_files);
+ fh_unref (state.prev_save_file);
+ for (size_t i = 0; i < state.n_save_files; i++)
+ save_file_destroy (state.save_files[i]);
+ free (state.save_files);
return CMD_SUCCESS;
}
projects / pspp / blobdiff