Menu
▾
▴
[Matlisp-commit] [matlisp-git]matlisp branch matlisp-cffi updated. 2012-02-23-57-g6173362
|
From: Akshay S. <ak...@us...> - 2012-03-17 11:00:45
|
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, matlisp-cffi has been updated
via 61733620324195c7c1a45a770e29637a74329ebd (commit)
via f868f214196101712deba5c07cc60c9e43e1f9b0 (commit)
from 54341c25f149263190e4ffad1c516d93a79ad3ed (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 61733620324195c7c1a45a770e29637a74329ebd
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Mar 17 16:25:11 2012 +0530
-> Other odd fixes to get matlisp to compile.
diff --git a/matlisp.asd b/matlisp.asd
index 6af45a8..7898782 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -100,17 +100,18 @@
:depends-on ("foreign-interface"
"foreign-functions")
:components ((:file "conditions")
- (:file "copy")
(:file "standard-matrix")
(:file "real-matrix"
- :depends-on ("standard-matrix" "copy"))
+ :depends-on ("standard-matrix"))
(:file "complex-matrix"
- :depends-on ("standard-matrix" "copy"))
+ :depends-on ("standard-matrix"))
;; (:file "ref"
;; :depends-on ("matrix"))
+ (:file "copy"
+ :depends-on ("standard-matrix"))
(:file "print"
:depends-on ("standard-matrix"))))
-
+
(:module "matlisp-blas-wrappers"
:pathname "src/"
:depends-on ("foreign-interface"
diff --git a/src/gemm.lisp b/src/gemm.lisp
index ff28c3f..ae4d935 100644
--- a/src/gemm.lisp
+++ b/src/gemm.lisp
@@ -112,8 +112,8 @@
(rotatef st-a st-b)
(rotatef nr-c nc-c)
;;
- (setf fort-job-a (fortran-string-nop fort-job-a))
- (setf fort-job-b (fortran-string-nop fort-job-b)))
+ (setf fort-job-a (fortran-snop fort-job-a))
+ (setf fort-job-b (fortran-snop fort-job-b)))
(,blas-gemm-func fort-job-a fort-job-b
nr-c nc-c k
alpha
@@ -386,4 +386,4 @@
(complex-coerce beta)
beta)
c)))
- (gemm! alpha a b 1d0 c job)))
\ No newline at end of file
+ (gemm! alpha a b 1d0 result job)))
\ No newline at end of file
diff --git a/src/standard-matrix.lisp b/src/standard-matrix.lisp
index e223d37..1d168e9 100644
--- a/src/standard-matrix.lisp
+++ b/src/standard-matrix.lisp
@@ -396,8 +396,7 @@ Cannot create a sub-matrix of size (~a ~a) starting at (~a ~a)" nrows ncols i j)
(defun fortran-nop (op)
(ecase op (:t "N") (:n "T")))
-(declaim (inline (fortran-string-nop)))
-(defun fortran-string-nop (sop)
+(defun fortran-snop (sop)
(cond
((string= sop "N") "T")
((string= sop "T") "N")
commit f868f214196101712deba5c07cc60c9e43e1f9b0
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Mar 17 15:58:16 2012 +0530
-> Gemm! works
diff --git a/matlisp.asd b/matlisp.asd
index 4632cf4..6af45a8 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -100,16 +100,16 @@
:depends-on ("foreign-interface"
"foreign-functions")
:components ((:file "conditions")
+ (:file "copy")
(:file "standard-matrix")
(:file "real-matrix"
- :depends-on ("standard-matrix"))
+ :depends-on ("standard-matrix" "copy"))
(:file "complex-matrix"
- :depends-on ("standard-matrix"))
+ :depends-on ("standard-matrix" "copy"))
;; (:file "ref"
;; :depends-on ("matrix"))
(:file "print"
- :depends-on ("standard-matrix"))
- (:file "copy")))
+ :depends-on ("standard-matrix"))))
(:module "matlisp-blas-wrappers"
:pathname "src/"
@@ -119,6 +119,7 @@
:components ((:file "axpy")
(:file "scal")
(:file "swap")
+ (:file "gemv")
(:file "gemm")))
(:module "matlisp-lapack-wrappers"
diff --git a/packages.lisp b/packages.lisp
index 74385fa..7b53ddc 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -326,6 +326,8 @@
"GEEV"
"GELSY!"
"GELSY"
+ #:gemv!
+ #:gemv
"GEMM!"
"GEMM"
"GESV!"
diff --git a/src/axpy.lisp b/src/axpy.lisp
index f001fd8..69a7005 100644
--- a/src/axpy.lisp
+++ b/src/axpy.lisp
@@ -171,8 +171,10 @@ don't know how to coerce COMPLEX to REAL"))
"))
(defmethod axpy :before ((alpha number) (x standard-matrix) (y standard-matrix))
- (mlet* (((nr-x nc-x) (slot-values x '(number-of-rows number-of-cols)) :type (fixnum fixnum))
- ((nr-y nc-y) (slot-values y '(number-of-rows number-of-cols)) :type (fixnum fixnum)))
+ (mlet* (((nr-x nc-x) (slot-values x '(number-of-rows number-of-cols))
+ :type (fixnum fixnum))
+ ((nr-y nc-y) (slot-values y '(number-of-rows number-of-cols))
+ :type (fixnum fixnum)))
(unless (and (= nr-x nr-y) (= nc-x nc-y))
(error "Arguments X,Y to AXPY are of different dimensions."))))
diff --git a/src/foreign-real-matrix.lisp b/src/foreign-real-matrix.lisp
index 8f483ed..a0c0248 100644
--- a/src/foreign-real-matrix.lisp
+++ b/src/foreign-real-matrix.lisp
@@ -3,16 +3,22 @@
(defclass foreign-real-matrix (real-matrix)
((store
- :type foreign-pointer))
+ :type cffi:foreign-pointer))
(:documentation "A class of matrices with real elements."))
-(defclass foreign-complex-matrix (complex-matrix)
- ((store
- :type foreign-pointer))
- (:documentation "A class of matrices with complex elements."))
+;;
+(defmethod matrix-ref-1d ((matrix foreign-real-matrix) (idx fixnum))
+ (let ((store (store matrix)))
+ (declare (type cffi:foreign-pointer store))
+ (cffi:mem-aref store :double idx)))
+
+(defmethod (setf matrix-ref-1d) ((value cl:real) (matrix foreign-real-matrix) (idx fixnum))
+ (let ((store (store matrix)))
+ (declare (type cffi:foreign-pointer store))
+ (setf (cffi:mem-aref store :double idx) (coerce value 'double-float))))
-(defun make-foreign-real-matrix (n m store)
+(defun make-foreign-real-matrix (n m store store-size)
"
Syntax
======
diff --git a/src/gemm.lisp b/src/gemm.lisp
index c42b892..ff28c3f 100644
--- a/src/gemm.lisp
+++ b/src/gemm.lisp
@@ -77,61 +77,86 @@
(in-package "MATLISP")
-;; Why write things again and again, when Lisp will gladly do it for you :)
-(defmacro generate-typed-gemm!-func (func element-type matrix-type blas-func)
+(defmacro generate-typed-gemm!-func (func element-type store-type matrix-type blas-gemm-func lisp-gemv-func)
`(defun ,func (alpha a b beta c job)
(declare (optimize (safety 0) (speed 3))
(type ,element-type alpha beta)
(type ,matrix-type a b c)
(type symbol job))
- (mlet* ((n (nrows c) :type fixnum)
- (m (ncols c) :type fixnum)
- (k (if (member job '(:nn :nt))
- (ncols a)
- (nrows a))
- :type fixnum)
- ((order-a lda job-a) (ecase job
- ((:nn :nt) (get-order-stride a "N"))
- ((:tn :tt) (get-order-stride a "T")))
- :type (nil fixnum (string 1)))
- ((order-b ldb job-b) (ecase job
- ((:nn :tn) (get-order-stride b "N"))
- ((:nt :tt) (get-order-stride b "T")))
- :type (nil fixnum (string 1)))
- ((order-c ldc job-c) (get-order-stride c "N")
+ (mlet* ((job-a (ecase job ((:nn :nt) :n) ((:tn :tt) :t)) :type symbol)
+ (job-b (ecase job ((:nn :tn) :n) ((:nt :tt) :t)) :type symbol)
+ ((hd-c nr-c nc-c st-c) (slot-values c '(head number-of-rows number-of-cols store))
+ :type (fixnum fixnum fixnum (,store-type *)))
+ ((hd-a st-a) (slot-values a '(head store))
+ :type (fixnum (,store-type *)))
+ ((hd-b st-b) (slot-values b '(head store))
+ :type (fixnum (,store-type *)))
+ (k (if (eq job-a :n)
+ (ncols a)
+ (nrows a))
+ :type fixnum)
+ ((order-a lda fort-job-a) (blas-matrix-compatible-p a job-a)
+ :type (symbol fixnum (string 1)))
+ ((order-b ldb fort-job-b) (blas-matrix-compatible-p b job-b)
+ :type (symbol fixnum (string 1)))
+ ((order-c ldc fort-job-c) (blas-matrix-compatible-p c :n)
:type (nil fixnum (string 1))))
-
- (when (string= job-c "T")
- (rotatef a b)
- (rotatef lda ldb)
- (rotatef n m)
- (rotatef job-a job-b)
- ;;
- (setf job-a (cond
- ((string= "N" job-a) "T")
- ((string= "T" job-a) "N")
- (t "N")))
- (setf job-b (cond
- ((string= "N" job-b) "T")
- ((string= "T" job-b) "N")
- (t "N"))))
-
- (,blas-func job-a ; TRANSA
- job-b ; TRANSB
- n ; M
- m ; N (LAPACK takes N M opposite our convention)
- k ; K
- alpha ; ALPHA
- (store a) ; A
- lda ; LDA
- (store b) ; B
- ldb ; LDB
- beta ; BETA
- (store c) ; C
- ldc ; LDC
- :head-a (head a) :head-b (head b) :head-c (head c))
- c)))
-
+ ;;
+ (if (and (> lda 0) (> ldb 0) (> ldc 0))
+ (progn
+ (when (string= fort-job-c "T")
+ (rotatef a b)
+ (rotatef lda ldb)
+ (rotatef fort-job-a fort-job-b)
+ (rotatef hd-a hd-b)
+ (rotatef st-a st-b)
+ (rotatef nr-c nc-c)
+ ;;
+ (setf fort-job-a (fortran-string-nop fort-job-a))
+ (setf fort-job-b (fortran-string-nop fort-job-b)))
+ (,blas-gemm-func fort-job-a fort-job-b
+ nr-c nc-c k
+ alpha
+ st-a lda
+ st-b ldb
+ beta
+ st-c ldc
+ :head-a hd-a :head-b hd-b :head-c hd-c))
+ (progn
+ (when (eq job-a :t) (transpose-i! a))
+ (when (eq job-b :t) (transpose-i! b))
+ ;;
+ (symbol-macrolet
+ ((loop-col
+ (mlet* ((cs-b (col-stride b) :type fixnum)
+ (cs-c (col-stride c) :type fixnum)
+ (col-b (col! b 0) :type ,matrix-type)
+ (col-c (col! c 0) :type ,matrix-type))
+ (dotimes (j nc-c)
+ (when (> j 0)
+ (setf (head col-b) (+ (head col-b) cs-b))
+ (setf (head col-c) (+ (head col-c) cs-c)))
+ (,lisp-gemv-func alpha a col-b beta col-c :n))))
+ (loop-row
+ (mlet* ((rs-a (row-stride a) :type fixnum)
+ (rs-c (row-stride c) :type fixnum)
+ (row-a (transpose-i! (row! a 0)) :type ,matrix-type)
+ (row-c (transpose-i! (row! c 0)) :type ,matrix-type))
+ (dotimes (i nr-c)
+ (when (> i 0)
+ (setf (head row-a) (+ (head row-a) rs-a))
+ (setf (head row-c) (+ (head row-c) rs-c)))
+ (,lisp-gemv-func alpha b row-a beta row-c :t)))))
+ (cond
+ (order-a loop-col)
+ (order-b loop-row)
+ ((< nr-c nc-c) loop-row)
+ (t loop-col)))
+ ;;
+ (when (eq job-a :t) (transpose-i! a))
+ (when (eq job-b :t) (transpose-i! b))
+ )))
+ c))
;;;;
(defgeneric gemm! (alpha a b beta c &optional job)
(:documentation
@@ -197,7 +222,9 @@
(error "dimensions of A,B,C given to GEMM! do not match"))))
;;
-(generate-typed-gemm!-func real-double-gemm!-typed real-matrix-element-type real-matrix blas:dgemm)
+(generate-typed-gemm!-func real-double-gemm!-typed
+ double-float real-matrix-store-type real-matrix
+ blas:dgemm real-double-gemv!-typed)
(defmethod gemm! ((alpha cl:real) (a real-matrix) (b real-matrix)
(beta cl:real) (c real-matrix)
@@ -207,7 +234,9 @@
job))
;;
-(generate-typed-gemm!-func complex-double-gemm!-typed (complex (double-float * *)) complex-matrix blas:zgemm)
+(generate-typed-gemm!-func complex-double-gemm!-typed
+ complex-double-float complex-matrix-store-type complex-matrix
+ blas:zgemm complex-double-gemv!-typed)
(defmethod gemm! ((alpha number) (a complex-matrix) (b complex-matrix)
(beta number) (c complex-matrix)
@@ -215,41 +244,85 @@
(complex-double-gemm!-typed (complex-coerce alpha) a b
(complex-coerce beta) c job))
+;
+(defmethod gemm! ((alpha number) (a real-matrix) (b complex-matrix)
+ (beta complex) (c complex-matrix)
+ &optional (job :nn))
+ (scal! (complex-coerce beta) c)
+ (gemm! alpha a b 1d0 c))
(defmethod gemm! ((alpha cl:real) (a real-matrix) (b complex-matrix)
- (beta number) (c complex-matrix)
+ (beta cl:real) (c complex-matrix)
&optional (job :nn))
- (scal! beta c)
- (real-double-gemm!-typed (coerce alpha 'double-float) a (realpart! b)
- 1d0 (realpart! c) job)
- (real-double-gemm!-typed (coerce alpha 'double-float) a (imagpart! b)
- 1d0 (imagpart! c) job))
+ (let ((r-b (realpart! b))
+ (i-b (imagpart! b))
+ (r-c (realpart! c))
+ (i-c (imagpart! c))
+ (r-al (coerce alpha 'double-float))
+ (r-be (coerce beta 'double-float)))
+ (declare (type real-matrix r-b i-b r-c i-c)
+ (type double-float r-al r-be))
+ (real-double-gemm!-typed r-al a r-b r-be r-c job)
+ (real-double-gemm!-typed r-al a i-b r-be i-c job)))
(defmethod gemm! ((alpha complex) (a real-matrix) (b complex-matrix)
- (beta number) (c complex-matrix)
+ (beta cl:real) (c complex-matrix)
&optional (job :nn))
- (scal! beta c)
- (real-double-gemm!-typed (coerce alpha 'double-float) a (realpart! b)
- 1d0 (realpart! c) job)
- (real-double-gemm!-typed (coerce alpha 'double-float) a (imagpart! b)
- 1d0 (imagpart! c) job))
-
+ (let ((r-b (realpart! b))
+ (i-b (imagpart! b))
+ (r-c (realpart! c))
+ (i-c (imagpart! c))
+ (r-al (coerce (realpart alpha) 'double-float))
+ (i-al (coerce (imagpart alpha) 'double-float))
+ (r-be (coerce beta 'double-float)))
+ (declare (type real-matrix r-b i-b r-c i-c)
+ (type double-float r-al r-be))
+ ;;
+ (real-double-gemm!-typed r-al a r-b r-be r-c job)
+ (real-double-gemm!-typed (- i-al) a i-b 1d0 r-c job)
+ ;;
+ (real-double-gemm!-typed r-al a i-b r-be i-c job)
+ (real-double-gemm!-typed i-al a r-b 1d0 i-c job)))
+
+;
+(defmethod gemm! ((alpha number) (a complex-matrix) (b real-matrix)
+ (beta complex) (c complex-matrix)
+ &optional (job :nn))
+ (scal! (complex-coerce beta) c)
+ (gemm! alpha a b 1d0 c))
-;;
-(defmethod gemm! ((alpha number) (a standard-matrix) (b standard-matrix)
- (beta number) (c complex-matrix)
+(defmethod gemm! ((alpha cl:real) (a complex-matrix) (b real-matrix)
+ (beta cl:real) (c complex-matrix)
&optional (job :nn))
- (let ((a (typecase a
- (real-matrix (copy! a (make-complex-matrix-dim (nrows a) (ncols a))))
- (complex-matrix a)
- (t (error "argument A given to GEMM! is not a REAL-MATRIX or COMPLEX-MATRIX"))))
- (b (typecase b
- (real-matrix (copy! b (make-complex-matrix-dim (nrows b) (ncols b))))
- (complex-matrix b)
- (t (error "argument B given to GEMM! is not a REAL-MATRIX or COMPLEX-MATRIX")))))
-
- (gemm! (complex-coerce alpha) a b
- (complex-coerce beta) c job)))
+ (let ((r-a (realpart! a))
+ (i-a (imagpart! a))
+ (r-c (realpart! c))
+ (i-c (imagpart! c))
+ (r-al (coerce alpha 'double-float))
+ (r-be (coerce beta 'double-float)))
+ (declare (type real-matrix r-a i-a r-c i-c)
+ (type double-float r-al r-be))
+ (real-double-gemm!-typed r-al r-a r-b r-be r-c job)
+ (real-double-gemm!-typed r-al i-a r-b r-be i-c job)))
+
+(defmethod gemm! ((alpha complex) (a complex-matrix) (b real-matrix)
+ (beta cl:real) (c complex-matrix)
+ &optional (job :nn))
+ (let ((r-a (realpart! a))
+ (i-a (imagpart! a))
+ (r-c (realpart! c))
+ (i-c (imagpart! c))
+ (r-al (coerce (realpart alpha) 'double-float))
+ (i-al (coerce (imagpart alpha) 'double-float))
+ (r-be (coerce beta 'double-float)))
+ (declare (type real-matrix r-a i-a r-c i-c)
+ (type double-float r-al r-be))
+ ;;
+ (real-double-gemm!-typed r-al r-a b r-be r-c job)
+ (real-double-gemm!-typed (- i-al) i-a b 1d0 r-c job)
+ ;;
+ (real-double-gemm!-typed r-al i-a b r-be i-c job)
+ (real-double-gemm!-typed i-al r-a b 1d0 i-c job)))
;;;;
(defgeneric gemm (alpha a b beta c &optional job)
@@ -303,27 +376,14 @@
(= m-b m-c)))
(error "dimensions of A,B,C given to GEMM! do not match"))))
-;;
-(defmethod gemm ((alpha cl:real) (a real-matrix) (b real-matrix)
- (beta cl:real) (c real-matrix)
- &optional (job :nn))
-
- (gemm! (coerce alpha 'real-matrix-element-type) a b
- (coerce beta 'real-matrix-element-type) (copy c)
- job))
-
-
;; if all args are not real then at least one of them
;; is complex, so we need to call GEMM! with a complex C
(defmethod gemm ((alpha number) (a standard-matrix) (b standard-matrix)
(beta number) (c standard-matrix)
&optional (job :nn))
-
- (let ((c (typecase c
- (real-matrix (copy! c (make-complex-matrix-dim (nrows c) (ncols c))))
- (complex-matrix (copy c))
- (t (error "argument C given to GEMM is not a REAL-MATRIX or COMPLEX-MATRIX")))))
-
- (gemm! (complex-coerce alpha) a b
- (complex-coerce beta) c
- job)))
\ No newline at end of file
+ (let ((result (scal (if (or (typep alpha 'complex) (typep a 'complex-matrix)
+ (typep b 'complex-matrix) (typep beta 'complex))
+ (complex-coerce beta)
+ beta)
+ c)))
+ (gemm! alpha a b 1d0 c job)))
\ No newline at end of file
diff --git a/src/gemv.lisp b/src/gemv.lisp
index c58f746..4ec41be 100644
--- a/src/gemv.lisp
+++ b/src/gemv.lisp
@@ -10,14 +10,13 @@
(declare (type ,element-type alpha beta)
(type ,matrix-type A x y)
(type symbol job))
- (mlet* ((fort-op (ecase job (:n "N") (:t "T")) :type ((string 1)))
- ((st-a hd-a nr-a nc-a rs-a cs-a) (slot-values A '(store head number-of-rows number-of-cols row-stride col-stride))
+ (mlet* (((st-a hd-a nr-a nc-a rs-a cs-a) (slot-values A '(store head number-of-rows number-of-cols row-stride col-stride))
:type ((,store-type *) fixnum fixnum fixnum fixnum fixnum))
((st-x hd-x rs-x) (slot-values x '(store head row-stride))
:type ((,store-type *) fixnum fixnum))
((st-y hd-y rs-y) (slot-values y '(store head row-stride))
:type ((,store-type *) fixnum fixnum))
- ((sym lda tf-op) (blas-matrix-compatible-p A fort-op) :type (symbol fixnum (string 1))))
+ ((sym lda tf-op) (blas-matrix-compatible-p A job) :type (symbol fixnum (string 1))))
(if (not (string= tf-op "?"))
(progn
(when (eq sym :row-major)
@@ -25,7 +24,7 @@
(rotatef rs-a cs-a))
(,blas-gemv-func tf-op nr-a nc-a alpha st-a lda st-x rs-x beta st-y rs-y :head-a hd-a :head-x hd-x :head-y hd-y))
(progn
- (when (string= fort-op "T")
+ (when (eq job :t)
(rotatef nr-a nc-a)
(rotatef rs-a cs-a))
;;Use the smaller of the loops.
@@ -231,4 +230,39 @@
;;
(real-double-gemv!-typed i-al r-A x r-be i-y job)
(real-double-gemv!-typed r-al i-A x 1d0 i-y job))
- y)
\ No newline at end of file
+ y)
+
+;;;;
+(defgeneric gemv (alpha A x beta y &optional job)
+ (:documentation
+"
+ Syntax
+ ======
+ (GEMV alpha A x beta y [job])
+
+ Purpose
+ =======
+ Returns the GEneral Matrix Vector operation given by
+
+ alpha * op(A) * x + beta * y
+
+ alpha,beta are scalars,
+ A is a matrix, and x,y are vectors.
+
+ op(A) means either A or A'.
+
+ JOB Operation
+ ---------------------------------------------------
+ :N (default) alpha * A * x + beta * y
+ :T alpha * A'* x + beta * y
+"))
+
+(defmethod gemv ((alpha number) (A standard-matrix) (x standard-matrix)
+ (beta number) (y standard-matrix) &optional (job :n))
+ (let ((result (scal (if (or (typep alpha 'complex) (typep beta 'complex)
+ (typep A 'complex-matrix) (typep x 'complex-matrix))
+ (complex-coerce beta)
+ beta)
+ y)))
+ (declare (type standard-matrix y))
+ (gemv! alpha A x 1d0 result job)))
\ No newline at end of file
diff --git a/src/real-matrix.lisp b/src/real-matrix.lisp
index 87b6684..7cb08a7 100644
--- a/src/real-matrix.lisp
+++ b/src/real-matrix.lisp
@@ -36,11 +36,10 @@
(declare (type (real-matrix-store-type *) store))
(aref store idx)))
-
(defmethod (setf matrix-ref-1d) ((value cl:real) (matrix real-matrix) (idx fixnum))
(let ((store (store matrix)))
(declare (type (real-matrix-store-type *) store))
- (setf (aref store idx) value)))
+ (setf (aref store idx) (coerce value 'double-float))))
;;
(declaim (inline allocate-real-store))
diff --git a/src/standard-matrix.lisp b/src/standard-matrix.lisp
index 089ef9b..e223d37 100644
--- a/src/standard-matrix.lisp
+++ b/src/standard-matrix.lisp
@@ -377,17 +377,28 @@ Cannot create a sub-matrix of size (~a ~a) starting at (~a ~a)" nrows ncols i j)
(t (values nil -1 -1)))))
;;
-(defun blas-matrix-compatible-p (matrix &optional (fortran-op "N"))
+(defun blas-matrix-compatible-p (matrix &optional (op :n))
(declare (optimize (safety 0) (speed 3))
(type (or real-matrix complex-matrix) matrix))
(mlet* (((rs cs) (slot-values matrix '(row-stride col-stride))
:type (fixnum fixnum)))
(cond
- ((= cs 1) (values :row-major rs (cond
- ((string= fortran-op "N" ) "T")
- ((string= fortran-op "T" ) "N"))))
- ((= rs 1) (values :col-major cs (cond
- ((string= fortran-op "N" ) "N")
- ((string= fortran-op "N" ) "T"))))
+ ((= cs 1) (values :row-major rs (fortran-nop op)))
+ ((= rs 1) (values :col-major cs (fortran-op op)))
;;Lets not confound lisp's type declaration.
- (t (values nil -1 "?")))))
\ No newline at end of file
+ (t (values nil -1 "?")))))
+;;
+(declaim (inline fortran-op))
+(defun fortran-op (op)
+ (ecase op (:n "N") (:t "T")))
+
+(declaim (inline fortran-nop))
+(defun fortran-nop (op)
+ (ecase op (:t "N") (:n "T")))
+
+(declaim (inline (fortran-string-nop)))
+(defun fortran-string-nop (sop)
+ (cond
+ ((string= sop "N") "T")
+ ((string= sop "T") "N")
+ (t (error "Unrecognised fortran-op."))))
\ No newline at end of file
diff --git a/src/utilities.lisp b/src/utilities.lisp
index 6cbf2bc..7445d33 100644
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -39,12 +39,14 @@
`(,(append (cond
;;If there is only one element use let
;;instead of multiple-value-bind
- ((or (symbolp vars) (null (cdr vars)))
- `(let ((,(car (ensure-list vars)) ,form))))
+ ((or (symbolp vars))
+ `(let ((,vars ,form))))
;;
(t
`(multiple-value-bind (,@vars) ,form)))
- (mlet-decl (ensure-list vars) (ensure-list type) declare)
+ (if (symbolp vars)
+ (mlet-decl (list vars) (list type) declare)
+ (mlet-decl vars type declare))
nest-code))))
;;
(mlet-walk (elst body)
-----------------------------------------------------------------------
Summary of changes:
matlisp.asd | 8 +-
packages.lisp | 2 +
src/axpy.lisp | 6 +-
src/foreign-real-matrix.lisp | 18 ++-
src/gemm.lisp | 254 ++++++++++++++++++++++++++----------------
src/gemv.lisp | 44 +++++++-
src/real-matrix.lisp | 3 +-
src/standard-matrix.lisp | 26 +++--
src/utilities.lisp | 8 +-
9 files changed, 243 insertions(+), 126 deletions(-)
hooks/post-receive
--
matlisp
|
