[pure-lang-svn] SF.net SVN: pure-lang:[833] pure/trunk

[<ag...@us...>]

Revision: 833
          http://pure-lang.svn.sourceforge.net/pure-lang/?rev=833&view=rev
Author:   agraef
Date:     2008-09-23 05:54:38 +0000 (Tue, 23 Sep 2008)

Log Message:
-----------
Make the matrix construction functions in the library throw a 'bad_matrix_value' exception in case of dimension mismatch.

Modified Paths:
--------------
    pure/trunk/lib/primitives.pure
    pure/trunk/runtime.cc
    pure/trunk/runtime.h

Modified: pure/trunk/lib/primitives.pure
===================================================================
--- pure/trunk/lib/primitives.pure	2008-09-23 05:31:30 UTC (rev 832)
+++ pure/trunk/lib/primitives.pure	2008-09-23 05:54:38 UTC (rev 833)
@@ -473,7 +473,9 @@
    converts it to a list of its elements; otherwise the result is the list of
    the rows of the matrix. You can also use list2 to convert a matrix to a
    list of lists. Conversely, matrix xs converts a list of lists or matrices
-   to the corresponding matrix. Otherwise, the result is a row vector. */
+   to the corresponding matrix; otherwise, the result is a row vector.
+   NOTE: The matrix function may throw a 'bad_matrix_value x' in case of
+   dimension mismatch, where x denotes the offending submatrix. */
 
 list x::matrix		= [x!i|i=0..#x-1] if rowvectorp x;
 			= rows x otherwise;
@@ -520,7 +522,9 @@
 /* Construct matrices from lists of rows and columns. These take either
    scalars or submatrices as inputs; corresponding dimensions must match.
    rowcat combines submatrices vertically, like {x;y}; colcat combines them
-   horizontally, like {x,y}. */
+   horizontally, like {x,y}. NOTE: Like the built-in matrix constructs, these
+   operations may throw a 'bad_matrix_value x' in case of dimension mismatch,
+   where x denotes the offending submatrix. */
 
 extern expr* matrix_rows(expr *x) = rowcat;
 extern expr* matrix_columns(expr *x) = colcat;

Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc	2008-09-23 05:31:30 UTC (rev 832)
+++ pure/trunk/runtime.cc	2008-09-23 05:54:38 UTC (rev 833)
@@ -4568,13 +4568,227 @@
   return y;
 }
 
+static pure_expr *matrix_rowsv(uint32_t n, pure_expr **xs)
+{
+  int k = -1;
+  size_t nrows = 0, ncols = 0;
+  int32_t target = 0;
+  bool have_matrix = false;
+  pure_expr *x = 0;
+  for (size_t i = 0; i < n; i++) {
+    x = xs[i];
+    switch (x->tag) {
+    case EXPR::MATRIX: {
+      gsl_matrix_symbolic *mp = (gsl_matrix_symbolic*)x->data.mat.p;
+      if (mp->size1 > 0 && mp->size2 > 0) {
+	if (k >= 0 && mp->size2 != (size_t)k)
+	  goto err;
+	nrows += mp->size1; k = mp->size2;
+	set_target_type(target, EXPR::MATRIX);
+	have_matrix = true;
+      }
+      break;
+    }
+#ifdef HAVE_GSL
+    case EXPR::DBL:
+      set_target_type(target, EXPR::DMATRIX);
+      if (k >= 0 && k != 1) goto err;
+      nrows++; k = 1;
+      break;
+    case EXPR::INT:
+      set_target_type(target, EXPR::IMATRIX);
+      if (k >= 0 && k != 1) goto err;
+      nrows++; k = 1;
+      break;
+    case EXPR::APP: {
+      double a, b;
+      if (k >= 0 && k != 1) goto err;
+      nrows++; k = 1;
+      if (get_complex(x, a, b))
+	set_target_type(target, EXPR::CMATRIX);
+      else
+	set_target_type(target, EXPR::MATRIX);
+      break;
+    }
+    case EXPR::DMATRIX: {
+      gsl_matrix *mp = (gsl_matrix*)x->data.mat.p;
+      if (mp->size1 > 0 && mp->size2 > 0) {
+	if (k >= 0 && mp->size2 != (size_t)k)
+	  goto err;
+	nrows += mp->size1; k = mp->size2;
+	set_target_type(target, EXPR::DMATRIX);
+	have_matrix = true;
+      }
+      break;
+    }
+    case EXPR::CMATRIX: {
+      gsl_matrix_complex *mp = (gsl_matrix_complex*)x->data.mat.p;
+      if (mp->size1 > 0 && mp->size2 > 0) {
+	if (k >= 0 && mp->size2 != (size_t)k)
+	  goto err;
+	nrows += mp->size1; k = mp->size2;
+	set_target_type(target, EXPR::CMATRIX);
+	have_matrix = true;
+      }
+      break;
+    }
+    case EXPR::IMATRIX: {
+      gsl_matrix_int *mp = (gsl_matrix_int*)x->data.mat.p;
+      if (mp->size1 > 0 && mp->size2 > 0) {
+	if (k >= 0 && mp->size2 != (size_t)k)
+	  goto err;
+	nrows += mp->size1; k = mp->size2;
+	set_target_type(target, EXPR::IMATRIX);
+	have_matrix = true;
+      }
+      break;
+    }
+#endif
+    default:
+      if (k >= 0 && k != 1) goto err;
+      nrows++; k = 1;
+      set_target_type(target, EXPR::MATRIX);
+      break;
+    }
+  }
+  if (n == 1 && have_matrix) return xs[0];
+  if (k < 0) k = 0;
+  ncols = k;
+  if (target == 0) target = EXPR::MATRIX;
+  switch (target) {
+  case EXPR::MATRIX:
+    return symbolic_matrix_rows(nrows, ncols, n, xs);
+#ifdef HAVE_GSL
+  case EXPR::DMATRIX:
+    return double_matrix_rows(nrows, ncols, n, xs);
+  case EXPR::CMATRIX:
+    return complex_matrix_rows(nrows, ncols, n, xs);
+  case EXPR::IMATRIX:
+    return int_matrix_rows(nrows, ncols, n, xs);
+#endif
+  default:
+    assert(0 && "this can't happen");
+    return 0;
+  }
+ err:
+  pure_throw(bad_matrix_exception(x));
+  return 0;
+}
+
+static pure_expr *matrix_columnsv(uint32_t n, pure_expr **xs)
+{
+  int k = -1;
+  size_t nrows = 0, ncols = 0;
+  int32_t target = 0;
+  bool have_matrix = false;
+  pure_expr *x = 0;
+  for (size_t i = 0; i < n; i++) {
+    x = xs[i];
+    switch (x->tag) {
+    case EXPR::MATRIX: {
+      gsl_matrix_symbolic *mp = (gsl_matrix_symbolic*)x->data.mat.p;
+      if (mp->size1 > 0 && mp->size2 > 0) {
+	if (k >= 0 && mp->size1 != (size_t)k)
+	  goto err;
+	ncols += mp->size2; k = mp->size1;
+	set_target_type(target, EXPR::MATRIX);
+	have_matrix = true;
+      }
+      break;
+    }
+#ifdef HAVE_GSL
+    case EXPR::DBL:
+      set_target_type(target, EXPR::DMATRIX);
+      if (k >= 0 && k != 1) goto err;
+      ncols++; k = 1;
+      break;
+    case EXPR::INT:
+      set_target_type(target, EXPR::IMATRIX);
+      if (k >= 0 && k != 1) goto err;
+      ncols++; k = 1;
+      break;
+    case EXPR::APP: {
+      double a, b;
+      if (k >= 0 && k != 1) goto err;
+      ncols++; k = 1;
+      if (get_complex(x, a, b))
+	set_target_type(target, EXPR::CMATRIX);
+      else
+	set_target_type(target, EXPR::MATRIX);
+      break;
+    }
+    case EXPR::DMATRIX: {
+      gsl_matrix *mp = (gsl_matrix*)x->data.mat.p;
+      if (mp->size1 > 0 && mp->size2 > 0) {
+	if (k >= 0 && mp->size1 != (size_t)k)
+	  goto err;
+	ncols += mp->size2; k = mp->size1;
+	set_target_type(target, EXPR::DMATRIX);
+	have_matrix = true;
+      }
+      break;
+    }
+    case EXPR::CMATRIX: {
+      gsl_matrix_complex *mp = (gsl_matrix_complex*)x->data.mat.p;
+      if (mp->size1 > 0 && mp->size2 > 0) {
+	if (k >= 0 && mp->size1 != (size_t)k)
+	  goto err;
+	ncols += mp->size2; k = mp->size1;
+	set_target_type(target, EXPR::CMATRIX);
+	have_matrix = true;
+      }
+      break;
+    }
+    case EXPR::IMATRIX: {
+      gsl_matrix_int *mp = (gsl_matrix_int*)x->data.mat.p;
+      if (mp->size1 > 0 && mp->size2 > 0) {
+	if (k >= 0 && mp->size1 != (size_t)k)
+	  goto err;
+	ncols += mp->size2; k = mp->size1;
+	set_target_type(target, EXPR::IMATRIX);
+	have_matrix = true;
+      }
+      break;
+    }
+#endif
+    default:
+      if (k >= 0 && k != 1) goto err;
+      ncols++; k = 1;
+      set_target_type(target, EXPR::MATRIX);
+      break;
+    }
+  }
+  if (n == 1 && have_matrix) return xs[0];
+  if (k < 0) k = 0;
+  nrows = k;
+  if (target == 0) target = EXPR::MATRIX;
+  switch (target) {
+  case EXPR::MATRIX:
+    return symbolic_matrix_columns(nrows, ncols, n, xs);
+#ifdef HAVE_GSL
+  case EXPR::DMATRIX:
+    return double_matrix_columns(nrows, ncols, n, xs);
+  case EXPR::CMATRIX:
+    return complex_matrix_columns(nrows, ncols, n, xs);
+  case EXPR::IMATRIX:
+    return int_matrix_columns(nrows, ncols, n, xs);
+#endif
+  default:
+    assert(0 && "this can't happen");
+    return 0;
+  }
+ err:
+  pure_throw(bad_matrix_exception(x));
+  return 0;
+}
+
 extern "C"
 pure_expr *matrix_rows(pure_expr *xs)
 {
   size_t n;
   pure_expr **elems;
   if (pure_is_listv(xs, &n, &elems)) {
-    pure_expr *ret = pure_matrix_rowsv(n, elems);
+    pure_expr *ret = matrix_rowsv(n, elems);
     if (elems) free(elems);
     return ret;
   } else
@@ -4587,7 +4801,7 @@
   size_t n;
   pure_expr **elems;
   if (pure_is_listv(xs, &n, &elems)) {
-    pure_expr *ret = pure_matrix_columnsv(n, elems);
+    pure_expr *ret = matrix_columnsv(n, elems);
     if (elems) free(elems);
     return ret;
   } else

Modified: pure/trunk/runtime.h
===================================================================
--- pure/trunk/runtime.h	2008-09-23 05:31:30 UTC (rev 832)
+++ pure/trunk/runtime.h	2008-09-23 05:54:38 UTC (rev 833)
@@ -703,9 +703,9 @@
 pure_expr *matrix_subdiag(pure_expr *x, int32_t k);
 pure_expr *matrix_supdiag(pure_expr *x, int32_t k);
 
-/* Matrix construction. These work like the pure_matrix_rows/
-   pure_matrix_columns functions in the public API, but take their input from
-   a Pure list. */
+/* Matrix construction. These work like the corresponding functions in the
+   public API, but take their input from a Pure list and raise the appropriate
+   exception in case of dimension mismatch. */
 
 pure_expr *matrix_rows(pure_expr *xs);
 pure_expr *matrix_columns(pure_expr *xs);


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.