[Matlisp-commit] [matlisp-git]matlisp branch classy updated. 2012-02-23-232-g50fcc68

[Akshay S. <ak...@us...>]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "matlisp".

The branch, classy has been updated
       via  50fcc688d2f72e751722b74e994808ad90f4c1ce (commit)
       via  c108b24c014b002d9d0465ed895a8223a766230a (commit)
       via  0b071d4d11400da962b99cbff50ee42afc443b0b (commit)
       via  ca0287f4334829367de787ba0e20947f53b6298c (commit)
       via  24def88c5b5227b29154cee9e05d88d119ceade8 (commit)
       via  ba36a2d0877b66fc5b6b4055b9310b2e60a54186 (commit)
       via  c213febdfa60e0b1a9a11c796911eb5b93fef90e (commit)
      from  ea151122023fbd5d481a831645292fa3232b7b8b (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 50fcc688d2f72e751722b74e994808ad90f4c1ce
Author: Akshay Srinivasan <aks...@gm...>
Date:   Wed Jun 19 02:07:37 2013 -0700

    Cleanup.

diff --git a/matlisp.asd b/matlisp.asd
index 6a36308..1526b85 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -134,19 +134,18 @@
    (:module "matlisp-level-1"
 	    :pathname "level-1"
 	    :depends-on ("matlisp-base" "matlisp-classes" "foreign-core")
-	    :components ((:file "tensor-maker")
+	    :components ((:file "maker")
+			 (:file "copy"
+				:depends-on ("maker"))
+			 (:file "dot"
+				:depends-on ("maker"))
 			 #+nil
 			 (
 			 (:file "swap")
-
-			 (:file "copy"
-				:depends-on ("tensor-maker"))
 			 (:file "realimag"
 				:depends-on ("copy"))
 			 (:file "scal"
 				:depends-on ("copy" "tensor-maker" "realimag"))
-			 (:file "dot"
-				:depends-on ("realimag"))
 			 (:file "axpy"
 				:depends-on ("copy" "scal"))
 			 (:file "trans"
diff --git a/src/level-1/tensor-maker.lisp b/src/level-1/maker.lisp
similarity index 100%
rename from src/level-1/tensor-maker.lisp
rename to src/level-1/maker.lisp

commit c108b24c014b002d9d0465ed895a8223a766230a
Author: Akshay Srinivasan <aks...@gm...>
Date:   Wed Jun 19 02:05:50 2013 -0700

    Migrated dot, copy to the new system.

diff --git a/src/base/blas-helpers.lisp b/src/base/blas-helpers.lisp
index 6b8b735..11ef0c0 100644
--- a/src/base/blas-helpers.lisp
+++ b/src/base/blas-helpers.lisp
@@ -77,6 +77,6 @@
 (defun make-stride (dims)
   (ecase *default-stride-ordering* (:row-major (make-stride-rmj dims)) (:col-major (make-stride-cmj dims))))
 
-(definline call-fortran? (x lb)
+(defun call-fortran? (x lb)
   (declare (type standard-tensor x))
-  (> (lvec-max (the index-store-vector (dimensions x))) lb))
+  (> (size x) lb))
diff --git a/src/base/generic-copy.lisp b/src/base/generic-copy.lisp
index 128d66c..543fa5c 100644
--- a/src/base/generic-copy.lisp
+++ b/src/base/generic-copy.lisp
@@ -90,6 +90,9 @@
   =======
   Return a copy of X"))
 
+(defmethod copy ((num number))
+  num)
+
 (defmethod copy ((lst cons))
   (copy-list lst))
 
diff --git a/src/base/tweakable.lisp b/src/base/tweakable.lisp
index 02f7e00..3ad44fc 100644
--- a/src/base/tweakable.lisp
+++ b/src/base/tweakable.lisp
@@ -27,13 +27,13 @@
 ")
 
 ;;Level 1--------------------------------------------------------;;
-(defparameter *real-l1-fcall-lb* 20000
+(defparameter *real-l1-fcall-lb* 50000
   "If the size of the array is less than this parameter, the
    lisp version of axpy is called in order to avoid FFI overheads.
    The Fortran function is not called if the tensor does not have
    a consecutive store (see blas-helpers.lisp/consecutive-store-p).")
 
-(defparameter *complex-l1-fcall-lb* 10000
+(defparameter *complex-l1-fcall-lb* 20000
   "If the size of the array is less than this parameter, the
    lisp version of axpy is called in order to avoid FFI overheads.
    The Fortran function is not called if the tensor does not have
diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp
index e67612d..0800470 100644
--- a/src/level-1/copy.lisp
+++ b/src/level-1/copy.lisp
@@ -136,24 +136,6 @@
   (assert (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil
 	  'tensor-dimension-mismatch))
 
-;;This shouldn't happen ideally
-(defmethod copy! ((x t) (y standard-tensor))
-  (let ((clname (class-name (class-of y))))
-    (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname)
-    (warn "copy! method being generated for '(t ~a), does not use BLAS." clname)
-    (compile-and-eval
-     `(defmethod copy! ((x t) (y ,clname))
-	(let-typed ((sto-y (store y) :type (simple-array ,(store-element-type clname)))
-		    (cx (t/coerce ,(field-type clname) x) :type ,(field-type clname)))
-		   ;;This should be safe
-		   (very-quickly
-		     (mod-dotimes (idx (dimensions y))
-		       :with (linear-sums
-			      (of-y (strides y) (head y)))
-		       :do (t/store-set ,clname cx sto-y of-y))))
-	y))
-    (copy! x y)))
-
 (defmethod copy! ((x standard-tensor) (y standard-tensor))
   (let ((clx (class-name (class-of x)))
 	(cly (class-name (class-of y))))
@@ -166,142 +148,30 @@
 	   `(defmethod copy! ((x ,clx) (y ,cly))
 	      ,(recursive-append
 		(when (subtypep clx 'blas-numeric-tensor)
-		  `(if (and (call-fortran? x (t/l1-lb ,clx)) (blas-copyable-p 
-  
-  (mod-dotimes (idx (dimensions x))
-    do (setf (tensor-ref y idx) (tensor-ref x idx)))
-  y)
-
-(defmethod copy! ((x complex-tensor) (y real-tensor))
-  (error 'coercion-error :from 'complex-tensor :to 'real-tensor))
-
-(defmethod copy! ((x real-tensor) (y real-tensor))
-  (real-typed-copy! x y))
-
-(defmethod copy! ((x number) (y real-tensor))
-  (real-typed-num-copy! (coerce-real x) y))
-
-(defmethod copy! ((x complex-tensor) (y complex-tensor))
-  (complex-typed-copy! x y))
-
-(defmethod copy! ((x real-tensor) (y complex-tensor))
-  ;;Borrowed from realimag.lisp
-  (let ((tmp (make-instance 'real-tensor
-			    :parent-tensor y :store (store y)
-			    :dimensions (dimensions y)
-			    :strides (map 'index-store-vector #'(lambda (n) (* 2 n)) (strides y))
-			    :head (the index-type (* 2 (head y))))))
-    (declare (type real-tensor tmp))
-    (real-typed-copy! x tmp)
-    ;;Increasing the head by 1 points us to the imaginary part.
-    (incf (head tmp))
-    (real-typed-num-copy! 0d0 tmp))
-  y)
-
-(defmethod copy! ((x number) (y complex-tensor))
-  (complex-typed-num-copy! (coerce-complex x) y))
-
-;; Copy between a Lisp array and a tensor
-(defun convert-to-lisp-array (tensor)
-  "
-  Syntax
-  ======
-  (convert-to-lisp-array tensor)
-
-  Purpose
-  =======
-  Create a new Lisp array with the same dimensions as the tensor and
-  with the same elements.  This is a copy of the tensor.
-"
-  (declare (type standard-tensor tensor))
-  (let*-typed ((dims (dimensions tensor) :type index-store-vector)
-	       (ret (make-array (lvec->list dims)
-				:element-type (or (getf (get-tensor-object-optimization tensor) :element-type)
-						  (error 'tensor-cannot-find-optimization :tensor-class (class-name (class-of tensor)))))))
-	      (let ((lst (make-list (rank tensor))))
-		(very-quickly
-		  (mod-dotimes (idx dims)
-		    do (setf (apply #'aref ret (lvec->list! idx lst)) (tensor-ref tensor idx))))
-		ret)))
-
-(defmethod copy! :before ((x standard-tensor) (y array))
-  (assert (subtypep (getf (get-tensor-object-optimization x) :element-type)
-		    (array-element-type y))
-	  nil 'invalid-type
-	  :given (getf (get-tensor-object-optimization x) :element-type)
-	  :expected (array-element-type y))
-  (assert (and
-	   (= (rank x) (array-rank y))
-	   (dolist (ele (mapcar #'= (lvec->list (dimensions x)) (array-dimensions y)) t)
-	     (unless ele (return nil))))
-	  nil 'dimension-mismatch))
-
-(defmethod copy! ((x real-tensor) (y array))
-  (let-typed ((sto-x (store x) :type real-store-vector)
-	      (lst (make-list (rank x)) :type cons))
-	     (mod-dotimes (idx (dimensions x))
-	       with (linear-sums
-		     (of-x (strides x) (head x)))
-	       do (setf (apply #'aref y (lvec->list! idx lst))
-			(aref sto-x of-x))))
-  y)
-
-(defmethod copy! ((x complex-tensor) (y array))
-  (let-typed ((sto-x (store x) :type complex-store-vector)
-	      (lst (make-list (rank x)) :type cons))
-	     (mod-dotimes (idx (dimensions x))
-	       with (linear-sums
-		     (of-x (strides x) (head x)))
-	       do (setf (apply #'aref y (lvec->list! idx lst))
-			(complex (aref sto-x (* 2 of-x)) (aref sto-x (1+ (* 2 of-x)))))))
-  y)
-
-;;
-(defmethod copy! :before ((x array) (y standard-tensor))
-  (assert (subtypep (array-element-type x)
-		    (getf (get-tensor-object-optimization y) :element-type))
-	  nil 'invalid-type
-	  :given (array-element-type x) :expected (getf (get-tensor-object-optimization y) :element-type))
-  (assert (and
-	   (= (array-rank x) (rank y))
-	   (dolist (ele (mapcar #'= (array-dimensions x) (lvec->list (dimensions y))) t)
-	     (unless ele (return nil))))
-	  nil 'dimension-mismatch))
-
-(defmethod copy! ((x array) (y real-tensor))
-  (let-typed ((sto-y (store y) :type real-store-vector)
-	      (lst (make-list (array-rank x)) :type cons))
-	     (very-quickly
-	       (mod-dotimes (idx (dimensions y))
-		 with (linear-sums
-		       (of-y (strides y) (head y)))
-		 do (setf (aref sto-y of-y) (apply #'aref x (lvec->list! idx lst))))))
-  y)
+		  `(if-let (strd (and (call-fortran? x (t/l1-lb ,clx)) (blas-copyablep x y)))
+		     (let ((sz (size x))) (t/blas-copy! ,clx sz x (first strd) y (second strd)))))
+		`(very-quickly (t/copy! (,clx ,cly) x y)))
+	      y)))
+	(compile-and-eval
+	 `(defmethod copy! ((x ,clx) (y ,cly))
+	    (t/copy! (,clx ,cly) x y)
+	    y)))
+    (copy! x y)))
 
-(defmethod copy! ((x array) (y complex-tensor))
-  (let-typed ((sto-y (store y) :type real-store-vector)
-	      (lst (make-list (array-rank x)) :type cons))
-	     (very-quickly
-	       (mod-dotimes (idx (dimensions y))
-		 with (linear-sums
-		       (of-y (strides y) (head y)))
-		 do (let-typed ((ele (apply #'aref x (lvec->list! idx lst)) :type complex-type))
-			       (setf (aref sto-y (* 2 of-y)) (realpart ele)
-				     (aref sto-y (1+ (* 2 of-y))) (imagpart ele))))))
-  y)
+(defmethod copy! ((x t) (y standard-tensor))
+  (let ((cly (class-name (class-of y))))
+    (assert (and (member cly *tensor-type-leaves*))
+	    nil 'tensor-abstract-class :tensor-class cly)
+    (compile-and-eval
+     `(defmethod copy! ((x t) (y ,cly))
+	,(recursive-append
+	  (when (subtypep cly 'blas-numeric-tensor)
+	    `(if-let (strd (and (call-fortran? y (t/l1-lb ,cly)) (consecutive-storep y)))
+	       	(let ((sz (size y))) (t/blas-num-copy! ,cly sz x y strd))))
+	  `(very-quickly (t/copy! (t ,cly) x y)))))
+    (copy! x y)))
 
-;;
 ;;Generic function defined in src;base;generic-copy.lisp
-
-(defmethod copy ((tensor real-tensor))
-  (let* ((ret (apply #'make-real-tensor (lvec->list (dimensions tensor)))))
-    (declare (type real-tensor ret))
+(defmethod copy ((tensor standard-tensor))
+  (let* ((ret (zeros (the index-store-vector (dimensions tensor)) (class-name (class-of tensor)))))
     (copy! tensor ret)))
-
-(defmethod copy ((tensor complex-tensor))
-  (let* ((ret (apply #'make-complex-tensor (lvec->list (dimensions tensor)))))
-    (declare (type complex-tensor ret))
-    (copy! tensor ret)))
-
-(defmethod copy ((tensor number))
-  tensor)
diff --git a/src/level-1/dot.lisp b/src/level-1/dot.lisp
index dc26862..a7ac53e 100644
--- a/src/level-1/dot.lisp
+++ b/src/level-1/dot.lisp
@@ -105,7 +105,7 @@
 ")
   (:method :before ((x standard-tensor) (y standard-tensor) &optional (conjugate-p t))
     (declare (ignore conjugate-p))
-    (unless (and (vector-p x) (vector-p y) (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)))
+    (unless (and (tensor-vectorp x) (tensor-vectorp y) (= (aref (the index-store-vector (dimensions x)) 0) (aref (the index-store-vector (dimensions y)) 0)))
       (error 'tensor-dimension-mismatch))))
 
 (defmethod dot ((x number) (y number) &optional (conjugate-p t))
@@ -119,24 +119,26 @@
     (assert (and (member clx *tensor-type-leaves*)
 		 (member cly *tensor-type-leaves*))
 	    nil 'tensor-abstract-class :tensor-class (list clx cly))
-    (if (eq clx cly)
-	(progn
-	  (compile-and-eval
-	   `(defmethod dot ((x ,clx) (y ,cly) &optional (conjugate-p t))
-	      ,(recursive-append
-		(when (subtypep clx 'blas-numeric-tensor)
-		  `(if (call-fortran? x (t/l1-lb ,clx))
-		       (if conjugate-p
-			   (t/blas-dot ,clx x y t)
-			   (t/blas-dot ,clx x y nil))))
-	      `(if conjugate-p
-		   ;;Please do your checks before coming here.
-		   (very-quickly (t/dot ,clx x y t))
-		   (very-quickly (t/dot ,clx x y nil))))))
-	  (dot x y conjugate-p))
-	;;You pay the piper if you like mixing types.
-	;;This is (or should be) a rare enough to not matter.
-	(or (handler-case
-		(dot (copy! x (zeros (dimensions x) cly)) y conjugate-p)
-	      (error () nil))
-	    (dot x (copy! y (zeros (dimensions y) clx)) conjugate-p)))))
+    (cond
+      ((eq clx cly)
+       (compile-and-eval
+	`(defmethod dot ((x ,clx) (y ,cly) &optional (conjugate-p t))
+	   ,(recursive-append
+	     (when (subtypep clx 'blas-numeric-tensor)
+	       `(if (call-fortran? x (t/l1-lb ,clx))
+		    (if conjugate-p
+			(t/blas-dot ,clx x y t)
+			(t/blas-dot ,clx x y nil))))
+	     `(if conjugate-p
+		  ;;Please do your checks before coming here.
+		  (very-quickly (t/dot ,clx x y t))
+		  (very-quickly (t/dot ,clx x y nil))))))
+       (dot x y conjugate-p))
+      ;;You pay the piper if you like mixing types.
+      ;;This is (or should be) a rare enough to not matter.
+      ((coerceable? clx cly)
+       (dot (copy! x (zeros (dimensions x) cly)) y conjugate-p))
+      ((coerceable? cly clx)
+       (dot x (copy! y (zeros (dimensions y) clx)) conjugate-p))
+      (t
+       (error "Don't know how to compute the dot product of ~a , ~a." clx cly)))))

commit 0b071d4d11400da962b99cbff50ee42afc443b0b
Author: Akshay Srinivasan <aks...@gm...>
Date:   Wed Jun 19 01:28:54 2013 -0700

    Cleaned up blas-helpers.lisp

diff --git a/matlisp.asd b/matlisp.asd
index 9c1efa3..6a36308 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -128,6 +128,7 @@
 	    :components ((:file "numeric")
 			 #+maxima
 			 (:file "symbolic-tensor")
+			 #+nil
 			 (:file "matrix"
 				:depends-on ("numeric"))))
    (:module "matlisp-level-1"
diff --git a/packages.lisp b/packages.lisp
index 96949cb..4168ed9 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -32,34 +32,34 @@
   (:export
    ;;<conditon {accessors*}>
    ;;Generic errors
-   #:generic-error #:message
+   #:generic-error
    #:dimension-mismatch
    #:assumption-violated
-   #:invalid-type #:given #:expected
-   #:invalid-arguments #:argnum
-   #:invalid-value #:given #:expected
-   #:unknown-token #:token
+   #:invalid-type
+   #:invalid-arguments
+   #:invalid-value
+   #:unknown-token
    #:parser-error
-   #:coercion-error #:from #:to
-   #:out-of-bounds-error #:requested #:bound   
-   #:non-uniform-bounds-error #:assumed #:found
+   #:coercion-error
+   #:out-of-bounds-error
+   #:non-uniform-bounds-error
    ;;Permutation conditions
-   #:permutation #:permutation
+   #:permutation
    #:permutation-invalid-error
-   #:permutation-permute-error #:seq-len #:group-rank   
+   #:permutation-permute-error
    ;;Tensor conditions
-   #:tensor-error #:tensor
-   #:tensor-store-index-out-of-bounds #:index #:store-size
-   #:tensor-insufficient-store #:store-size #:max-idx
-   #:tensor-not-matrix #:rank
-   #:tensor-not-vector #:rank
-   #:tensor-index-out-of-bounds #:argument #:index #:dimension
-   #:tensor-index-rank-mismatch #:index-rank #:rank
-   #:tensor-invalid-head-value #:head
-   #:tensor-invalid-dimension-value #:argument #:dimension
-   #:tensor-invalid-stride-value #:argument #:stride
-   #:tensor-cannot-find-counter-class #:tensor-class
-   #:tensor-cannot-find-optimization #:tensor-class
+   #:tensor-error
+   #:tensor-store-index-out-of-bounds
+   #:tensor-insufficient-store
+   #:tensor-not-matrix
+   #:tensor-not-vector
+   #:tensor-index-out-of-bounds
+   #:tensor-index-rank-mismatch
+   #:tensor-invalid-head-value
+   #:tensor-invalid-dimension-value
+   #:tensor-invalid-stride-value
+   #:tensor-cannot-find-counter-class
+   #:tensor-cannot-find-optimization
    #:tensor-dimension-mismatch
    #:tensor-store-not-consecutive
    #:tensor-method-does-not-exist
diff --git a/src/base/blas-helpers.lisp b/src/base/blas-helpers.lisp
index 07664c2..6b8b735 100644
--- a/src/base/blas-helpers.lisp
+++ b/src/base/blas-helpers.lisp
@@ -1,12 +1,35 @@
 (in-package #:matlisp)
+   
+(defun consecutive-storep (tensor)
+  (declare (type standard-tensor tensor))
+  (memoizing (tensor consecutive-storep)
+    (mlet* (((sort-std std-perm) (very-quickly (sort-permute-base (copy-seq (the index-store-vector (strides tensor))) #'<))
+	     :type (index-store-vector pindex-store-vector))
+	    (perm-dims (very-quickly (apply-action! (copy-seq (the index-store-vector (dimensions tensor))) std-perm)) :type index-store-vector))
+	   (very-quickly
+	     (loop
+		:for so-st :across sort-std
+		:for so-di :across perm-dims
+		:and accumulated-off := (aref sort-std 0) :then (the index-type (* accumulated-off so-di))
+		:unless (= so-st accumulated-off) :do (return (values nil perm-dims sort-std std-perm))
+		:finally (return (values (aref sort-std 0) perm-dims sort-std std-perm)))))))
+
+(defun blas-copyablep (ten-a ten-b)
+  (declare (type standard-tensor ten-a ten-b))
+  (when (= (rank ten-a) (rank ten-b))
+    (mlet*
+     (((csto-a? pdims-a tmp perm-a) (consecutive-storep ten-a) :type (t index-store-vector nil pindex-store-vector))
+      ((csto-b? pdims-b tmp perm-b) (consecutive-storep ten-b) :type (t index-store-vector nil pindex-store-vector)))
+     (when (and csto-a? csto-b? (very-quickly (lvec-eq perm-a perm-b)) (very-quickly (lvec-eq pdims-a pdims-b)))
+       (list csto-a? csto-b?)))))
 
 (definline fortran-nop (op)
-  (ecase op (#\T #\N) (#\N #\T)))
+  (ecase op (#\t #\n) (#\n #\t)))
 
 (defun split-job (job)
   (declare (type symbol job))
   (let-typed ((name (symbol-name job) :type string))
-    (loop :for x :across name :collect x)))
+    (loop :for x :across name :collect (char-downcase x))))
 
 (definline flip-major (job)
   (declare (type symbol job))
@@ -14,47 +37,10 @@
     (:row-major :col-major)
     (:col-major :row-major)))
 
-(defun blas-copyable-p (ten-a ten-b)
-  (declare (type standard-tensor ten-a ten-b))
-  (when (= (rank ten-a) (rank ten-b))
-    (mlet*
-     (((sort-std-a std-a-perm) (very-quickly (sort-permute-base (copy-seq (the index-store-vector (strides ten-a))) #'<)) :type (index-store-vector pindex-store-vector))
-      (perm-a-dims (very-quickly (apply-action! (copy-seq (the index-store-vector (dimensions ten-a))) std-a-perm)) :type index-store-vector)
-      ;;If blas-copyable then the strides must have the same sorting permutation.
-      (sort-std-b (very-quickly (apply-action! (copy-seq (the index-store-vector (strides ten-b))) std-a-perm)) :type index-store-vector)
-      (perm-b-dims (very-quickly (apply-action! (copy-seq (the index-store-vector (dimensions ten-b))) std-a-perm)) :type index-store-vector))
-     (very-quickly
-       (loop
-	  :for i :of-type index-type :from 0 :below (rank ten-a)
-	  :for sost-a :across sort-std-a
-	  :for a-aoff :of-type index-type := (aref sort-std-a 0) :then (the index-type (* a-aoff (aref perm-a-dims (1- i))))
-	  ;;
-	  :for sost-b :across sort-std-b
-	  :for b-aoff :of-type index-type := (aref sort-std-b 0) :then (the index-type (* b-aoff (aref perm-b-dims (1- i))))
-	  ;;
-	  :do (unless (and (= sost-a a-aoff)
-			   (= sost-b b-aoff)
-			   (= (aref perm-a-dims i) (aref perm-b-dims i)))
-		(return nil))
-	  :finally (return (list (aref sort-std-a 0) (aref sort-std-b 0))))))))
-
-(definline consecutive-store-p (tensor)
-  (declare (type standard-tensor tensor))
-  (mlet* (((sort-std std-perm) (very-quickly (sort-permute-base (copy-seq (the index-store-vector (strides tensor))) #'<))
-	   :type (index-store-vector pindex-store-vector))
-	  (perm-dims (very-quickly (apply-action! (copy-seq (the index-store-vector (dimensions tensor))) std-perm)) :type index-store-vector))
-	 (very-quickly
-	   (loop
-	      :for so-st :across sort-std
-	      :for so-di :across perm-dims
-	      :and accumulated-off := (aref sort-std 0) :then (the index-type (* accumulated-off so-di))
-	      :unless (= so-st accumulated-off) :do (return nil)
-
-	      :finally (return (values t (aref sort-std 0)))))))
-
-(definline blas-matrix-compatible-p (matrix op)
-  (declare (type standard-matrix matrix)
+(definline blas-matrix-compatiblep (matrix op)
+  (declare (type standard-tensor matrix)
 	   (type character op))
+  (assert (tensor-matrixp matrix) nil 'tensor-not-matrix)
   (let*-typed ((stds (strides matrix) :type index-store-vector)
 	       (rs (aref stds 0) :type index-type)
 	       (cs (aref stds 1) :type index-type))
diff --git a/src/base/permutation.lisp b/src/base/permutation.lisp
index 5777efe..0869622 100644
--- a/src/base/permutation.lisp
+++ b/src/base/permutation.lisp
@@ -1,8 +1,10 @@
 (in-package #:matlisp)
 
 ;;This must match the type used in LAPACK
+;;(unsigned-byte 32)
+
 (deftype pindex-type ()
-  '(unsigned-byte 32))
+  'fixnum)
 
 (deftype pindex-store-vector (&optional (size '*))
   `(simple-array pindex-type (,size)))
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index 397e8e7..0544757 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -62,6 +62,18 @@
     :documentation "Place for computable attributes of an object instance."))
   (:documentation "Basic tensor class."))
 
+(defmacro memoizing ((tensor name) &rest body)
+  (declare (type symbol name))
+  (with-gensyms (tens)
+    `(let* ((,tens ,tensor))
+       (declare (type standard-tensor ,tens))
+       (multiple-value-bind (value present?) (gethash ',name (attributes ,tens))
+	 (values-list 
+	  (if present?
+	      value
+	      (setf (gethash ',name (attributes ,tens))
+		    (multiple-value-list (progn ,@body)))))))))
+		      
 ;;I have no idea what this does, or why we want it (inherited from standard-matrix.lisp)
 (defmethod make-load-form ((tensor standard-tensor) &optional env)
   "
@@ -69,30 +81,14 @@
   tensor, for example #.(make-tensors ...)"
   (make-load-form-saving-slots tensor :environment env))
 
-;;These should ideally be memoised
-(defgeneric rank (tensor)
-  (:documentation "
-  Syntax
-  ======
-  (rank tensor)
-
-  Purpose
-  =======
-  Returns the rank of the tensor object.")
-  (:method ((tensor standard-tensor))
-    (length (dimensions tensor))))
-
-(defgeneric size (tensor)
-  (:documentation "
-  Syntax
-  ======
-  (size tensor)
+;;These should ideally be memoised (or not)
+(definline rank (tensor)
+  (declare (type standard-tensor tensor))
+  (length (the index-store-vector (dimensions tensor))))
 
-  Purpose
-  =======
-  Returns the number of elements in the tensor.")
-  (:method ((tensor standard-tensor))
-    (lvec-foldr #'* (the index-store-vector (dimensions tensor)))))
+(definline size (tensor)
+  (declare (type standard-tensor tensor))
+  (lvec-foldr #'* (the index-store-vector (dimensions tensor))))
 
 (defgeneric store-size (tensor)
   (:documentation "
@@ -296,7 +292,7 @@
     (setf (store-ref tensor idx) value)))
 
 ;;
-(defun tensor-typep (tensor subscripts)
+(defun tensor-typep (tensor subs)
   "
   Syntax
   ======
@@ -310,31 +306,35 @@
   Examples
   ========
   Checking for a vector:
-  > (tensor-typep ten '(*))
+  > (tensor-typep ten '(class-name *))
 
   Checking for a matrix with 2 columns:
-  > (tensor-typep ten '(* 2))
+  > (tensor-typep ten '(real-tensor (* 2)))
 
   "
   (declare (type standard-tensor tensor))
-  (let-typed ((rank (rank tensor) :type index-type)
-	      (dims (dimensions tensor) :type index-store-vector))
-    (very-quickly 
-      (loop :for val :in subscripts
-	 :for i :of-type index-type := 0 :then (1+ i)
-	 :do (unless (or (eq val '*) (eq val (aref dims i)))
-	       (return nil))
-	 :finally (return (when (= (1+ i) rank) t))))))
-
-(definline matrix-p (ten)
+  (destructuring-bind (cls &optional subscripts) (ensure-list subs)
+    (and (typep tensor cls)
+	 (if subscripts
+	     (let-typed ((rank (rank tensor) :type index-type)
+			 (dims (dimensions tensor) :type index-store-vector))
+			(very-quickly 
+			  (loop :for val :in subscripts
+			     :for i :of-type index-type := 0 :then (1+ i)
+			     :do (unless (or (eq val '*) (eq val (aref dims i)))
+				   (return nil))
+			     :finally (return (when (= (1+ i) rank) t)))))
+	     t))))
+
+(definline tensor-matrixp (ten)
   (declare (type standard-tensor ten))
   (= (rank ten) 2))
 
-(definline vector-p (ten)
+(definline tensor-vectorp (ten)
   (declare (type standard-tensor ten))
   (= (rank ten) 1))
 
-(definline square-p (tensor)
+(definline tensor-squarep (tensor)
   (let-typed ((dims (dimensions tensor) :type index-store-vector))
     (lvec-foldr #'(lambda (a b) (if (eq a b) a nil)) dims)))
 
@@ -357,13 +357,13 @@
   X
 
   ;; Get (:, 0, 0)
-  > (sub-tensor~ X '((* * *) (0 * 1) (0 * 1)))
+  > (sub-tensor/ X '((* * *) (0 * 1) (0 * 1)))
 
   ;; Get (:, 2:5, :)
-  > (sub-tensor~ X '((* * *) (2 * 5)))
+  > (sub-tensor/ X '((* * *) (2 * 5)))
 
   ;; Get (:, :, 0:2:10) (0:10:2 = [i : 0 <= i < 10, i % 2 = 0])
-  > (sub-tensor~ X '((* * *) (* * *) (0 2 10)))
+  > (sub-tensor/ X '((* * *) (* * *) (0 2 10)))
 
   Commentary
   ==========
diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp
index c01039e..e67612d 100644
--- a/src/level-1/copy.lisp
+++ b/src/level-1/copy.lisp
@@ -133,7 +133,7 @@
 
 ;;
 (defmethod copy! :before ((x standard-tensor) (y standard-tensor))
-  (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
+  (assert (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil
 	  'tensor-dimension-mismatch))
 
 ;;This shouldn't happen ideally
@@ -166,7 +166,7 @@
 	   `(defmethod copy! ((x ,clx) (y ,cly))
 	      ,(recursive-append
 		(when (subtypep clx 'blas-numeric-tensor)
-		  
+		  `(if (and (call-fortran? x (t/l1-lb ,clx)) (blas-copyable-p 
   
   (mod-dotimes (idx (dimensions x))
     do (setf (tensor-ref y idx) (tensor-ref x idx)))

commit ca0287f4334829367de787ba0e20947f53b6298c
Merge: ea15112 24def88
Author: Akshay Srinivasan <aks...@gm...>
Date:   Tue Jun 18 23:34:49 2013 -0700

    Merge branch 'tensor' into classy
    
    Conflicts:
    	matlisp.asd
    	src/base/blas-helpers.lisp
    	src/base/standard-tensor.lisp
    	src/level-1/tensor-maker.lisp
    	src/utilities/functions.lisp

diff --cc matlisp.asd
index 5b8b043,dc7a129..9c1efa3
--- a/matlisp.asd
+++ b/matlisp.asd
@@@ -122,14 -125,12 +125,11 @@@
     (:module "matlisp-classes"
  	    :pathname "classes"
  	    :depends-on ("matlisp-base")
- 	    :components ((:file "real-tensor")
- 			 (:file "complex-tensor")
+ 	    :components ((:file "numeric")
  			 #+maxima
  			 (:file "symbolic-tensor")
 -			 #+nil
  			 (:file "matrix"
- 				:depends-on ("real-tensor" "complex-tensor"))))
-    #+nil
+ 				:depends-on ("numeric"))))
     (:module "matlisp-level-1"
  	    :pathname "level-1"
  	    :depends-on ("matlisp-base" "matlisp-classes" "foreign-core")
@@@ -146,7 -150,7 +149,8 @@@
  			 (:file "axpy"
  				:depends-on ("copy" "scal"))
  			 (:file "trans"
- 				:depends-on ("scal" "copy"))))
+ 				:depends-on ("scal" "copy")))))
++
     #+nil
     (:module "matlisp-level-2"
  	    :pathname "level-2"
diff --cc src/base/blas-helpers.lisp
index f48901a,e34dc8b..07664c2
--- a/src/base/blas-helpers.lisp
+++ b/src/base/blas-helpers.lisp
@@@ -1,60 -1,47 +1,60 @@@
  (in-package #:matlisp)
  
 -;;Check dimensions of the tensors before passing the argument here!
 +(definline fortran-nop (op)
 +  (ecase op (#\T #\N) (#\N #\T)))
 +
 +(defun split-job (job)
 +  (declare (type symbol job))
 +  (let-typed ((name (symbol-name job) :type string))
 +    (loop :for x :across name :collect x)))
 +
 +(definline flip-major (job)
 +  (declare (type symbol job))
 +  (case job
 +    (:row-major :col-major)
 +    (:col-major :row-major)))
 +
  (defun blas-copyable-p (ten-a ten-b)
    (declare (type standard-tensor ten-a ten-b))
 -  (mlet*
 -   (((sort-std-a std-a-perm) (let-typed ((std-a (strides ten-a) :type index-store-vector))
 -			       (very-quickly (sort-permute (copy-seq std-a) #'<)))
 -     :type (index-store-vector permutation-action))
 -    (perm-a-dims (permute (dimensions ten-a) std-a-perm) :type index-store-vector)
 -    ;;If blas-copyable then the strides must have the same sorting permutation.
 -    (sort-std-b (permute (strides ten-b) std-a-perm) :type index-store-vector)
 -    (perm-b-dims (permute (dimensions ten-b) std-a-perm) :type index-store-vector))
 -   (very-quickly
 -     (loop
 -	:for i :of-type index-type :from 0 :below (rank ten-a)
 -	:for sost-a :across sort-std-a
 -	:for a-aoff :of-type index-type := (aref sort-std-a 0) :then (the index-type (* a-aoff (aref perm-a-dims (1- i))))
 -	;;
 -	:for sost-b :across sort-std-b
 -	:for b-aoff :of-type index-type := (aref sort-std-b 0) :then (the index-type (* b-aoff (aref perm-b-dims (1- i))))
 -	;;
 -	:do (progn
 -	      (unless (and (= sost-a a-aoff)
 -			   (= sost-b b-aoff))
 -		(return nil)))
 -	:finally (return (list (aref sort-std-a 0) (aref sort-std-b 0)))))))
 +  (when (= (rank ten-a) (rank ten-b))
 +    (mlet*
 +     (((sort-std-a std-a-perm) (very-quickly (sort-permute-base (copy-seq (the index-store-vector (strides ten-a))) #'<)) :type (index-store-vector pindex-store-vector))
 +      (perm-a-dims (very-quickly (apply-action! (copy-seq (the index-store-vector (dimensions ten-a))) std-a-perm)) :type index-store-vector)
 +      ;;If blas-copyable then the strides must have the same sorting permutation.
 +      (sort-std-b (very-quickly (apply-action! (copy-seq (the index-store-vector (strides ten-b))) std-a-perm)) :type index-store-vector)
 +      (perm-b-dims (very-quickly (apply-action! (copy-seq (the index-store-vector (dimensions ten-b))) std-a-perm)) :type index-store-vector))
 +     (very-quickly
 +       (loop
 +	  :for i :of-type index-type :from 0 :below (rank ten-a)
 +	  :for sost-a :across sort-std-a
 +	  :for a-aoff :of-type index-type := (aref sort-std-a 0) :then (the index-type (* a-aoff (aref perm-a-dims (1- i))))
 +	  ;;
 +	  :for sost-b :across sort-std-b
 +	  :for b-aoff :of-type index-type := (aref sort-std-b 0) :then (the index-type (* b-aoff (aref perm-b-dims (1- i))))
 +	  ;;
 +	  :do (unless (and (= sost-a a-aoff)
 +			   (= sost-b b-aoff)
 +			   (= (aref perm-a-dims i) (aref perm-b-dims i)))
 +		(return nil))
 +	  :finally (return (list (aref sort-std-a 0) (aref sort-std-b 0))))))))
  
- (defmemo consecutive-store-p (tensor)
 -(defun consecutive-store-p (tensor)
++(definline consecutive-store-p (tensor)
    (declare (type standard-tensor tensor))
 -  (mlet* (((sort-std std-perm) (let-typed ((stds (strides tensor) :type index-store-vector))
 -				 (very-quickly (sort-permute (copy-seq stds) #'<)))
 -	   :type (index-store-vector permutation))
 -	  (perm-dims (permute (dimensions tensor) std-perm) :type index-store-vector))
 -      (very-quickly
 -	(loop
 -	   :for so-st :across sort-std
 -	   :for so-di :across perm-dims
 -	   :and accumulated-off := (aref sort-std 0) :then (the index-type (* accumulated-off so-di))
 -	   :unless (= so-st accumulated-off) :do (return nil)
 -	   :finally (return (aref sort-std 0))))))
 +  (mlet* (((sort-std std-perm) (very-quickly (sort-permute-base (copy-seq (the index-store-vector (strides tensor))) #'<))
 +	   :type (index-store-vector pindex-store-vector))
 +	  (perm-dims (very-quickly (apply-action! (copy-seq (the index-store-vector (dimensions tensor))) std-perm)) :type index-store-vector))
 +	 (very-quickly
 +	   (loop
 +	      :for so-st :across sort-std
 +	      :for so-di :across perm-dims
 +	      :and accumulated-off := (aref sort-std 0) :then (the index-type (* accumulated-off so-di))
 +	      :unless (= so-st accumulated-off) :do (return nil)
 +
 +	      :finally (return (values t (aref sort-std 0)))))))
  
 -(defun blas-matrix-compatible-p (matrix op)
 -  (declare (type standard-tensor matrix))
 +(definline blas-matrix-compatible-p (matrix op)
 +  (declare (type standard-matrix matrix)
 +	   (type character op))
    (let*-typed ((stds (strides matrix) :type index-store-vector)
  	       (rs (aref stds 0) :type index-type)
  	       (cs (aref stds 1) :type index-type))
diff --cc src/base/standard-tensor.lisp
index 5e84180,d013aaf..397e8e7
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@@ -14,7 -14,7 +14,7 @@@
    (ALLOCATE-INDEX-STORE SIZE [INITIAL-ELEMENT 0])
  
    Purpose
--  =======
++  ======
    Allocates index storage.")
  
  (definline make-index-store (contents)
@@@ -33,162 -33,87 +33,94 @@@
    (make-index-store contents))
  
  ;;
- (defclass tensor ()
-   ((dimensions
-     :reader dimensions
-     :initarg :dimensions
-     :type index-store-vector
+ (defvar *tensor-type-leaves* nil "
+   This is used to keep track of classes that are not meant to be
+   abstract classes. This prevents less specialized methods from
+   clobbering the generation of more sophisticated (read faster)
+   methods.")
+ 
+ (defmacro defleaf (name direct-superclasses direct-slots &rest options)
+   `(progn
+      (defclass ,name ,direct-superclasses ,direct-slots ,@options)
+      (setf *tensor-type-leaves* (setadd *tensor-type-leaves* ',name))))
+ 
+ (defclass standard-tensor ()
+   ((dimensions :reader dimensions :initarg :dimensions :type index-store-vector
      :documentation "Dimensions of the vector spaces in which the tensor's arguments reside.")
     ;;
-    (parent-tensor
-     :reader parent-tensor
-     :initarg :parent-tensor
-     :type tensor
+    (parent-tensor :reader parent-tensor :initarg :parent-tensor :type standard-tensor
      :documentation "If the tensor is a view of another tensor, then this slot is bound.")
     ;;
-    (store
-     :reader store
-     :initarg :store)
+    (head :initarg :head :initform 0 :reader head :type index-type
+     :documentation "Head for the store's accessor.")
+    (strides :initarg :strides :reader strides :type index-store-vector
+     :documentation "Strides for accesing elements of the tensor.")
+    (store :initarg :store :reader store
+     :documentation "The actual storage for the tensor.")
     ;;
-    (memos
-     :reader memos
-     :initarg :memos
-     :documentation "Cache for arbitrary (computable) attributes of the object.")))
+    (attributes :initarg :attributes :reader attributes :initform (make-hash-table)
+     :documentation "Place for computable attributes of an object instance."))
+   (:documentation "Basic tensor class."))
  
- ;;
- (defclass dense-tensor (tensor)
-   ((store :type dense-store)))
++;;I have no idea what this does, or why we want it (inherited from standard-matrix.lisp)
++(defmethod make-load-form ((tensor standard-tensor) &optional env)
++  "
++  MAKE-LOAD-FORM allows us to determine a load time value for
++  tensor, for example #.(make-tensors ...)"
++  (make-load-form-saving-slots tensor :environment env))
 +
- (defclass dense-store ()
-   ((vector-store)
-    (head)
-    (strides))
+ ;;These should ideally be memoised
+ (defgeneric rank (tensor)
+   (:documentation "
+   Syntax
+   ======
+   (rank tensor)
  
- ;;
- (defclass standard-matrix (standard-tensor)
-   ((rank
-     :allocation :class
-     :initform 2
-     :documentation "For a matrix, rank = 2."))
-   (:documentation "Basic matrix class."))
- 
- (defmethod initialize-instance :after ((matrix standard-matrix) &rest initargs)
-   (declare (ignore initargs))
-   (assert (= (rank matrix) 2) nil 'tensor-not-matrix :rank (rank matrix) :tensor matrix))
+   Purpose
+   =======
+   Returns the rank of the tensor object.")
+   (:method ((tensor standard-tensor))
+     (length (dimensions tensor))))
  
- (defmethod update-instance-for-different-class :before ((old standard-tensor) (new standard-matrix) &rest initargs)
-   (declare (ignore initargs))
-   (assert (= (rank old) 2) nil 'tensor-not-matrix :rank (rank old)))
+ (defgeneric size (tensor)
+   (:documentation "
+   Syntax
+   ======
+   (size tensor)
  
- ;;
- (defclass standard-vector (standard-tensor)
-   ((rank
-     :allocation :class
-     :initform 1
-     :documentation "For a vector, rank = 1."))
-   (:documentation "Basic vector class."))
- 
- (defmethod initialize-instance :after ((vector standard-vector) &rest initargs)
-   (declare (ignore initargs))
-   (assert (= (rank vector) 1) nil 'tensor-not-vector :rank (rank vector) :tensor vector))
+   Purpose
+   =======
+   Returns the number of elements in the tensor.")
+   (:method ((tensor standard-tensor))
+     (lvec-foldr #'* (the index-store-vector (dimensions tensor)))))
  
- (defmethod update-instance-for-different-class :before ((old standard-tensor) (new standard-vector) &rest initargs)
-   (declare (ignore initargs))
-   (assert (= (rank old) 1) nil 'tensor-not-vector :rank (rank old)))
+ (defgeneric store-size (tensor)
+   (:documentation "
+   Syntax
+   ======
+   (store-size tensor)
  
- ;;Use 
- (defmacro defmemo (func-name (tensor) &rest body)
-   "
-   This macro defines a function taking a tensor argument @arg{tensor}, and memoizes the
-   results of the code @arg{body}. It is assumed that the function definition is functional
-   in character.
- 
-   Examples:
-   @lisp
-   > (macroexpand-1 `(defmemo thing (x) (+ x (rank x))))
-   > (defun thing (x)
-       (declare (type standard-tensor x))
-       (let ((memo-hash (memos x)))
-         (multiple-value-bind (value present?) (gethash 'thing memo-hash)
-         (if present? value
-            (let ((value (progn (+ x (rank x)))))
-              (setf (gethash 'thing memo-hash) value)
-             value)))))
-   T
-   >
-   @end lisp
- "
-   (let ((decls (when (and (consp (car body)) (eql (caar body) 'declare)) (cdar body))))
-     `(defun ,func-name (,tensor)
-        (declare (type standard-tensor ,tensor)
- 		,@decls)
-        (let* ((memo-hash (memos ,tensor)))
- 	 (multiple-value-bind (value present?) (gethash ',func-name memo-hash)
- 	   (if present? (values-list value)
- 	       (let ((value (multiple-value-list (progn ,@(if decls (cdr body) body)))))
- 		 (values-list (setf (gethash ',func-name memo-hash) value)))))))))
- 		 
+   Purpose
+   =======
+   Returns the number of elements the store of the tensor can hold
+   (which is not necessarily equal to its vector length).")
+   (:method ((tensor standard-tensor))
+     (length (store tensor))))
  
- ;;
- (defvar *tensor-class-optimizations* (make-hash-table)
-   "
-   Contains a either:
-   o A property list containing:  
-   :field-type -> Field type
-   :f+ (a b) -> a + b
-   :f- (a b) -> a + (- b)
-   :finv+ (a) -> -a
-   :fid+ () -> + identity
-   :f* (a b) -> a * b
-   :f/ (a b) -> a * b^{-1}
-   :finv* (a) -> 1/a
-   :fid* () -> * identity
-   :f= (a b) -> (= a b)
-   :fconj (a) -> a^* {if nil, Field does not have a conjugation op}
- 
-   :coercer (ele) -> Coerced to store-type, with error checking
-   :coercer-unforgiving (ele) -> Coerced to store-type, no error checking
- 
-   :store-allocator (n) -> Allocates a store of size n
-   :store-type
-   :reader (store idx) => result
-   :value-writer (value store idx) => (store idx) <- value
-   :reader-writer (fstore fidx tstore tidx) => (tstore tidx) <- (fstore fidx)
-   :swapper       (fstore fidx tstore tidx) => (tstore tidx) <-> (fstore fidx)
-   o class-name (symbol) of the superclass whose optimizations
-   are to be made use of.")
- 
- (definline get-tensor-class-optimization (clname)
-   (declare (type symbol clname))
-   (symbol-plist clname))
- 
- (definline get-tensor-object-optimization (obj)
-   (symbol-plist (class-name (class-of obj))))
- 
- (defun get-tensor-class-optimization-hashtable (clname)
-   (let ((opt (gethash clname *tensor-class-optimizations*)))
-     (cond
-       ((null opt) nil)
-       ((symbolp opt)
-        (get-tensor-class-optimization opt))
-       (t (values opt clname)))))
- 
- (defun (setf get-tensor-class-optimization) (value clname)
-   (setf (gethash clname *tensor-class-optimizations*) value)
-   (let ((opt (if (symbolp value)
- 		 (get-tensor-class-optimization-hashtable clname)
- 		 value)))
-     (setf (symbol-plist (getf opt :tensor)) opt
- 	  (symbol-plist (getf opt :matrix)) opt
- 	  (symbol-plist (getf opt :vector)) opt)))
- 
- ;; Akshay: I have no idea what this does, or why we want it
- ;; (inherited from standard-matrix.lisp
- (defmethod make-load-form ((tensor standard-tensor) &optional env)
-   "
-   MAKE-LOAD-FORM allows us to determine a load time value for
-   tensor, for example #.(make-tensors ...)"
-   (make-load-form-saving-slots tensor :environment env))
+ (defgeneric print-element (tensor
+ 			   element stream)
+   (:documentation "
+   Syntax
+   ======
+   (PRINT-ELEMENT tensor element stream)
+ 
+   Purpose
+   =======
+   This generic function is specialized to TENSOR to
+   print ELEMENT to STREAM.  Called by PRINT-TENSOR/MATRIX
+   to format a tensor into the STREAM.")
+   (:method ((tensor standard-tensor) element stream)
+     (format stream "~a" element)))
  
  ;;
  (defun store-indexing-vec (idx hd strides dims)
@@@ -323,104 -246,47 +253,48 @@@
         /_        i      i
        i = 0
  
-   of the store."))
- 
- (defgeneric (setf tensor-ref) (value tensor &rest subscripts))
- 
- ;;
- (defgeneric tensor-store-ref (tensor store-idx)
-   (:documentation "
-   Syntax
-   ======
-   (tensor-store-ref store store-idx)
- 
-   Purpose
-   =======
-   Return the element store-idx of the tensor store."))
- 
- (defgeneric (setf tensor-store-ref) (value tensor idx))
- 
- ;;
- (defgeneric print-element (tensor element stream)
-   (:documentation "
-   Syntax
-   ======
-   (PRINT-ELEMENT tensor element stream)
- 
-   Purpose
-   =======
-   This generic function is specialized to TENSOR to
-   print ELEMENT to STREAM.  Called by PRINT-TENSOR/MATRIX
-   to format a tensor into the STREAM.")
-   (:method (tensor element stream)
-     (format stream "~a" element)))
- 
- ;;
- (defmacro define-tensor
-   ((tensor-class element-type store-element-type store-type &rest class-decls) &key
-     f+ f- finv+ fid+ f* f/ finv* fid* fconj f=
-     matrix vector
-     store-allocator coercer coercer-unforgiving reader value-writer value-incfer reader-writer swapper)
-   ;;Error checking
-   (assert (and f+ f- finv+ fid+ f* f/ finv* fid* f= store-allocator coercer coercer-unforgiving matrix vector reader value-writer value-incfer reader-writer swapper))
-   ;;
-   `(progn
-      ;;Class definitions
-      (defclass ,tensor-class (standard-tensor)
-        ((store :type ,store-type))
-        ,@class-decls)
-      (defclass ,matrix (standard-matrix ,tensor-class)
-        ())
-      (defclass ,vector (standard-vector ,tensor-class)
-        ())
-      ;;Store refs
-      (defmethod tensor-ref ((tensor ,tensor-class) &rest subs)
-        (let-typed ((lidx (store-indexing (if (typep (car subs) '(or cons vector)) (car subs) subs) tensor) :type index-type)
- 		   (sto-x (store tensor) :type ,(linear-array-type store-element-type)))
- 	 (,reader sto-x lidx)))
-      (defmethod (setf tensor-ref) (value (tensor ,tensor-class) &rest subs)
-        (let-typed ((lidx (store-indexing (if (typep (car subs) '(or cons vector)) (car subs) subs) tensor) :type index-type)
- 		   (sto-x (store tensor) :type ,(linear-array-type store-element-type)))
- 	 (,value-writer (,coercer-unforgiving value) sto-x lidx)))
-      (defmethod tensor-store-ref ((tensor ,tensor-class) lidx)
-        (declare (type index-type lidx))
-        (let-typed ((sto-x (store tensor) :type ,(linear-array-type store-element-type)))
- 	 (,reader sto-x lidx)))
-      (defmethod (setf tensor-store-ref) (value (tensor ,tensor-class) lidx)
-        (declare (type index-type lidx))
-        (let-typed ((sto-x (store tensor) :type ,(linear-array-type store-element-type)))
- 	 (,value-writer (,coercer-unforgiving value) sto-x lidx)))
-      ;;
-      (eval-when (:compile-toplevel :load-toplevel :execute)
-        (let ((hst (list
- 		   :tensor ',tensor-class
- 		   :matrix ',matrix
- 		   :vector ',vector
- 		   :element-type ',element-type
- 		   :f+ ',f+
- 		   :f- ',f-
- 		   :finv+ ',finv+
- 		   :fid+ ',fid+
- 		   :f* ',f*
- 		   :f/ ',f/
- 		   :finv* ',finv*
- 		   :fid* ',fid*
- 		   :f= ',f=
- 		   :fconj ',fconj
- 		   :reader ',reader
- 		   :value-writer ',value-writer
- 		   :value-incfer ',value-incfer
- 		   :reader-writer ',reader-writer
- 		   :swapper ',swapper
- 		   :store-allocator ',store-allocator
- 		   :coercer ',coercer
- 		   :coercer-unforgiving ',coercer-unforgiving
- 		   :store-type ',store-element-type)))
- 	 (setf (get-tensor-class-optimization ',tensor-class) hst
- 	       (get-tensor-class-optimization ',matrix) ',tensor-class
- 	       (get-tensor-class-optimization ',vector) ',tensor-class)
- 	 (setf (symbol-plist ',tensor-class) hst)))))
+   of the store.")
+   (:method ((tensor standard-tensor) &rest subscripts)
+     (let ((clname (class-name (class-of tensor))))
+       (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname)
+       (compile-and-eval
+        `(defmethod ref ((tensor ,clname) &rest subscripts)
+ 	  (let ((subs (if (numberp (car subscripts)) subscripts (car subscripts))))
+ 	    (t/store-ref ,clname (store tensor) (store-indexing subs tensor)))))
+       (apply #'ref (cons tensor subscripts)))))
+ 
+ (defgeneric (setf ref) (value tensor &rest subscripts)
+   (:method (value (tensor standard-tensor) &rest subscripts)
+     (let ((clname (class-name (class-of tensor))))
+       (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname)
+       (compile-and-eval
+        `(defmethod (setf ref) (value (tensor ,clname) &rest subscripts)
+ 	  (let* ((subs (if (numberp (car subscripts)) subscripts (car subscripts)))
+ 		 (idx (store-indexing subs tensor)))
+ 	    (t/store-set ,clname value (store tensor) idx)
+ 	    (t/store-ref ,clname (store tensor) idx))))
+     (setf (apply #'ref (cons tensor subscripts)) value))))
+ 
+ (defgeneric store-ref (tensor idx)
+   (:documentation  "Generic serial read access to the store.")
+   (:method ((tensor standard-tensor) idx)
+     (let ((clname (class-name (class-of tensor))))
+       (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname)
+       (compile-and-eval
+        `(defmethod store-ref ((tensor ,clname) idx)
+ 	  (t/store-ref ,clname (store tensor) idx))))
+     (store-ref tensor idx)))
+ 
+ (defgeneric (setf store-ref) (value tensor idx)
+   (:method (value (tensor standard-tensor) idx)
+     (let ((clname (class-name (class-of tensor))))
+       (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname)
+       (compile-and-eval
+        `(defmethod (setf store-ref) (value (tensor ,clname) idx)
+ 	  (t/store-set ,clname value (store tensor) idx)
+ 	  (t/store-ref ,clname (store tensor) idx))))
+     (setf (store-ref tensor idx) value)))
 +
  ;;
  (defun tensor-typep (tensor subscripts)
    "
diff --cc src/level-1/tensor-maker.lisp
index 700f8a5,2f1b409..21959a8
--- a/src/level-1/tensor-maker.lisp
+++ b/src/level-1/tensor-maker.lisp
@@@ -1,93 -1,30 +1,31 @@@
  (in-package #:matlisp)
  
- (defmacro make-tensor-maker (func-name (tensor-class))
-   (let ((opt (get-tensor-class-optimization-hashtable tensor-class)))
-     (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
-     `(progn
-        (eval-when (:compile-toplevel :load-toplevel :execute)
- 	 (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
- 	   (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
- 	   (setf (getf opt :maker) ',func-name
- 		 (get-tensor-class-optimization ',tensor-class) opt)))
-        (defun ,func-name (&rest args)
- 	 (labels ((make-dims (dims)
- 		    (declare (type cons dims))
- 		    (let*-typed ((vdim (make-index-store dims) :type index-store-vector)
- 				 (ss (very-quickly (lvec-foldl #'(lambda (x y) (the index-type (* x y))) vdim)))
- 				 (store (,(getf opt :store-allocator) ss))
- 				 (rnk (length vdim))
- 				 (ret (let ((*check-after-initializing?* nil))
- 					(make-instance (case rnk (2 ',(getf opt :matrix)) (1 ',(getf opt :vector)) (t ',tensor-class))
- 						       :rank rnk
- 						       :strides (make-stride vdim)
- 						       :store store :store-size ss :dimensions vdim))))
- 				(setf (slot-value ret 'number-of-elements) ss)
- 				ret))
- 		  (make-from-array (arr)
- 		    (declare (type (array * *) arr))
- 		    (let* ((ret (make-dims (array-dimensions arr)))
- 			   (st-r (store ret))
- 			   (lst (make-list (rank ret))))
- 		      (declare (type ,tensor-class ret)
- 			       (type ,(linear-array-type (getf opt :store-type)) st-r))
- 		      (mod-dotimes (idx (dimensions ret))
- 			with (linear-sums
- 			      (of-r (strides ret) (head ret)))
- 			do (,(getf opt :value-writer) (,(getf opt :coercer) (apply #'aref arr (lvec->list! idx lst))) st-r of-r))
- 		      ret))
- 		  (make-from-list (lst)
- 		    (let* ((ret (make-dims (list-dimensions lst)))
- 			   (st-r (store ret)))
- 		      (declare (type ,tensor-class ret)
- 			       (type ,(linear-array-type (getf opt :store-type)) st-r))
- 		      (list-loop (idx ele lst)
- 				 with (linear-sums
- 				       (of-r (strides ret) (head ret)))
- 				 do (,(getf opt :value-writer) (,(getf opt :coercer) ele) st-r of-r))
- 		      ret)))
- 	   (let ((largs (length args)))
- 	     (if (= largs 1)
- 		 (etypecase (first args)
- 		   (array
- 		    (make-from-array (first args)))
- 		   (cons
- 		    (make-from-list (first args)))
- 		   (integer
- 		    (make-dims (list (first args)))))
- 		 (make-dims args))))))))
+ (deft/generic (t/zeros #'subtypep) sym (dims &optional initial-element))
+ (deft/method t/zeros (class standard-tensor) (dims &optional initial-element)
+   (with-gensyms (astrs adims sizs)
+     `(let* ((,adims (make-index-store ,dims)))
+        (multiple-value-bind (,astrs ,sizs) (make-stride ,adims)
+ 	 (make-instance ',class
+ 			:dimensions ,adims			  
+ 			:head 0
+ 			:strides ,astrs
+ 			:store (t/store-allocator ,class ,sizs ,@(when initial-element `(,initial-element))))))))
  
- (make-tensor-maker make-real-tensor (real-tensor))
- (make-tensor-maker make-complex-tensor (complex-tensor))
+ (defgeneric zeros-generic (dims dtype)
+   (:documentation "Create a tensor with dimensions @arg{dims} of class @arg{dtype}.")
+   (:method ((dims cons) (dtype t))
+     (assert (member dtype *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class dtype)
+     (compile-and-eval
+      `(defmethod zeros-generic ((dims cons) (dtype (eql ',dtype)))
+ 	(t/zeros ,dtype dims)))
+     (zeros-generic dims dtype)))
  
- #+maxima
- (make-tensor-maker make-symbolic-tensor (symbolic-tensor))
- 
- ;;Had to move it here in the wait for copy!
- (definline sub-tensor (tensor subscripts &optional (preserve-rank nil))
-   (copy (sub-tensor~ tensor subscripts preserve-rank)))
- 
- ;;This seems unnecessary.
- (defmacro make-zeros-dims (func-name (tensor-class))
-   (let ((opt (get-tensor-class-optimization-hashtable tensor-class)))
-     (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
-     `(progn
-        (eval-when (:compile-toplevel :load-toplevel :execute)
- 	 (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
- 	   (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
- 	   (setf (getf opt :zero-maker) ',func-name
- 		 (get-tensor-class-optimization ',tensor-class) opt)))
-        (defun ,func-name (dims)
- 	 (declare (type (or cons index-store-vector) dims))
- 	 (let*-typed ((dims (if (consp dims) (make-index-store dims) (copy-seq dims)) :type index-store-vector)
- 		      (rnk (length dims) :type index-type))
- 		     (multiple-value-bind (strides size) (make-stride dims)		  
- 		       (let ((*check-after-initializing?* nil))
- 			 (make-instance (case rnk (2 ',(getf opt :matrix)) (1 ',(getf opt :vector)) (t ',tensor-class))
- 					:strides strides :number-of-elements 
- 					:dimensions dims :store (,(getf opt :store-allocator) size) :store-size size)))))))
- 
- (make-zeros-dims real-typed-zeros (real-tensor))
- (make-zeros-dims complex-typed-zeros (complex-tensor))
- 
- #+maxima
- (make-zeros-dims symbolic-typed-zeros (symbolic-tensor))
+ (definline zeros (dims &optional (type 'real-tensor))
 -  (etypecase dims
 -    (vector
 -     (zeros-generic (lvec->list dims) type))
 -    (cons
 -     (zeros-generic dims type))
 -    (fixnum
 -     (zeros-generic (list dims) type))))
++  (let ((*check-after-initializing?* nil))
++    (etypecase dims
++      (vector
++       (zeros-generic (lvec->list dims) type))
++      (cons
++       (zeros-generic dims type))
++      (fixnum
++       (zeros-generic (list dims) type)))))

commit 24def88c5b5227b29154cee9e05d88d119ceade8
Author: Akshay Srinivasan <aks...@gm...>
Date:   Tue Jun 18 23:18:15 2013 -0700

    o This is a snapshot of the current work to make writing generic template
      code more manageable.

diff --git a/matlisp.asd b/matlisp.asd
index 09ec278..dc7a129 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -69,6 +69,8 @@
 	       (:file "macros"
 		      :depends-on ("functions"))
 	       (:file "lvec"
+		      :depends-on ("macros" "functions"))
+	       (:file "template"
 		      :depends-on ("macros" "functions"))))
 
 (asdf:defsystem fortran-names
@@ -104,8 +106,9 @@
 	    :depends-on ("foreign-core")
 	    :pathname "base"
 	    :components ((:file "tweakable")
+			 (:file "template")
 			 (:file "standard-tensor"
-				:depends-on ("tweakable"))
+				:depends-on ("tweakable" "template"))
 			 ;;
 			 (:file "loopy"
 				:depends-on ("standard-tensor"))
@@ -122,17 +125,20 @@
    (:module "matlisp-classes"
 	    :pathname "classes"
 	    :depends-on ("matlisp-base")
-	    :components ((:file "real-tensor")
-			 (:file "complex-tensor")
+	    :components ((:file "numeric")
 			 #+maxima
 			 (:file "symbolic-tensor")
+			 #+nil
 			 (:file "matrix"
-				:depends-on ("real-tensor" "complex-tensor"))))
+				:depends-on ("numeric"))))
    (:module "matlisp-level-1"
 	    :pathname "level-1"
 	    :depends-on ("matlisp-base" "matlisp-classes" "foreign-core")
 	    :components ((:file "tensor-maker")
+			 #+nil
+			 (
 			 (:file "swap")
+
 			 (:file "copy"
 				:depends-on ("tensor-maker"))
 			 (:file "realimag"
@@ -144,19 +150,23 @@
 			 (:file "axpy"
 				:depends-on ("copy" "scal"))
 			 (:file "trans"
-				:depends-on ("scal" "copy"))))
+				:depends-on ("scal" "copy")))))
+   #+nil
    (:module "matlisp-level-2"
 	    :pathname "level-2"
 	    :depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1")
 	    :components ((:file "gemv")))
+   #+nil
    (:module "matlisp-level-3"
 	    :pathname "level-3"
 	    :depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1" "matlisp-level-2")
 	    :components ((:file "gemm")))
+   #+nil
    (:module "matlisp-lapack"
 	    :pathname "lapack"
 	    :depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3")
 	    :components ((:file "getrf")))
+   #+nil
    (:module "matlisp-sugar"
 	    :pathname "sugar"
 	    :depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3")
diff --git a/packages.lisp b/packages.lisp
index 64e09af..96949cb 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -63,15 +63,18 @@
    #:tensor-dimension-mismatch
    #:tensor-store-not-consecutive
    #:tensor-method-does-not-exist
+   #:tensor-abstract-class
 ))
 
 (defpackage "MATLISP-UTILITIES"
   (:use #:common-lisp #:matlisp-conditions)
   (:export #:ensure-list #:id
 	   #:vectorify #:copy-n
-	   #:zip #:zip-eq
+	   #:ensure-args #:repsym #:findsym #:find-tag
+	   #:zip #:zip-eq #:zipsym
+	   #:list-eq #:setadd #:setrem
 	   #:cut-cons-chain!
-	   #:slot-values 
+	   #:slot-values #:remmeth
 	   #:recursive-append #:unquote-args #:flatten
 	   #:format-to-string #:string+
 	   #:linear-array-type
@@ -89,6 +92,11 @@
 	   #:inlining #:definline
 	   #:with-optimization #:quickly #:very-quickly #:slowly #:quickly-if))
 
+
+(defpackage "MATLISP-TEMPLATE"
+  (:use #:common-lisp #:matlisp-utilities)
+  (:export #:deft/generic #:deft/method #:remt/method))
+
 ;;Modified version of Mark Kantrowitz' infix package.
 (defpackage "MATLISP-INFIX"
   (:use #:common-lisp #:matlisp-conditions #:matlisp-utilities)
@@ -162,7 +170,7 @@
 
 (defpackage "MATLISP"
   (:use #:common-lisp
-	#:matlisp-conditions #:matlisp-utilities #:matlisp-ffi
+	#:matlisp-conditions #:matlisp-utilities #:matlisp-ffi #:matlisp-template
 	#:matlisp-blas #:matlisp-lapack #:matlisp-dfftpack #:matlisp-libmatlisp)
   (:export #:index-type #:index-array #:allocate-index-store #:make-index-store
 	   ;;Standard-tensor
diff --git a/src/base/blas-helpers.lisp b/src/base/blas-helpers.lisp
index f30164e..e34dc8b 100644
--- a/src/base/blas-helpers.lisp
+++ b/src/base/blas-helpers.lisp
@@ -41,7 +41,7 @@
 	   :finally (return (aref sort-std 0))))))
 
 (defun blas-matrix-compatible-p (matrix op)
-  (declare (type standard-matrix matrix))
+  (declare (type standard-tensor matrix))
   (let*-typed ((stds (strides matrix) :type index-store-vector)
 	       (rs (aref stds 0) :type index-type)
 	       (cs (aref stds 1) :type index-type))
@@ -103,3 +103,7 @@
 
 (defun make-stride (dims)
   (ecase *default-stride-ordering* (:row-major (make-stride-rmj dims)) (:col-major (make-stride-cmj dims))))
+
+(definline call-fortran? (x lb)
+  (declare (type standard-tensor x))
+  (> (lvec-max (the index-store-vector (dimensions x))) lb))
diff --git a/src/base/generic-copy.lisp b/src/base/generic-copy.lisp
index 71431fa..128d66c 100644
--- a/src/base/generic-copy.lisp
+++ b/src/base/generic-copy.lisp
@@ -1,6 +1,6 @@
 (in-package #:matlisp)
 
-(defgeneric copy! (from-tensor to-tensor)
+(defgeneric copy! (from to)
   (:documentation
    "
   Syntax
@@ -10,45 +10,31 @@
   Purpose
   =======
   Copies the contents of X into Y. Returns Y.
-
-  X,Y must have the same dimensions, and
-  ergo the same number of elements.
-
-  Furthermore, X may be a scalar, in which
-  case Y is filled with X.
 ")
-  (:method :before ((x cons) (y cons))
-	   (assert (= (length x) (length y))))
   (:method :before ((x array) (y array))
-	   (assert (subtypep (array-element-type x) (array-element-type y))
-		   nil 'invalid-type
-		   :given (array-element-type y) :expected (array-element-type x))
-	   (assert (and
-		    (= (array-rank x) (array-rank y))
-		    (reduce #'(lambda (x y) (and x y))
-			    (mapcar #'= (array-dimensions x) (array-dimensions y))))
+	   (assert (list-eq (array-dimensions x) (array-dimensions y))		   
 		   nil 'dimension-mismatch)))
 
 (defmethod copy! ((from cons) (to cons))
   (let-rec cdr-writer ((flst from) (tlst to))
-	   (if (null flst) to
-	       (progn
-		 (rplaca tlst (car flst))
-		 (cdr-writer (cdr flst) (cdr tlst))))))
+    (unless (or (null flst) (null tlst))
+      (setf (car tlst) (car flst))
+      (cdr-writer (cdr flst) (cdr tlst))))
+  to)
 
-(defmethod copy! (from (to cons))
+(defmethod copy! ((from t) (to cons))
   (mapl #'(lambda (lst) (rplaca lst from)) to)
   to)
 
 (defmethod copy! ((from array) (to array))
   (let ((lst (make-list (array-rank to))))
     (mod-dotimes (idx (make-index-store (array-dimensions to)))
-      do (progn
-	   (lvec->list! idx lst)
-	   (setf (apply #'aref to lst) (apply #'aref from lst)))))
+      :do (progn
+	    (lvec->list! idx lst)
+	    (setf (apply #'aref to lst) (apply #'aref from lst)))))
   to)
 
-(defmethod copy! (from (to array))
+(defmethod copy! ((from t) (to array))
   (let ((lst (make-list (array-rank to))))
     (mod-dotimes (idx (make-index-store (array-dimensions to)))
       do (progn
@@ -57,6 +43,42 @@
   to))
 
 ;;
+(defmethod copy! :before ((x array) (y standard-tensor))
+  (assert (list-eq (array-dimensions x) (lvec->list (dimensions y)))
+	  nil 'dimension-mismatch))
+(defmethod copy! :before ((x standard-tensor) (y array))
+  (assert (list-eq (array-dimensions y) (lvec->list (dimensions x)))
+	  nil 'dimension-mismatch))
+
+(defmethod copy! ((...
 
[truncated message content]