Menu
▾
▴
matlisp-commit — Commit log
You can subscribe to this list here.
| 2012 |
Jan
|
Feb
|
Mar
(34) |
Apr
(4) |
May
(2) |
Jun
(11) |
Jul
(22) |
Aug
(9) |
Sep
|
Oct
|
Nov
|
Dec
(4) |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 2013 |
Jan
(15) |
Feb
(17) |
Mar
(3) |
Apr
|
May
|
Jun
(3) |
Jul
(1) |
Aug
(5) |
Sep
(5) |
Oct
(2) |
Nov
(1) |
Dec
(1) |
| 2014 |
Jan
|
Feb
(1) |
Mar
(1) |
Apr
|
May
(1) |
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
| 2016 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
(1) |
Sep
|
Oct
|
Nov
|
Dec
|
|
From: Akshay S. <ak...@us...> - 2012-06-25 10:21:32
|
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, tensor has been updated
via 0f1b57f2c90f00aac4aa5ea6e7240ae69690409f (commit)
from 8bb55ab5b53aa70785619511fcd6457b3bb79401 (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 0f1b57f2c90f00aac4aa5ea6e7240ae69690409f
Author: Akshay Srinivasan <aks...@gm...>
Date: Mon Jun 25 15:46:15 2012 +0530
Added mod-loop for doing multi-index loops seemlessly. Must add more checks.
Added tensor-copy; can run things at about 3x BLAS (dcopy) speed (!) :)
diff --git a/AUTHORS b/AUTHORS
index c400f4e..2617a30 100644
--- a/AUTHORS
+++ b/AUTHORS
@@ -4,5 +4,5 @@ based on an initial prototype by Raymond Toy.
It is now being refactored by Akshay Srinivasan.
Some of code was originally written by Nicholas Neuss for
-Femlisp (www.femlisp.org); it has used here (with modification)
-with the author's consent.
+Femlisp (www.femlisp.org); it has been used here
+(with modification or otherwise) with the author's consent.
diff --git a/src/complex-tensor.lisp b/src/complex-tensor.lisp
index b7abc41..9ae6fbe 100644
--- a/src/complex-tensor.lisp
+++ b/src/complex-tensor.lisp
@@ -72,6 +72,10 @@ Cannot hold complex numbers."))
(setf (gethash 'complex-sub-tensor *tensor-class-optimizations*) 'complex-tensor)
+(defmethod (setf tensor-ref) ((value number) (tensor complex-tensor) subscripts)
+ (let ((sto-idx (store-indexing subscripts tensor)))
+ (setf (tensor-store-ref tensor sto-idx) (coerce-complex value))))
+
;;
(defmethod print-element ((tensor complex-tensor)
element stream)
diff --git a/src/real-tensor.lisp b/src/real-tensor.lisp
index 9408e85..b47f5be 100644
--- a/src/real-tensor.lisp
+++ b/src/real-tensor.lisp
@@ -53,6 +53,10 @@ Allocates real storage. Default initial-element = 0d0.")
(setf (gethash 'real-sub-tensor *tensor-class-optimizations*) 'real-tensor)
+(defmethod (setf tensor-ref) ((value number) (tensor real-tensor) subscripts)
+ (let ((sto-idx (store-indexing subscripts tensor)))
+ (setf (tensor-store-ref tensor sto-idx) (coerce-real value))))
+
;;
(defmethod print-element ((tensor real-tensor)
element stream)
diff --git a/src/standard-matrix.lisp b/src/standard-matrix.lisp
index 6357c1c..192a23a 100644
--- a/src/standard-matrix.lisp
+++ b/src/standard-matrix.lisp
@@ -122,7 +122,7 @@ matrix and a number"))
;;
(gethash 'complex-matrix *tensor-class-optimizations*) 'complex-tensor
(gethash 'complex-sub-matrix *tensor-class-optimizations*) 'complex-tensor)
-
+
;;
(definline matrix-ref (matrix row &optional col)
diff --git a/src/standard-tensor.lisp b/src/standard-tensor.lisp
index bbbb419..3ef4919 100644
--- a/src/standard-tensor.lisp
+++ b/src/standard-tensor.lisp
@@ -96,23 +96,23 @@
;;
(defparameter *sub-tensor-counterclass* (make-hash-table)
"
-Contains the sub-tensor CLOS counterpart classes of every
-tensor class. This is used by sub-tensor~ and other in-place
-slicing functions to construct new objects.")
+ Contains the sub-tensor CLOS counterpart classes of every
+ tensor class. This is used by sub-tensor~ and other in-place
+ slicing functions to construct new objects.")
(setf (gethash 'standard-tensor *sub-tensor-counterclass*) 'standard-sub-tensor)
;;
(defparameter *tensor-class-optimizations* (make-hash-table)
"
-Contains a either:
-o A property list containing:
-:element-type
-:store-type
-:reader (store idx) => result
-:value-writer (value store idx) => (store idx) <- value
-:reader-writer (fstore fidx tstore tidx) => (tstore tidx) <- (fstore fidx)
-o class-name (symbol) of the superclass whose optimizations
+ Contains a either:
+ o A property list containing:
+ :element-type
+ :store-type
+ :reader (store idx) => result
+ :value-writer (value store idx) => (store idx) <- value
+ :reader-writer (fstore fidx tstore tidx) => (tstore tidx) <- (fstore fidx)
+ o class-name (symbol) of the superclass whose optimizations
are to be made use of.")
(defun get-tensor-class-optimization (clname)
@@ -127,8 +127,9 @@ o class-name (symbol) of the superclass whose optimizations
;; 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 allows us to determine a load time value for
+ tensor, for example #.(make-tensors ...)"
(make-load-form-saving-slots tensor :environment env))
;;
diff --git a/src/tensor-copy.lisp b/src/tensor-copy.lisp
index c52907a..3400bc3 100644
--- a/src/tensor-copy.lisp
+++ b/src/tensor-copy.lisp
@@ -23,89 +23,123 @@ is used, else the fortran routine is called instead.
unless (= off accumulated-off) do (return nil)
finally (return t))))
-;;
-
-(defmacro mod-tensor-loop ((idx dims) &body body)
+(defmacro mod-loop ((idx dims) &body body)
(check-type idx symbol)
(let ((tensor-table (make-hash-table)))
- (labels ((get-tensors (decl ret)
- (if (null decl)
- ret
+ (labels ((get-tensors (decl)
+ (if (null decl) t
(let ((cdecl (car decl)))
- (if (and (eq (first cdecl) 'type)
- (gethash (second cdecl) *sub-tensor-counterclass*))
- (dolist sym
- (get-tensors (cdr decl) (append ret (cddr cdecl)))
- (get-tensors (cdr decl) ret)))))
+ (when (and (eq (first cdecl) 'type)
+ (get-tensor-class-optimization (second cdecl)))
+ (dolist (sym (cddr cdecl))
+ (let ((hsh (list
+ :class (second cdecl)
+ :stride-sym (gensym (string+ (symbol-name sym) "-stride"))
+ :store-sym (gensym (string+ (symbol-name sym) "-store"))
+ :offset-sym (gensym (string+ (symbol-name sym) "-offset")))))
+ (setf (gethash sym tensor-table) hsh))))
+ (get-tensors (cdr decl)))))
+ (ttrans-p (code)
+ (and (eq (first code) 'tensor-ref)
+ (gethash (second code) tensor-table)
+ (eq (third code) idx)))
+ (transform-setf-tensor-ref (snippet ret)
+ (if (null snippet) ret
+ (transform-setf-tensor-ref
+ (cddr snippet)
+ (append ret
+ (destructuring-bind (to from &rest rest) snippet
+ (declare (ignore rest))
+ (let ((to-t? (ttrans-p to))
+ (fr-t? (ttrans-p from)))
+ (cond
+ ((and to-t? fr-t?)
+ (let ((to-opt (gethash (second to) tensor-table))
+ (fr-opt (gethash (second from) tensor-table)))
+ ;;Add type checking here!
+ (cdr (funcall (getf (get-tensor-class-optimization (getf to-opt :class)) :reader-writer)
+ (getf fr-opt :store-sym) (getf fr-opt :offset-sym) (getf to-opt :store-sym) (getf to-opt :offset-sym)))))
+ (to-t?
+ (let ((to-opt (gethash (second to) tensor-table)))
+ ;;Add type checking here!
+ (cdr (funcall (getf (get-tensor-class-optimization (getf to-opt :class)) :value-writer)
+ from (getf to-opt :store-sym) (getf to-opt :offset-sym)))))
+ (fr-t?
+ (let ((fr-opt (gethash (second from) tensor-table)))
+ (cons to (funcall (getf (get-tensor-class-optimization (getf fr-opt :class)) :reader)
+ (getf fr-opt :store-sym) (getf fr-opt :offset-sym)))))
+ (t
+ (list to from)))))))))
(transform-tensor-ref (snippet)
- (let ((ten (second snippet))
- (index (third snippet)))
- (if (not (eq index idx)) snippet
- (destructuring-bind (tstride tstore toff)
- (if-ret (gethash ten tensor-table)
- (setf (gethash ten tensor-table)
- (mapcar #'(lambda (x)
- (gensym (string+ (symbol-name ten) (symbol-name x))))
- '(stride store off))))
- (let ((let-before-code `((,tstride (strides ,ten))
- (,tstore (store ,ten))))
- (loop-code `(with ,toff of-type index-type = (head ,ten)))
- (decl-code `(type
-
-
-
- (find-tensor-refs (code ret ten)
- (let ((ccode (car code)))
- (cond
- ((consp ccode)
- (find-tensor-refs (car ccode) ...))
- ((eq ccode 'tensor-ref)
- (transform-tensor-ref code)))
-
- (with-gensyms (dims-sym rank-sym)
- `(let* ((,dims-sym ,dims)
- (,rank-sym (length ,dims-sym))
- (,idx (allocate-index-store ,rank-sym)))
- (declare (type (index-array *) ,idx))
- (loop
- do (progn
- ,@body)
- while (dotimes (i ,rank-sym nil)
- (declare (type index-type i))
- (if (= (aref ,idx i) (1- (aref ,dims-sym i)))
- (progn
- (setf (aref ,idx i) 0))
- (progn
- (incf (aref ,idx i))
- (return t))))))))
+ (if (eq (first snippet) 'setf)
+ (cons 'setf (transform-setf-tensor-ref (cdr snippet) nil))
+ (destructuring-bind (tref ten index) snippet
+ (assert (eq tref 'tensor-ref))
+ (let ((topt (gethash ten tensor-table)))
+ (if (not (and (eq index idx) topt)) snippet
+ (funcall (getf (get-tensor-class-optimization (getf topt :class)) :reader) (getf topt :store-sym) (getf topt :offset-sym)))))))
+ (find-tensor-refs (code ret)
+ (if (null code) (reverse ret)
+ (cond
+ ((consp code)
+ (if (member (first code) '(tensor-ref setf))
+ (transform-tensor-ref code)
+ (find-tensor-refs (cdr code) (cons (find-tensor-refs (car code) nil) ret))))
+ (t code)))))
+ (when (eq (caar body) 'declare)
+ (get-tensors (cdar body)))
+ (with-gensyms (dims-sym rank-sym count-sym)
+ `(let* ((,dims-sym ,dims)
+ (,rank-sym (length ,dims-sym))
+ (,idx (allocate-index-store ,rank-sym))
+ ,@(loop for key being the hash-keys of tensor-table
+ collect (let ((hsh (gethash key tensor-table)))
+ `(,(getf hsh :stride-sym) (strides ,key))))
+ ,@(loop for key being the hash-keys of tensor-table
+ collect (let ((hsh (gethash key tensor-table)))
+ `(,(getf hsh :store-sym) (store ,key)))))
+ (declare (type (index-array *) ,idx ,@(loop for key being the hash-keys of tensor-table
+ collect (getf (gethash key tensor-table) :stride-sym)))
+ ,@(loop for key being the hash-keys of tensor-table
+ collect (let* ((hsh (gethash key tensor-table))
+ (opt (get-tensor-class-optimization (getf hsh :class))))
+ `(type ,(linear-array-type (getf opt :store-type)) ,(getf hsh :store-sym)))))
+ (loop
+ ,@(loop for key being the hash-keys of tensor-table
+ append (let ((hsh (gethash key tensor-table)))
+ `(with ,(getf hsh :offset-sym) of-type index-type = (head ,key))))
+ do (locally
+ ,@(find-tensor-refs body nil))
+ while (dotimes (,count-sym ,rank-sym nil)
+ (declare (type index-type ,count-sym))
+ (if (= (aref ,idx ,count-sym) (1- (aref ,dims-sym ,count-sym)))
+ (progn
+ (setf (aref ,idx ,count-sym) 0)
+ ,@(loop for key being the hash-keys of tensor-table
+ collect (let ((hsh (gethash key tensor-table)))
+ `(decf ,(getf hsh :offset-sym) (* (aref ,(getf hsh :stride-sym) ,count-sym) (1- (aref ,dims-sym ,count-sym)))))))
+ (progn
+ (incf (aref ,idx ,count-sym))
+ ,@(loop for key being the hash-keys of tensor-table
+ collect (let ((hsh (gethash key tensor-table)))
+ `(incf ,(getf hsh :offset-sym) (aref ,(getf hsh :stride-sym) ,count-sym))))
+ (return t))))))))))
(defun tensor-copy (from to)
(declare (optimize (speed 3) (safety 0))
(type real-tensor to from))
- (let* ((rank (rank to))
- (dims (dimensions to))
- (t-strides (strides to))
- (f-strides (strides from))
- (t-store (store to))
- (f-store (store from))
- (idx (allocate-index-store rank)))
- (declare (type (index-array *) dims t-strides f-strides idx))
- (declare (type (real-array *) t-store f-store))
- (loop
- with of-t of-type index-type = (head to)
- with of-f of-type index-type = (head from)
- do (setf (aref t-store of-t) (aref f-store of-f))
- while (dotimes (i rank nil)
- (if (= (aref idx i) (1- (aref dims i)))
- (progn
- (setf (aref idx i) 0)
- (decf of-t (* (aref t-strides i) (1- (aref dims i))))
- (decf of-f (* (aref f-strides i) (1- (aref dims i)))))
- (progn
- (incf (aref idx i))
- (incf of-t (aref t-strides i))
- (incf of-f (aref f-strides i))
- (return t)))))))
+ (let ((dims (dimensions from)))
+ (mod-loop (idx dims)
+ (declare (type real-tensor to from))
+ (setf (tensor-ref to idx) (tensor-ref from idx)))))
+
+
+(let ((x (make-real-tensor-dims 100 100 100))
+ (y (make-real-tensor-dims 100 100 100)))
+ (mod-loop (idx #(100 100 100))
+ (declare (type real-tensor x y))
+ (setf (tensor-ref x idx) (random 1d0)))
+ (time (tensor-copy x y)))
(defmacro generate-typed-copy!-func (func store-type matrix-type blas-func)
;;Be very careful when using functions generated by this macro.
diff --git a/src/utilities.lisp b/src/utilities.lisp
index 794e30b..a475531 100644
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -2,28 +2,28 @@
(defmacro mlet* (decls &rest body)
"
-mlet* ({ {(var*) | var} values-form &keyform declare type}*) form*
+ mlet* ({ {(var*) | var} values-form &keyform declare type}*) form*
-o var is just one symbol -> expands into let
-o var is a list -> expands into multiple-value-bind
+ o var is just one symbol -> expands into let
+ o var is a list -> expands into multiple-value-bind
-This macro also handles type declarations.
+ This macro also handles type declarations.
-Example:
-> (mlet* ((x 2 :type fixnum :declare ((optimize (safety 0) (speed 3))))
- ((a b) (floor 3) :type (nil fixnum)))
- (+ x b))
+ Example:
+ > (mlet* ((x 2 :type fixnum :declare ((optimize (safety 0) (speed 3))))
+ ((a b) (floor 3) :type (nil fixnum)))
+ (+ x b))
-expands into:
+ expands into:
-> (let ((x 2))
- (declare (optimize (safety 0) (speed 3))
- (type fixnum x))
- (multiple-value-bind (a b)
- (floor 3)
- (declare (ignore a)
- (type fixnum b))
- (+ x b)))
+ > (let ((x 2))
+ (declare (optimize (safety 0) (speed 3))
+ (type fixnum x))
+ (multiple-value-bind (a b)
+ (floor 3)
+ (declare (ignore a)
+ (type fixnum b))
+ (+ x b)))
"
(labels ((mlet-decl (vars type decls)
(when (or type decls)
@@ -57,13 +57,13 @@ expands into:
(defmacro let-rec (name arglist &rest code)
"
-(let-rec name ({var [init-form]}*) declaration* form*) => result*
-Works similar to \"let\" in Scheme.
+ (let-rec name ({var [init-form]}*) declaration* form*) => result*
+ Works similar to \"let\" in Scheme.
-Example:
-> (let-rec rev ((x '(1 2 3 4)) (ret nil))
- (if (null x) ret
- (rev (cdr x) (cons (car x) ret))))
+ Example:
+ > (let-rec rev ((x '(1 2 3 4)) (ret nil))
+ (if (null x) ret
+ (rev (cdr x) (cons (car x) ret))))
"
(let ((init (mapcar #'second arglist))
(args (mapcar #'first arglist)))
@@ -73,8 +73,8 @@ Example:
(defmacro with-gensyms (symlist &body body)
"
-(with-gensyms (var *) form*)
-Binds every variable in SYMLIST to a gensym."
+ (with-gensyms (var *) form*)
+ Binds every variable in SYMLIST to a gensym."
`(let ,(mapcar #'(lambda (sym)
`(,sym (gensym ,(symbol-name sym))))
symlist)
@@ -120,9 +120,9 @@ Binds every variable in SYMLIST to a gensym."
(defmacro if-ret (form &rest else-body)
"
-if-ret (form &rest else-body)
-Evaluate form, and if the form is not nil, then return it,
-else run else-body"
+ if-ret (form &rest else-body)
+ Evaluate form, and if the form is not nil, then return it,
+ else run else-body"
(let ((ret (gensym)))
`(let ((,ret ,form))
(or ,ret
-----------------------------------------------------------------------
Summary of changes:
AUTHORS | 4 +-
src/complex-tensor.lisp | 4 +
src/real-tensor.lisp | 4 +
src/standard-matrix.lisp | 2 +-
src/standard-tensor.lisp | 27 ++++---
src/tensor-copy.lisp | 184 +++++++++++++++++++++++++++-------------------
src/utilities.lisp | 56 +++++++-------
7 files changed, 162 insertions(+), 119 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-06-24 15:41:51
|
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, tensor has been updated
via 8bb55ab5b53aa70785619511fcd6457b3bb79401 (commit)
from 8232b005b14d4aced35d7ce07afe9a9c35233b7e (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 8bb55ab5b53aa70785619511fcd6457b3bb79401
Author: Akshay Srinivasan <aks...@gm...>
Date: Sun Jun 24 21:06:39 2012 +0530
Added infrastructure to make the tensor-aware "compiler" macros
for working with mod-loops.
diff --git a/AUTHORS b/AUTHORS
index 8ca39ab..c400f4e 100644
--- a/AUTHORS
+++ b/AUTHORS
@@ -3,6 +3,6 @@ based on an initial prototype by Raymond Toy.
It is now being refactored by Akshay Srinivasan.
-Some code has been either been directly obtained from,
-or modified from Femlisp (www.femlisp.org), written by
-Nicholas Neuss.
+Some of code was originally written by Nicholas Neuss for
+Femlisp (www.femlisp.org); it has used here (with modification)
+with the author's consent.
diff --git a/matlisp.asd b/matlisp.asd
index 4de9217..1a5eecc 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -91,7 +91,13 @@
(:file "complex-tensor"
:depends-on ("standard-tensor"))
(:file "standard-matrix"
- :depends-on ("standard-tensor"))))))
+ :depends-on ("standard-tensor"))
+ ;; (:file "real-matrix"
+ ;; :depends-on ("standard-matrix"))
+ ;; (:file "complex-matrix"
+ ;; :depends-on ("standard-matrix"))
+ (:file "print"
+ :depends-on ("standard-tensor" "standard-matrix"))))))
;; (defclass f2cl-cl-source-file (asdf:cl-source-file)
diff --git a/packages.lisp b/packages.lisp
index 49d63b1..cbe1052 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -159,11 +159,14 @@
#:zip #:zip-eq
#:cut-cons-chain!
#:slot-values
- #:recursive-append
+ #:recursive-append #:unquote-args #:flatten
+ #:format-to-string #:string+
+ #:linear-array-type
;;Macros
#:when-let #:if-let #:if-ret #:with-gensyms #:let-rec
#:mlet* #:make-array-allocator
#:nconsc #:define-constant
+ #:macrofy
;;
#:inlining #:definline
#:with-optimization #:quickly #:very-quickly #:slowly #:quickly-if
@@ -173,10 +176,13 @@
(defpackage :fortran-ffi-accessors
(:nicknames :ffi)
- #+:cmu (:use :common-lisp :c-call :cffi :utilities)
- #+:sbcl (:use :common-lisp :sb-alien :sb-c :cffi :utilities)
- #+:allegro (:use :common-lisp :cffi :utilities)
- #+(not (or sbcl cmu allegro)) (:use :common-lisp :cffi :utilities)
+ (:use :common-lisp :cffi :utilities)
+ ;; TODO: Check if this is implementation-agnostic.
+ ;; #+:cmu (:use :common-lisp :c-call :cffi :utilities)
+ ;; #+:sbcl (:use :common-lisp :cffi :utilities)
+
+ ;; #+:allegro (:use :common-lisp :cffi :utilities)
+ ;; #+(not (or sbcl cmu allegro)) (:use :common-lisp :cffi :utilities)
(:export
;; interface functions
#:def-fortran-routine
diff --git a/src/complex-tensor.lisp b/src/complex-tensor.lisp
index 530aff9..b7abc41 100644
--- a/src/complex-tensor.lisp
+++ b/src/complex-tensor.lisp
@@ -7,11 +7,11 @@
(deftype complex-base-array (size)
"The type of the storage structure for a COMPLEX-MATRIX"
- `(simple-array real-type (,size)))
+ `(simple-array complex-base-type (,size)))
(deftype complex-type ()
"Complex number with Re, Im parts in complex-base-type."
- '(cl:complex (complex-base-type * *)))
+ '(cl:complex complex-base-type))
)
;;
@@ -25,6 +25,9 @@ Default initial-element = 0d0."
(definline coerce-complex (x)
(coerce x 'complex-type))
+(definline coerce-complex-base (x)
+ (coerce x 'complex-base-type))
+
;;
(defclass complex-tensor (standard-tensor)
((store
@@ -53,13 +56,21 @@ Cannot hold complex numbers."))
(call-next-method))
;;
-(defmethod tensor-store-ref ((tensor complex-tensor) (idx fixnum))
- (complex (aref (store tensor) (* 2 idx))
- (aref (store tensor) (+ (* 2 idx) 1))))
+(tensor-store-defs (complex-tensor complex-type complex-base-type)
+ :reader
+ (lambda (tstore idx)
+ (complex (aref tstore (* 2 idx))
+ (aref tstore (1+ (* 2 idx)))))
+ :value-writer
+ (lambda (value store idx)
+ (setf (aref store (* 2 idx)) (realpart value)
+ (aref store (1+ (* 2 idx))) (imagpart value)))
+ :reader-writer
+ (lambda (fstore fidx tstore tidx)
+ (setf (aref fstore (* 2 fidx)) (aref tstore (* 2 tidx))
+ (aref fstore (1+ (* 2 fidx))) (aref tstore (1+ (* 2 tidx))))))
-(defmethod (setf tensor-store-ref) ((value number) (tensor complex-tensor) (idx fixnum))
- (setf (aref (store tensor) (* 2 idx)) (coerce (realpart value) 'complex-base-type)
- (aref (store tensor) (+ (* 2 idx) 1)) (coerce (imagpart value) 'complex-base-type)))
+(setf (gethash 'complex-sub-tensor *tensor-class-optimizations*) 'complex-tensor)
;;
(defmethod print-element ((tensor complex-tensor)
@@ -77,4 +88,3 @@ Cannot hold complex numbers."))
(ss (reduce #'* dims))
(store (allocate-complex-store ss)))
(make-instance 'complex-tensor :store store :dimensions dims)))
-
diff --git a/src/conditions.lisp b/src/conditions.lisp
index 9b5586b..7935cf3 100644
--- a/src/conditions.lisp
+++ b/src/conditions.lisp
@@ -39,7 +39,9 @@
(defmethod print-object ((c invalid-value) stream)
(format stream "Given object ~A, expected ~A.~%" (given c) (expected c))
(call-next-method))
-
+;;---------------------------------------------------------------;;
+
+
;;---------------------------------------------------------------;;
(define-condition matlisp-error (error)
;;Optional argument for error-handling.
diff --git a/src/ffi-cffi-interpreter-specific.lisp b/src/ffi-cffi-interpreter-specific.lisp
index c80216d..4d51dc0 100644
--- a/src/ffi-cffi-interpreter-specific.lisp
+++ b/src/ffi-cffi-interpreter-specific.lisp
@@ -1,7 +1,9 @@
;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: :fortran-ffi-accessors; Base: 10 -*-
;; Yes the file name is an oxymoron.
-(in-package "FORTRAN-FFI-ACCESSORS")
+(in-package :ffi)
+
+;;TODO: Add support for {Allegro CL, Lispworks, ECL, clisp}
(defmacro with-fortran-float-modes (&body body)
"Execute the body with the IEEE FP modes appropriately set for Fortran"
@@ -40,18 +42,17 @@
#+ccl `(ccl::without-gcing)
body))
-(defmacro vector-sap-interpreter-specific (vec)
- #+sbcl `(sb-sys:vector-sap ,vec)
- #+cmu `(system:vector-sap ,vec)
- #+ccl (let ((addr-vec (gensym)))
- `(let ((,addr-vec (ccl:%null-ptr)))
- (declare (type ccl:macptr ,addr-vec))
- (ccl::%vect-data-to-macptr ,vec ,addr-vec))))
+(definline vector-sap-interpreter-specific (vec)
+ #+sbcl (sb-sys:vector-sap vec)
+ #+cmu (system:vector-sap vec)
+ #+ccl (let ((addr-vec (ccl:%null-ptr)))
+ (declare (type ccl:macptr addr-vec))
+ (ccl::%vect-data-to-macptr vec addr-vec)))
-(defmacro vector-data-address (vec)
-"
-Creates lisp code to return the physical address of where the actual
-data of the object VEC is stored.
+#+(or sbcl cmu ccl)
+(defun vector-data-address (vec)
+ "
+Returns the pointer address of where the actual data store of the object VEC.
VEC - must be a either a (complex double-float), (complex single-float)
or a specialized array type in CMU Lisp. This currently means
@@ -65,45 +66,18 @@ VEC is a simple-array of one dimension of one of the following types:
Returns
1 - system area pointer to the actual data
"
- `(progn
- (with-optimization (:speed 1 :safety 3)
- ;; It's quite important that the arrays have the right type.
- ;; Otherwise, we will probably get the address of the data wrong,
- ;; and then foreign function could be scribbling over who knows
- ;; where!
- (check-type ,vec matlisp-specialized-array))
- (with-optimization (:speed 3 :safety 0 :space 0)
- ;;vec is either a simple-array or a system-area-pointer itself.
- (declare (type matlisp-specialized-array ,vec))
- (if (typep ,vec '(simple-array * (*)))
- (vector-sap-interpreter-specific ,vec)
- vec))))
-
-;; #+(or sbcl cmu ccl)
-;; (progn
-;; (declaim (inline vector-data-address))
-
-;; (defun vector-data-address (vec)
-
-;; (locally
-;; (declare (optimize (speed 1) (safety 3)))
-;; ;; It's quite important that the arrays have the write type.
-;; ;; Otherwise, we will probably get the address of the data wrong,
-;; ;; and then foreign function could be scribbling over who knows
-;; ;; where!
-;; ;;
-;; (check-type vec matlisp-specialized-array))
-;; (locally
-;; (declare (type matlisp-specialized-array vec)
-;; (optimize (speed 3) (safety 0) (space 0)))
-;; ;;vec is either a simple-array or a system-area-pointer itself.
-;; (if (typep vec '(simple-array * (*)))
-;; #+sbcl (sb-sys:vector-sap vec)
-;; #+cmu (system:vector-sap vec)
-;; #+ccl (let ((addr-vec (ccl:%null-ptr)))
-;; (declare (type ccl:macptr addr-vec))
-;; (ccl::%vect-data-to-macptr vec addr-vec))
-;; vec))))
+ (with-optimization (:speed 1 :safety 3)
+ ;; It's quite important that the arrays have the right type.
+ ;; Otherwise, we will probably get the address of the data wrong,
+ ;; and then foreign function could be scribbling over who knows
+ ;; where!
+ (check-type vec matlisp-specialized-array))
+ (with-optimization (:speed 3 :safety 0 :space 0)
+ ;;vec is either a simple-array or a system-area-pointer itself.
+ (declare (type matlisp-specialized-array vec))
+ (if (typep vec '(simple-array * (*)))
+ (vector-sap-interpreter-specific vec)
+ vec)))
#+(or sbcl cmu ccl)
(defmacro with-vector-data-addresses (vlist &body body)
diff --git a/src/ffi-cffi.lisp b/src/ffi-cffi.lisp
index 3311dc6..deabaaa 100644
--- a/src/ffi-cffi.lisp
+++ b/src/ffi-cffi.lisp
@@ -413,16 +413,15 @@
,@pars))
(setq hack-return-type :void)))
- `(eval-when (load eval compile)
- (progn
- ;; Removing 'inlines' It seems that CMUCL has a problem with
- ;; inlines of FFI's when a lisp image is saved. Until the
- ;; matter is clarified we leave out 'inline's
-
- ;; (declaim (inline ,lisp-name)) ;sbcl 0.8.5 has problems with
- (cffi:defcfun (,fortran-name ,lisp-name) ,@(get-return-type hack-return-type)
- ,@(parse-fortran-parameters hack-body))
- ,@(def-fortran-interface name hack-return-type hack-body hidden-var-name))))))
+ `(progn
+ ;; Removing 'inlines' It seems that CMUCL has a problem with
+ ;; inlines of FFI's when a lisp image is saved. Until the
+ ;; matter is clarified we leave out 'inline's
+
+ ;; (declaim (inline ,lisp-name)) ;sbcl 0.8.5 has problems with
+ (cffi:defcfun (,fortran-name ,lisp-name) ,@(get-return-type hack-return-type)
+ ,@(parse-fortran-parameters hack-body))
+ ,@(def-fortran-interface name hack-return-type hack-body hidden-var-name)))))
;; Create a form specifying a simple Lisp function that calls the
;; underlying Fortran routine of the same name.
diff --git a/src/print.lisp b/src/print.lisp
index 06d2d4d..816b2f1 100644
--- a/src/print.lisp
+++ b/src/print.lisp
@@ -81,148 +81,84 @@
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Routines for printing a matrix nicely.
+;;; Routines for printing a tensors/matrices nicely.
-(in-package "MATLISP")
+(in-package :matlisp)
-(defvar *print-max-len*
- 5
- "Maximum number of elements in any particular argument to print.
- Set this to NIL to print no elements. Set this to T
- to print all elements.")
+(defparameter *print-max-len* 5
+"
+Maximum number of elements in any particular argument to print.
+Set this to T to print all the elements.
+")
-(defvar *print-max-args* 5
- "Maximum number of arguments of the tensor to print.
- Set this to NIL to print none; to T to print all of them.")
+(defparameter *print-max-args* 5
+"
+Maximum number of arguments of the tensor to print.
+Set this to T to print all the arguments.
+")
-(defun set-print-limits-for-matrix (n m)
- (declare (type fixnum n m))
- (if (eq *print-matrix* t)
- (values n m)
- (if (eq *print-matrix* nil)
- (values 0 0)
- (if (and (integerp *print-matrix*)
- (> *print-matrix* 0))
- (values (min n *print-matrix*)
- (min m *print-matrix*))
- (error "Cannot set the print limits for matrix.
-Required that *PRINT-MATRIX* be T,NIL or a positive INTEGER,
-but got *PRINT-MATRIX* of type ~a"
- (type-of *print-matrix*))))))
-
-(defvar *print-indent* 0
- "Determines how many spaces will be printed before each row
- of a matrix (default 0)")
+(defparameter *print-indent* 0
+"
+Determines how many spaces will be printed before each row
+of a matrix (default 0)
+")
(defun print-tensor (tensor stream)
(let ((rank (rank tensor))
- (dims (dimensions tensor)))
+ (dims (dimensions tensor))
+ (two-print-calls 0))
(labels ((two-print (tensor subs)
- (dotimes (i (aref dims 0))
- (dotimes (j (aref dims 1))
- (format stream "~A~,4T" (apply #'tensor-ref (list tensor (append (list i j) subs)))))
- (format stream "~%")))
- (rec-print (tensor idx subs)
- (if (> idx 1)
- (dotimes (i (aref dims idx))
- (rec-print tensor (1- idx) (cons i subs)))
+ (dotimes (i (aref dims (- rank 2)))
+ (format stream (format-to-string "~~~AT" *print-indent*))
+ (if (or (eq *print-max-len* t) (< i *print-max-len*))
+ (progn
+ (dotimes (j (aref dims (- rank 1)))
+ (if (or (eq *print-max-len* t) (< j *print-max-len*))
+ (progn
+ (print-element tensor (tensor-ref tensor (append subs `(,i ,j))) stream)
+ (format stream "~,4T"))
+ (progn
+ (format stream "...")
+ (return nil))))
+ (format stream "~%"))
(progn
- (format stream "~A~%" (append (list '\: '\:) subs))
- (two-print tensor subs)
- (format stream "~%")))))
- (format stream "~A ~A~%" rank dims)
+ (format stream (format-to-string ".~~%~~~AT:~~%" *print-indent*))
+ (return nil)))))
+ (rec-print (tensor idx subs)
+ (if (< idx (- rank 2))
+ (dotimes (i (aref dims idx) t)
+ (unless (rec-print tensor (1+ idx) (append subs `(,i)))
+ (return nil)))
+ (progn
+ (if (or (eq *print-max-args* t) (< two-print-calls *print-max-args*))
+ (progn
+ (format stream "~A~%" (append subs '(\: \:)))
+ (two-print tensor subs)
+ (format stream "~%")
+ (incf two-print-calls)
+ t)
+ (progn
+ (format stream "~A~%" (make-list rank :initial-element '\:))
+ (format stream (format-to-string "~~~AT..~~%~~~AT::~~%" *print-indent* *print-indent*))
+ nil))))))
+
(case rank
(1
(dotimes (i (aref dims 0))
- (format stream "~A~,4T" (tensor-ref tensor `(,i))))
+ (print-element tensor (tensor-ref tensor `(,i)) stream)
+ (format stream "~,4T"))
(format stream "~%"))
(2
(two-print tensor nil))
(t
- (rec-print tensor (- rank 1) nil))))))
-
-(defun print-matrix (matrix stream)
- (with-slots (number-of-rows number-of-cols)
- matrix
- (multiple-value-bind (max-n max-m)
- (set-print-limits-for-matrix number-of-rows number-of-cols)
- (declare (type fixnum max-n max-m))
- (format stream " ~d x ~d" number-of-rows number-of-cols)
-
- ;; Early exit if the total number of elements is zero.
- (when (zerop (number-of-elements matrix))
- (return-from print-matrix))
- (decf max-n)
- (decf max-m)
- (flet ((print-row (i)
- (when (minusp i)
- (return-from print-row))
- (format stream "~% ")
-
- (dotimes (k *matrix-indent*)
- (format stream " "))
- (dotimes (j max-m)
- (declare (type fixnum j))
- (print-element matrix
- (matrix-ref matrix i j)
- stream)
- (format stream " "))
- (if (< max-m (1- number-of-cols))
- (progn
- (format stream "... ")
- (print-element matrix
- (matrix-ref matrix i (1- number-of-cols))
- stream)
- (format stream " "))
- (if (< max-m number-of-cols)
- (progn
- (print-element matrix
- (matrix-ref matrix i (1- number-of-cols))
- stream)
- (format stream " "))))))
-
- (dotimes (i max-n)
- (declare (type fixnum i))
- (print-row i))
-
- (if (< max-n (1- number-of-rows))
- (progn
- (format stream "~% :")
- (print-row (1- number-of-rows)))
- (if (< max-n number-of-rows)
- (print-row (1- number-of-rows))))))))
-
-
-(defmethod print-object ((matrix standard-matrix) stream)
- (print-unreadable-object (matrix stream :type t :identity (not *print-matrix*))
- (when *print-max*
- (print-matrix matrix stream))))
-
+ (rec-print tensor 0 nil))))))
(defmethod print-object ((tensor standard-tensor) stream)
(print-unreadable-object (tensor stream :type t)
- (let ((rank (rank tensor))
- (dims (dimensions tensor)))
- (labels ((two-print (tensor subs)
- (dotimes (i (aref dims 0))
- (dotimes (j (aref dims 1))
- (format stream "~A~,4T" (apply #'tensor-ref (list tensor (append (list i j) subs)))))
- (format stream "~%")))
- (rec-print (tensor idx subs)
- (if (> idx 1)
- (dotimes (i (aref dims idx))
- (rec-print tensor (1- idx) (cons i subs)))
- (progn
- (format stream "~A~%" (append (list '\: '\:) subs))
- (two-print tensor subs)
- (format stream "~%")))))
- (format stream "~A ~A~%" rank dims)
- (case rank
- (1
- (dotimes (i (aref dims 0))
- (format stream "~A~,4T" (tensor-ref tensor `(,i))))
- (format stream "~%"))
- (2
- (two-print tensor nil))
- (t
- (rec-print tensor (- rank 1) nil)))))))
\ No newline at end of file
+ (format stream "~A~%" (dimensions tensor))
+ (print-tensor tensor stream)))
+
+(defmethod print-object ((tensor standard-matrix) stream)
+ (print-unreadable-object (tensor stream :type t)
+ (format stream "~A x ~A~%" (nrows tensor) (ncols tensor))
+ (print-tensor tensor stream)))
diff --git a/src/real-matrix.lisp b/src/real-matrix.lisp
index ec9199b..38ad1f4 100644
--- a/src/real-matrix.lisp
+++ b/src/real-matrix.lisp
@@ -1,34 +1,3 @@
-;;; Definitions of REAL-MATRIX.
-
-(in-package :matlisp)
-
-(eval-when (load eval compile)
- (deftype real-matrix-element-type ()
- "The type of the elements stored in a REAL-MATRIX"
- 'double-float)
-
- (deftype real-matrix-store-type (size)
- "The type of the storage structure for a REAL-MATRIX"
- `(simple-array double-float (,size)))
- )
-;;
-(defclass real-matrix (standard-matrix)
- ((store
- :initform nil
- :type (real-matrix-store-type *)))
- (:documentation "A class of matrices with real elements."))
-
-(defclass sub-real-matrix (real-matrix)
- ((parent-matrix
- :initarg :parent
- :accessor parent
- :type real-matrix))
- (:documentation "A class of matrices with real elements."))
-
-;;
-(defmethod initialize-instance ((matrix real-matrix) &rest initargs)
- (setf (store-size matrix) (length (getf :store initargs)))
- (call-next-method))
;;
(defmethod matrix-ref-1d ((matrix real-matrix) (idx fixnum))
diff --git a/src/real-tensor.lisp b/src/real-tensor.lisp
index ff36e54..9408e85 100644
--- a/src/real-tensor.lisp
+++ b/src/real-tensor.lisp
@@ -40,11 +40,18 @@ Allocates real storage. Default initial-element = 0d0.")
(call-next-method))
;;
-(defmethod tensor-store-ref ((tensor real-tensor) (idx fixnum))
- (aref (store tensor) idx))
+(tensor-store-defs (real-tensor real-type real-type)
+ :reader
+ (lambda (tstore idx)
+ (aref tstore idx))
+ :value-writer
+ (lambda (value store idx)
+ (setf (aref store idx) value))
+ :reader-writer
+ (lambda (fstore fidx tstore tidx)
+ (setf (aref fstore fidx) (aref tstore tidx))))
-(defmethod (setf tensor-store-ref) ((value number) (tensor real-tensor) (idx fixnum))
- (setf (aref (store tensor) idx) (coerce-real value)))
+(setf (gethash 'real-sub-tensor *tensor-class-optimizations*) 'real-tensor)
;;
(defmethod print-element ((tensor real-tensor)
@@ -53,8 +60,12 @@ Allocates real storage. Default initial-element = 0d0.")
;;
-(defun make-real-tensor (&rest subs)
+(defun make-real-tensor-dims (&rest subs)
(let* ((dims (make-index-store subs))
(ss (reduce #'* dims))
(store (allocate-real-store ss)))
(make-instance 'real-tensor :store store :dimensions dims)))
+
+#+nil(defun make-real-tensor-array (arr)
+ (let* ((dims (array-dimensions arr))
+ (ret (apply #'make-real-tensor-dims dims)))))
diff --git a/src/standard-matrix.lisp b/src/standard-matrix.lisp
index ce2afb3..6357c1c 100644
--- a/src/standard-matrix.lisp
+++ b/src/standard-matrix.lisp
@@ -9,37 +9,29 @@
:documentation "For a matrix, rank = 2."))
(:documentation "Basic matrix class."))
-(defun nrows (matrix)
+(definline nrows (matrix)
(declare (type standard-matrix matrix))
- (let ((dims (dimensions matrix)))
- (declare (type (index-array 2) dims))
- (aref dims 0)))
+ (aref (dimensions matrix) 0))
-(defun ncols (matrix)
+(definline ncols (matrix)
(declare (type standard-matrix matrix))
- (let ((dims (dimensions matrix)))
- (declare (type (index-array 2) dims))
- (aref dims 1)))
+ (aref (dimensions matrix) 1))
-(defun row-stride (matrix)
+(definline row-stride (matrix)
(declare (type standard-matrix matrix))
- (let ((stds (strides matrix)))
- (declare (type (index-array 2) stds))
- (aref stds 0)))
+ (aref (strides matrix) 0))
-(defun col-stride (matrix)
+(definline col-stride (matrix)
(declare (type standard-matrix matrix))
- (let ((stds (strides matrix)))
- (declare (type (index-array 2) stds))
- (aref stds 1)))
+ (aref (strides matrix) 1))
-(defun size (matrix)
+(definline size (matrix)
(declare (type standard-matrix matrix))
(let ((dims (dimensions matrix)))
(declare (type (index-array 2) dims))
(list (aref dims 0) (aref dims 1))))
-;;
+;;
(defmethod initialize-instance :after ((matrix standard-matrix) &rest initargs)
(declare (ignore initargs))
(mlet*
@@ -48,43 +40,37 @@
(error 'tensor-not-matrix :rank rank :tensor matrix))))
;;
-(defmacro matrix-ref (matrix row &optional col)
- (if col
- `(matrix-ref-2d ,matrix ,row ,col)
- `(matrix-ref-1d ,matrix ,row)))
-
-;;
-(defun row-vector-p (matrix)
+(definline row-matrix-p (matrix)
"
Syntax
======
- (ROW-VECTOR-P x)
+ (ROW-MATRIX-P x)
Purpose
=======
- Return T if X is a row vector (number of columns is 1)"
- (tensor-type-p '(1 t)))
+ Return T if X is a row matrix (number of columns is 1)"
+ (tensor-type-p matrix '(1 *)))
-(defun col-vector-p (matrix)
+(definline col-matrix-p (matrix)
"
Syntax
======
- (COL-VECTOR-P x)
+ (COL-MATRIX-P x)
Purpose
=======
- Return T if X is a column vector (number of rows is 1)"
- (tensor-type-p '(t 1)))
+ Return T if X is a column matrix (number of rows is 1)"
+ (tensor-type-p matrix '(* 1)))
-(defun row-or-col-vector-p (matrix)
+(definline row-or-col-matrix-p (matrix)
"
Syntax
======
- (ROW-OR-COL-VECTOR-P x)
+ (ROW-OR-COL-matrix-P x)
Purpose
=======
- Return T if X is either a row or a column vector"
+ Return T if X is either a row or a column matrix."
(or (row-vector-p matrix) (col-vector-p matrix)))
(defun square-matrix-p (matrix)
@@ -105,4 +91,41 @@
(defmethod fill-matrix ((matrix t) (fill t))
(error "arguments MATRIX and FILL to FILL-MATRIX must be a
-matrix and a number"))
\ No newline at end of file
+matrix and a number"))
+
+;;
+(defclass real-matrix (standard-matrix real-tensor)
+ ()
+ (:documentation "A class of matrices with real elements."))
+
+(defclass real-sub-matrix (real-matrix standard-sub-tensor)
+ ()
+ (:documentation "Sub-matrix class with real elements."))
+
+(setf (gethash 'real-matrix *sub-tensor-counterclass*) 'real-sub-matrix
+ (gethash 'real-sub-matrix *sub-tensor-counterclass*) 'real-sub-matrix
+ ;;
+ (gethash 'real-matrix *tensor-class-optimizations*) 'real-tensor
+ (gethash 'real-sub-matrix *tensor-class-optimizations*) 'real-tensor)
+;;
+
+(defclass complex-matrix (standard-matrix complex-tensor)
+ ()
+ (:documentation "A class of matrices with complex elements."))
+
+(defclass complex-sub-matrix (complex-matrix standard-sub-tensor)
+ ()
+ (:documentation "Sub-matrix class with complex elements."))
+
+(setf (gethash 'complex-matrix *sub-tensor-counterclass*) 'complex-sub-matrix
+ (gethash 'complex-sub-matrix *sub-tensor-counterclass*) 'complex-sub-matrix
+ ;;
+ (gethash 'complex-matrix *tensor-class-optimizations*) 'complex-tensor
+ (gethash 'complex-sub-matrix *tensor-class-optimizations*) 'complex-tensor)
+
+;;
+
+(definline matrix-ref (matrix row &optional col)
+ (declare (type standard-matrix matrix))
+ (tensor-ref matrix `(,row ,col)))
+
diff --git a/src/standard-tensor.lisp b/src/standard-tensor.lisp
index d431c32..bbbb419 100644
--- a/src/standard-tensor.lisp
+++ b/src/standard-tensor.lisp
@@ -8,8 +8,9 @@
`(simple-array integer4-type (,size)))
;;
- (deftype index-type ()
- '(signed-byte 64))
+ (deftype index-type ()
+ #+cmu '(signed-byte 32)
+ #-cmu '(signed-byte 64))
(deftype index-array (size)
`(simple-array index-type (,size)))
)
@@ -17,120 +18,38 @@
(declaim (inline allocate-integer4-store))
(make-array-allocator allocate-integer4-store 'integer4-type 0
"
-(allocate-int32-store size [initial-element])
-Allocates integer-32 storage. Default initial-element = 0.
-")
+ Syntax
+ ======
+ (ALLOCATE-INT32-STORE SIZE [INITIAL-ELEMENT 0])
+
+ Purpose
+ =======
+ Allocates integer-32 storage.")
(make-array-allocator allocate-index-store 'index-type 0
"
-(allocate-index-store size [initial-element])
-Allocates index storage. Default initial-element = 0.
-")
+ Syntax
+ ======
+ (ALLOCATE-INDEX-STORE SIZE [INITIAL-ELEMENT 0])
+ Purpose
+ =======
+ Allocates index storage.")
(defun make-index-store (contents)
+"
+ Syntax
+ ======
+ (MAKE-INDEX-STORE CONTENTS)
+
+ Purpose
+ =======
+ Allocates index storage with initial elements from the list CONTENTS."
(let ((size (length contents)))
(make-array size :element-type 'index-type
:initial-contents contents)))
;;
-(defun store-indexing-internal (idx hd strides)
-"
-No explicit error checking, meant to be used internally.
-Returns the sum:
-
- length(strides)
- __
-hd + \ stride * idx
- /_ i i
- i = 0
-
-"
- (declare (optimize (safety 0) (speed 3))
- (type index-type hd)
- (type (index-array *) idx strides))
- (let ((rank (length strides)))
- (declare (type index-type rank))
- (the index-type
- (do ((i 0 (+ i 1))
- (sto-idx (the index-type hd) (the index-type
- (+ sto-idx
- (the index-type
- (* (the index-type
- (aref idx i))
- (the index-type
- (aref strides i))))))))
- ((= i rank) sto-idx)
- (declare (type index-type i sto-idx))))))
-
-(defun store-indexing-vec (idx hd strides dims)
-"
-Returns the sum:
-
- length(strides)
- __
-hd + \ stride * idx
- /_ i i
- i = 0
-
-"
- (declare (type index-type hd)
- (type (index-array *) idx strides dims))
- (let ((rank (length strides)))
- (declare (type index-type rank))
- (if (not (= rank (length idx)))
- (error 'tensor-index-rank-mismatch :index-rank (length idx) :rank rank)
- (the index-type
- (do ((i 0 (+ i 1))
- (sto-idx (the index-type hd)
- (the index-type
- (+ sto-idx
- (the index-type
- (* (the index-type
- (aref strides i))
- ;;
- (the index-type
- (let ((cidx (aref idx i)))
- (declare (type index-type cidx))
- (if (< -1 cidx (aref dims i))
- cidx
- (error 'tensor-index-out-of-bounds :argument i :index cidx :dimension (aref dims i)))))))))))
- ((= i rank) sto-idx)
- (declare (type index-type i sto-idx)))))))
-
-(defun store-indexing-lst (idx hd strides dims)
-"
-Returns the sum
-
- length(strides)
- __
-hd + \ stride * idx
- /_ i i
- i = 0
-
-idx here is a list.
-"
- (declare (type index-type hd)
- (type (index-array *) strides dims)
- (type cons idx))
- (let ((rank (length strides)))
- (declare (type index-type rank))
- (labels ((rec-sum (sum i lst)
- (cond
- ((and (null lst) (= i rank)) (the index-type sum))
- ((or (null lst) (= i rank)) (error 'tensor-index-rank-mismatch :index-rank (length idx) :rank rank))
- (t
- (let ((cidx (car lst)))
- (declare (type index-type cidx))
- (rec-sum (the index-type (+ sum
- (* (aref strides i)
- (if (< -1 cidx (aref dims i))
- cidx
- (error 'tensor-index-out-of-bounds :argument i :index cidx :dimension (aref dims i))))))
- (+ i 1) (cdr lst)))))))
- (rec-sum (the index-type hd) 0 idx))))
-
-;;
(defclass standard-tensor ()
((rank
:accessor rank
@@ -173,6 +92,38 @@ idx here is a list.
:accessor parent-tensor))
(:documentation "Basic sub-tensor class."))
+
+;;
+(defparameter *sub-tensor-counterclass* (make-hash-table)
+ "
+Contains the sub-tensor CLOS counterpart classes of every
+tensor class. This is used by sub-tensor~ and other in-place
+slicing functions to construct new objects.")
+
+(setf (gethash 'standard-tensor *sub-tensor-counterclass*) 'standard-sub-tensor)
+
+;;
+(defparameter *tensor-class-optimizations* (make-hash-table)
+ "
+Contains a either:
+o A property list containing:
+:element-type
+:store-type
+:reader (store idx) => result
+:value-writer (value store idx) => (store idx) <- value
+:reader-writer (fstore fidx tstore tidx) => (tstore tidx) <- (fstore fidx)
+o class-name (symbol) of the superclass whose optimizations
+ are to be made use of.")
+
+(defun get-tensor-class-optimization (clname)
+ (declare (type symbol clname))
+ (let ((opt (gethash clname *tensor-class-optimizations*)))
+ (cond
+ ((symbolp opt)
+ (get-tensor-class-optimization opt))
+ ((null opt) nil)
+ (t 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)
@@ -181,12 +132,96 @@ idx here is a list.
(make-load-form-saving-slots tensor :environment env))
;;
+(defun store-indexing-vec (idx hd strides dims)
+"
+ Syntax
+ ======
+ (STORE-INDEXING-VEC IDX HD STRIDES DIMS)
+
+ Purpose
+ =======
+ Does error checking to make sure IDX is not out of bounds.
+ Returns the sum:
+
+ length(STRIDES)
+ __
+ HD + \ STRIDE * IDX
+ /_ i i
+ i = 0
+"
+ (declare (type index-type hd)
+ (type (index-array *) idx strides dims))
+ (let ((rank (length strides)))
+ (declare (type index-type rank))
+ (if (not (= rank (length idx)))
+ (error 'tensor-index-rank-mismatch :index-rank (length idx) :rank rank)
+ (very-quickly
+ (loop
+ for i of-type index-type from 0 below rank
+ and sto-idx of-type index-type = hd then (+ sto-idx (* cidx (aref strides i)))
+ for cidx of-type index-type = (aref idx i)
+ do (unless (< -1 cidx (aref dims i))
+ (error 'tensor-index-out-of-bounds :argument i :index cidx :dimension (aref dims i)))
+ finally (return sto-idx))))))
+
+(defun store-indexing-lst (idx hd strides dims)
+"
+ Syntax
+ ======
+ (STORE-INDEXING-LST IDX HD STRIDES DIMS)
+
+ Purpose
+ =======
+ Does error checking to make sure idx is not out of bounds.
+ Returns the sum:
+
+ length(STRIDES)
+ __
+ HD + \ STRIDE * IDX
+ /_ i i
+ i = 0
+"
+ (declare (type index-type hd)
+ (type (index-array *) strides dims)
+ (type cons idx))
+ (let ((rank (length strides)))
+ (declare (type index-type rank))
+ (labels ((rec-sum (sum i lst)
+ (cond
+ ((consp lst)
+ (let ((cidx (car lst)))
+ (declare (type index-type cidx))
+ (unless (< -1 cidx (aref dims i))
+ (error 'tensor-index-out-of-bounds :argument i :index cidx :dimension (aref dims i)))
+ (rec-sum (+ sum (* (aref strides i) cidx)) (1+ i) (cdr lst))))
+ ((and (null lst) (= i rank)) sum)
+ (t
+ (error 'tensor-index-rank-mismatch :index-rank (length idx) :rank rank)))))
+ (rec-sum (the index-type hd) (the index-type 0) idx))))
+
(defun store-indexing (idx tensor)
+"
+ Syntax
+ ======
+ (STORE-INDEXING IDX TENSOR)
+
+ Purpose
+ =======
+ Returns the linear index of the element pointed by IDX.
+ Does error checking to make sure idx is not out of bounds.
+ Returns the sum:
+
+ length(STRIDES)
+ __
+ HD + \ STRIDES * IDX
+ /_ i i
+ i = 0
+"
(declare (type standard-tensor tensor)
(type (or cons (index-array *)) idx))
(typecase idx
- (cons (store-indexing-lst idx (strides tensor) (dimensions tensor) (head tensor)))
- (vector (store-indexing-lst idx (strides tensor) (dimensions tensor) (head tensor)))))
+ (cons (store-indexing-lst idx (head tensor) (strides tensor) (dimensions tensor)))
+ (vector (store-indexing-lst idx (head tensor) (strides tensor) (dimensions tensor)))))
;;
(defmethod initialize-instance :after ((tensor standard-tensor) &rest initargs)
@@ -241,33 +276,59 @@ idx here is a list.
(unless (< -1 idx (store-size tensor))
(error 'store-index-out-of-bounds :index idx :store-size (store-size tensor) :tensor tensor))))
-;;
(defgeneric (setf tensor-store-ref) (value tensor idx)
- (:method :before ((value t) (tensor standard-tensor) idx)
+ (:method :before (value (tensor standard-tensor) idx)
(declare (type index-type idx))
(unless (< -1 idx (store-size tensor))
(error 'store-index-out-of-bounds :index idx :store-size (store-size tensor) :tensor tensor))))
+(defmacro tensor-store-defs ((tensor-class element-type store-element-type) &key reader value-writer reader-writer)
+ (let ((tensym (gensym "tensor")))
+ (assert (eq (first reader-writer) 'lambda))
+ `(progn
+ ,(destructuring-bind (lbd args &rest body) reader
+ (assert (eq lbd 'lambda))
+ (destructuring-bind (tstore idx) args
+ `(defmethod tensor-store-ref ((,tensym ,tensor-class) ,idx)
+ (declare (type index-type ,idx))
+ (let ((,tstore (store ,tensym)))
+ (declare (type ,(linear-array-type store-element-type) ,tstore))
+ ,@body))))
+ ,(destructuring-bind (lbd args &rest body) value-writer
+ (assert (eq lbd 'lambda))
+ (destructuring-bind (value tstore tidx) args
+ `(defmethod (setf tensor-store-ref) (,value (,tensym ,tensor-class) ,tidx)
+ (declare (type index-type ,tidx)
+ (type ,element-type ,value))
+ (let ((,tstore (store ,tensym)))
+ (declare (type ,(linear-array-type store-element-type) ,tstore))
+ ,@body))))
+ (let ((hst (list
+ :reader (macrofy ,reader)
+ :value-writer (macrofy ,value-writer)
+ :reader-writer (macrofy ,reader-writer)
+ :element-type ',element-type
+ :store-type ',store-element-type)))
+ (setf (gethash ',tensor-class *tensor-class-optimizations*) hst)))))
+
;;
(defgeneric tensor-ref (tensor subscripts)
- (:documentation
-"
-Syntax
-======
-(tensor-ref store subscripts)
-
-Purpose
-=======
-Return the element:
-
- (rank - 1)
- __
-hd + \ stride * sub
- /_ i i
- i = 0
-
-of the store.
-")
+ (:documentation "
+ Syntax
+ ======
+ (tensor-ref store subscripts)
+
+ Purpose
+ =======
+ Return the element:
+
+ (rank - 1)
+ __
+ hd + \ stride * sub
+ /_ i i
+ i = 0
+
+ of the store.")
(:method ((tensor standard-tensor) subscripts)
(let ((sto-idx (store-indexing subscripts tensor)))
(tensor-store-ref tensor sto-idx))))
@@ -281,16 +342,15 @@ of the store.
(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.
-")
+ 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)))
@@ -298,25 +358,26 @@ of the store.
(defun tensor-type-p (tensor subscripts)
"
-Syntax
-======
-(tensor-type-p tensor subscripts)
+ Syntax
+ ======
+ (tensor-type-p tensor subscripts)
-Purpose
-=======
-Check if the given tensor is of particular sizes in particular
-arguments.
+ Purpose
+ =======
+ Check if the given tensor is of a particular size in particular
+ arguments.
-Checking if the tensor is a vector would then be:
-> (tensor-type-p ten '(*))
+ Examples
+ ========
+ Checking for a vector:
+ > (tensor-type-p ten '(*))
-Checking if it is a matrix with 2 columns would be:
-> (tensor-type-p ten '(* 2))
+ Checking for a matrix with 2 columns:
+ > (tensor-type-p ten '(* 2))
-Also does symbolic association, so that things like this:
-> (tensor-type-p ten '(a a))
-are valid. This particular example checks if the tensor is
-square.
+ Also does symbolic association; checking for
+ a square matrix:
+ > (tensor-type-p ten '(a a))
"
(declare (type standard-tensor tensor))
(mlet* (((rank dims) (slot-values tensor '(rank dimensions))
@@ -340,11 +401,11 @@ square.
nil)))))))
(parse-sub subscripts 0)))))
-(defun vector-p (tensor)
+(definline vector-p (tensor)
(declare (type standard-tensor tensor))
(tensor-type-p tensor '(*)))
-(defun matrix-p (tensor)
+(definline matrix-p (tensor)
(declare (type standard-tensor tensor))
(tensor-type-p tensor '(* *)))
@@ -357,15 +418,35 @@ square.
;;---------------------------------------------------------------;;
(define-constant +array-slicing-symbols+ '(\:)
+"
+ Symbols which are used to refer to slicing operations.")
+
+(defun sub-tensor~ (tensor subscripts)
"
-These are the symbols which are understoop to mean slicing operations
-in subscript lists passed to functions.
-")
+ Syntax
+ ======
+ (SUB-TENSOR~ TENSOR SUBSCRIPTS)
-(defparameter *sub-tensor-counterclass*
- (make-hash-table))
+ Purpose
+ =======
+ Creates a new tensor data structure, sharing store with
+ TENSOR but with different strides and dimensions, as defined
+ in the subscript-list SUBSCRIPTS.
-(defun sub-tensor~ (tensor subscripts)
+ Examples
+ ========
+ > (defvar X (make-real-tensor 10 10 10))
+ X
+
+ ;; Get [:, 0, 0]
+ > (sub-tensor~ X '(\: 0 0))
+
+ ;; Get [:, 2:5, :]
+ > (sub-tensor~ X '(\: (\: 2 5) \:))
+
+ ;; Get [:, :, 0:10:2] (0:10:2 = [i : 0 <= i < 10, i % 2 = 0])
+ > (sub-tensor~ X '(\: \: ((\: 2) 0 *)))
+"
(declare (type standard-tensor tensor))
(let ((rank (rank tensor))
(dims (dimensions tensor))
diff --git a/src/tensor-copy.lisp b/src/tensor-copy.lisp
index 0a462b4..c52907a 100644
--- a/src/tensor-copy.lisp
+++ b/src/tensor-copy.lisp
@@ -22,9 +22,63 @@ is used, else the fortran routine is called instead.
and accumulated-off of-type index-type = 1 then (* accumulated-off dim)
unless (= off accumulated-off) do (return nil)
finally (return t))))
-
;;
+
+(defmacro mod-tensor-loop ((idx dims) &body body)
+ (check-type idx symbol)
+ (let ((tensor-table (make-hash-table)))
+ (labels ((get-tensors (decl ret)
+ (if (null decl)
+ ret
+ (let ((cdecl (car decl)))
+ (if (and (eq (first cdecl) 'type)
+ (gethash (second cdecl) *sub-tensor-counterclass*))
+ (dolist sym
+ (get-tensors (cdr decl) (append ret (cddr cdecl)))
+ (get-tensors (cdr decl) ret)))))
+ (transform-tensor-ref (snippet)
+ (let ((ten (second snippet))
+ (index (third snippet)))
+ (if (not (eq index idx)) snippet
+ (destructuring-bind (tstride tstore toff)
+ (if-ret (gethash ten tensor-table)
+ (setf (gethash ten tensor-table)
+ (mapcar #'(lambda (x)
+ (gensym (string+ (symbol-name ten) (symbol-name x))))
+ '(stride store off))))
+ (let ((let-before-code `((,tstride (strides ,ten))
+ (,tstore (store ,ten))))
+ (loop-code `(with ,toff of-type index-type = (head ,ten)))
+ (decl-code `(type
+
+
+
+ (find-tensor-refs (code ret ten)
+ (let ((ccode (car code)))
+ (cond
+ ((consp ccode)
+ (find-tensor-refs (car ccode) ...))
+ ((eq ccode 'tensor-ref)
+ (transform-tensor-ref code)))
+
+ (with-gensyms (dims-sym rank-sym)
+ `(let* ((,dims-sym ,dims)
+ (,rank-sym (length ,dims-sym))
+ (,idx (allocate-index-store ,rank-sym)))
+ (declare (type (index-array *) ,idx))
+ (loop
+ do (progn
+ ,@body)
+ while (dotimes (i ,rank-sym nil)
+ (declare (type index-type i))
+ (if (= (aref ,idx i) (1- (aref ,dims-sym i)))
+ (progn
+ (setf (aref ,idx i) 0))
+ (progn
+ (incf (aref ,idx i))
+ (return t))))))))
+
(defun tensor-copy (from to)
(declare (optimize (speed 3) (safety 0))
(type real-tensor to from))
@@ -42,14 +96,16 @@ is used, else the fortran routine is called instead.
with of-f of-type index-type = (head from)
do (setf (aref t-store of-t) (aref f-store of-f))
while (dotimes (i rank nil)
- (incf (aref idx i))
- (incf of-t (aref t-strides i))
- (incf of-f (aref f-strides i))
- (when (< (aref idx i) (aref dims i)) (return t))
- (setf (aref idx i) 0)
- (decf of-t (* (aref t-strides i) (aref dims i)))
- (decf of-f (* (aref f-strides i) (aref dims i)))))))
-
+ (if (= (aref idx i) (1- (aref dims i)))
+ (progn
+ (setf (aref idx i) 0)
+ (decf of-t (* (aref t-strides i) (1- (aref dims i))))
+ (decf of-f (* (aref f-strides i) (1- (aref dims i)))))
+ (progn
+ (incf (aref idx i))
+ (incf of-t (aref t-strides i))
+ (incf of-f (aref f-strides i))
+ (return t)))))))
(defmacro generate-typed-copy!-func (func store-type matrix-type blas-func)
;;Be very careful when using functions generated by this macro.
diff --git a/src/utilities.lisp b/src/utilities.lisp
index b9bf14d..794e30b 100644
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -1,22 +1,22 @@
(in-package :utilities)
-;;
(defmacro mlet* (decls &rest body)
-" mlet* ({ {(var*) | var} values-form &keyform declare type}*) form*
+"
+mlet* ({ {(var*) | var} values-form &keyform declare type}*) form*
- o var is just one symbol -> expands into let
- o var is a list -> expands into multiple-value-bind
+o var is just one symbol -> expands into let
+o var is a list -> expands into multiple-value-bind
- This macro also handles type declarations.
+This macro also handles type declarations.
- Example:
- (mlet* ((x 2 :type fixnum :declare ((optimize (safety 0) (speed 3))))
- ((a b) (floor 3) :type (nil fixnum)))
- (+ x b))
+Example:
+> (mlet* ((x 2 :type fixnum :declare ((optimize (safety 0) (speed 3))))
+ ((a b) (floor 3) :type (nil fixnum)))
+ (+ x b))
- expands into:
+expands into:
- (let ((x 2))
+> (let ((x 2))
(declare (optimize (safety 0) (speed 3))
(type fixnum x))
(multiple-value-bind (a b)
@@ -33,7 +33,6 @@
`(ignore ,(second tv))
`(type ,(first tv) ,(second tv))))
(map 'list #'list type vars)))))))
- ;;
(mlet-transform (elst nest-code)
(destructuring-bind (vars form &key declare type) elst
`(,(append (cond
@@ -41,37 +40,41 @@
;;instead of multiple-value-bind
((or (symbolp vars))
`(let ((,vars ,form))))
- ;;
(t
`(multiple-value-bind (,@vars) ,form)))
(if (symbolp vars)
(mlet-decl (list vars) (list type) declare)
(mlet-decl vars type declare))
nest-code))))
- ;;
(mlet-walk (elst body)
(if (null elst)
`(,@body)
(mlet-transform (car elst) (mlet-walk (cdr elst) body)))))
- ;;
(if decls
(car (mlet-walk decls body))
`(progn
,@body))))
-;;
(defmacro let-rec (name arglist &rest code)
- "let-rec name ({var [init-form]}*) declaration* form* => result*
+"
+(let-rec name ({var [init-form]}*) declaration* form*) => result*
+Works similar to \"let\" in Scheme.
- Works similar to \"let\" in Scheme."
+Example:
+> (let-rec rev ((x '(1 2 3 4)) (ret nil))
+ (if (null x) ret
+ (rev (cdr x) (cons (car x) ret))))
+"
(let ((init (mapcar #'second arglist))
(args (mapcar #'first arglist)))
`(labels ((,name (,@args)
,@code))
(,name ,@init))))
-;;
(defmacro with-gensyms (symlist &body body)
+"
+(with-gensyms (var *) form*)
+Binds every variable in SYMLIST to a gensym."
`(let ,(mapcar #'(lambda (sym)
`(,sym (gensym ,(symbol-name sym))))
symlist)
@@ -87,7 +90,6 @@
(nconc ,var ,@(cdr args)))
(nconc ,var ,@args))))
-;;
(defun pop-arg! (sym arglist)
(check-type sym symbol)
(locally
@@ -102,19 +104,23 @@
(t (get-sym sym (cdr arglist) arglist)))))
(get-sym sym arglist nil))))
-;;
(defun slot-values (obj slots)
(values-list (mapcar #'(lambda (slt) (slot-value obj slt))
slots)))
-;;
+(declaim (inline linear-array-type))
+(defun linear-array-type (type-sym &optional (size '*))
+ `(simple-array ,type-sym (,size)))
+
+(declaim (inline ensure-list))
(defun ensure-list (lst)
(if (listp lst)
lst
`(,lst)))
(defmacro if-ret (form &rest else-body)
- "if-ret (form &rest else-body)
+"
+if-ret (form &rest else-body)
Evaluate form, and if the form is not nil, then return it,
else run else-body"
(let ((ret (gensym)))
@@ -150,7 +156,7 @@ else run else-body"
(cut-cons-chain-tin lst test lst)))
;;
-(defun zip (&rest args)
+(defun zip (&rest args)
(apply #'map 'list #'list args))
;;
@@ -169,8 +175,7 @@ else run else-body"
`(and ,@(mapcar (lambda (pair) (cons 'eq pair))
(zip (ensure-list a) (ensure-list b)))))
-;;
-(defun recursive-append (&rest lsts)
+(defun recursive-append (&rest lsts)
(labels ((bin-append (x y)
(if (null x)
(if (typep (car y) 'symbol)
@@ -185,6 +190,50 @@ else run else-body"
nil
(bin-append (car lsts) (apply #'recursive-append (cdr lsts))))))
+(defun unquote-args (lst args)
+ (labels ((replace-atoms (lst ret)
+ (if (null lst) (reverse ret)
+ (let ((fst (car lst)))
+ (replace-atoms (cdr lst)
+ (cond
+ ((atom fst)
+ (if (member fst args)
+ (cons fst ret)
+ (append `(',fst) ret)))
+ ((consp fst)
+ (cons (replace-lst fst nil) ret)))))))
+ (replace-lst (lst acc)
+ (cond
+ ((null lst) acc)
+ ((consp lst)
+ (cons 'list (replace-atoms lst nil)))
+ ((atom lst) lst))))
+ (replace-lst lst nil)))
+
+(defun flatten (x)
+ (labels ((rec (x acc)
+ (cond ((null x) acc)
+ ((atom x) (cons x acc))
+ (t (rec
+ (car x)
+ (rec (cdr x) acc))))))
+ (rec x nil)))
+
+(defmacro macrofy (lambda-func)
+ (destructuring-bind (labd args &rest body) lambda-func
+ (assert (eq labd 'lambda))
+ `(lambda ,args ,@(cdr (unquote-args body args)))))
+
+(declaim (inline string+))
+(defun string+ (&rest strings)
+ (apply #'concatenate (cons 'string strings)))
+
+(defun format-to-string (fmt &rest args)
+ (let ((ret (make-array 0 :element-type 'character :fill-pointer t)))
+ (with-output-to-string (ostr ret)
+ (apply #'format (append `(,ostr ,fmt) args)))
+ ret))
+
;;---------------------------------------------------------------;;
(defstruct (foreign-vector
(:conc-name fv-)
@@ -359,15 +408,15 @@ use the inlining macro directly."
,@(if (eq (caar forms) 'declare) (cdr forms) forms)))
(defmacro quickly (&body forms)
- `(with-optimization (:speed 3) do
+ `(with-optimization (:speed 3)
,@forms))
(defmacro very-quickly (&body forms)
- `(with-optimization (:safety 0 :space 0 :speed 3) do
+ `(with-optimization (:safety 0 :space 0 :speed 3)
,@forms))
(defmacro slowly (&body forms)
- `(with-optimization (:speed 1) do
+ `(with-optimization (:speed 1)
,@forms))
(defmacro quickly-if (test &body forms)
-----------------------------------------------------------------------
Summary of changes:
AUTHORS | 6 +-
matlisp.asd | 8 +-
packages.lisp | 16 +-
src/complex-tensor.lisp | 28 ++-
src/conditions.lisp | 4 +-
src/ffi-cffi-interpreter-specific.lisp | 76 ++----
src/ffi-cffi.lisp | 19 +-
src/print.lisp | 188 +++++----------
src/real-matrix.lisp | 31 ---
src/real-tensor.lisp | 21 ++-
src/standard-matrix.lisp | 95 +++++---
src/standard-tensor.lisp | 401 +++++++++++++++++++-------------
src/tensor-copy.lisp | 74 +++++-
src/utilities.lisp | 107 ++++++---
14 files changed, 598 insertions(+), 476 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-06-16 05:18:36
|
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, tensor has been updated
via 8232b005b14d4aced35d7ce07afe9a9c35233b7e (commit)
via 90e484c4fa59934da70010e4b2ff789fdbf6f40b (commit)
from 1d9d45b7aac05a33ccb3cae5428a08cda19d00ce (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 8232b005b14d4aced35d7ce07afe9a9c35233b7e
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Jun 16 10:42:45 2012 +0530
* Added some macros from Nicholas Neuss' femlisp.
* Made vector-data-address into a macro so that pointer aren't coerced into sap's
(or was it the other way around ?)
* Added a sub-tensor~ method.
diff --git a/AUTHORS b/AUTHORS
index a3868e3..8ca39ab 100644
--- a/AUTHORS
+++ b/AUTHORS
@@ -1,4 +1,8 @@
-Matlisp is primarily written by Tunc Simsek, based on an initial
-prototype by Raymond Toy.
+Matlisp was originally written by Tunc Simsek,
+based on an initial prototype by Raymond Toy.
-It is now being tweaked by Akshay Srinivasan.
+It is now being refactored by Akshay Srinivasan.
+
+Some code has been either been directly obtained from,
+or modified from Femlisp (www.femlisp.org), written by
+Nicholas Neuss.
diff --git a/matlisp.asd b/matlisp.asd
index adf4dd6..4de9217 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -62,26 +62,12 @@
:components
((:file "f77-mangling")))
-(defclass f2cl-cl-source-file (asdf:cl-source-file)
- ())
-
-(defmethod asdf:source-file-type ((f f2cl-cl-source-file) (m asdf:module))
- "l")
-
-(asdf:defsystem matlisp-f2cl-macros
- :pathname #.(translate-logical-pathname "matlisp:srcdir;lib-src;")
- :depends-on ("matlisp-packages")
- :default-component-class f2cl-cl-source-file
- :components
- ((:file "macros")))
-
(asdf:defsystem matlisp
- :pathname #.(translate-logical-pathname "matlisp:srcdir;")
- :depends-on ("lazy-loader"
- "matlisp-packages"
- "matlisp-utilities"
- "fortran-names"
- "matlisp-f2cl-macros")
+ :pathname #.(translate-logical-pathname "matlisp:srcdir;")
+ :depends-on ("lazy-loader"
+ "matlisp-packages"
+ "matlisp-utilities"
+ "fortran-names")
:components
((:module "foreign-interface"
:pathname "src/"
@@ -93,234 +79,280 @@
:depends-on ("foreign-interface")
:components ((:file "blas")
(:file "lapack")
- (:file "dfftpack")
- #+nil (:file "ranlib")))
+ (:file "dfftpack")))
(:module "matlisp-essentials"
:pathname "src/"
:depends-on ("foreign-interface"
"foreign-functions")
:components ((:file "conditions")
- (:file "standard-matrix")
- (:file "real-matrix"
- :depends-on ("standard-matrix"))
- (:file "complex-matrix"
- :depends-on ("standard-matrix"))
- ;; (:file "ref"
- ;; :depends-on ("matrix"))
- (:file "copy"
- :depends-on ("standard-matrix"))
- (:file "print"
- :depends-on ("standard-matrix"))))
+ (:file "standard-tensor")
+ (:file "real-tensor"
+ :depends-on ("standard-tensor"))
+ (:file "complex-tensor"
+ :depends-on ("standard-tensor"))
+ (:file "standard-matrix"
+ :depends-on ("standard-tensor"))))))
+
+
+;; (defclass f2cl-cl-source-file (asdf:cl-source-file)
+;; ())
+
+;; (defmethod asdf:source-file-type ((f f2cl-cl-source-file) (m asdf:module))
+;; "l")
+
+;; (asdf:defsystem matlisp-f2cl-macros
+;; :pathname #.(translate-logical-pathname "matlisp:srcdir;lib-src;")
+;; :depends-on ("matlisp-packages")
+;; :default-component-class f2cl-cl-source-file
+;; :components
+;; ((:file "macros")))
+
+;; (asdf:defsystem matlisp
+;; :pathname #.(translate-logical-pathname "matlisp:srcdir;")
+;; :depends-on ("lazy-loader"
+;; "matlisp-packages"
+;; "matlisp-utilities"
+;; "fortran-names"
+;; "matlisp-f2cl-macros")
+;; :components
+;; ((:module "foreign-interface"
+;; :pathname "src/"
+;; :components ((:file "ffi-cffi")
+;; (:file "ffi-cffi-interpreter-specific")
+;; ))
+;; (:module "foreign-functions"
+;; :pathname "src/"
+;; :depends-on ("foreign-interface")
+;; :components ((:file "blas")
+;; (:file "lapack")
+;; (:file "dfftpack")
+;; #+nil (:file "ranlib")))
+;; (:module "matlisp-essentials"
+;; :pathname "src/"
+;; :depends-on ("foreign-interface"
+;; "foreign-functions")
+;; :components ((:file "conditions")
+;; (:file "standard-matrix")
+;; (:file "real-matrix"
+;; :depends-on ("standard-matrix"))
+;; (:file "complex-matrix"
+;; :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"
- "foreign-functions"
- "matlisp-essentials")
- :components ((:file "axpy")
- (:file "scal")
- (:file "swap")
- (:file "gemv")
- (:file "gemm")))
+;; (:module "matlisp-blas-wrappers"
+;; :pathname "src/"
+;; :depends-on ("foreign-interface"
+;; "foreign-functions"
+;; "matlisp-essentials")
+;; :components ((:file "axpy")
+;; (:file "scal")
+;; (:file "swap")
+;; (:file "gemv")
+;; (:file "gemm")))
- (:module "matlisp-lapack-wrappers"
- :pathname "src/"
- :depends-on ("foreign-interface"
- "foreign-functions"
- "matlisp-essentials")
- :components ((:file "gels")
- (:file "gesv")
- (:file "geev")
- (:file "getrf")
- (:file "getrs")
- (:file "potrf")
- (:file "potrs")))
+;; (:module "matlisp-lapack-wrappers"
+;; :pathname "src/"
+;; :depends-on ("foreign-interface"
+;; "foreign-functions"
+;; "matlisp-essentials")
+;; :components ((:file "gels")
+;; (:file "gesv")
+;; (:file "geev")
+;; (:file "getrf")
+;; (:file "getrs")
+;; (:file "potrf")
+;; (:file "potrs")))
- (:module "matlisp-functions"
- :pathname "src/"
- :depends-on ("foreign-interface"
- "foreign-functions"
- "matlisp-essentials"
- "matlisp-blas-wrappers"
- "matlisp-lapack-wrappers")
- :components ((:file "compat")
- (:file "help")
- (:file "special")
- (:file "reader")
- (:file "trans")
- (:file "realimag")
- (:file "submat")
- (:file "reshape")
- (:file "join")
- (:file "svd")
- (:file "sum")
- (:file "norm")
- (:file "dot")
- (:file "trace")
- (:file "seq")
- (:file "vec")
- (:file "map")
- (:file "mplus")
- (:file "mminus")
- (:file "mtimes")
- (:file "mdivide")
- (:file "msqrt")
- (:file "fft")
- (:file "geqr")))
- (:module "special-functions"
- :pathname "src/"
- :depends-on ("matlisp-functions")
- :components
- ((:file "specfun")))))
+;; (:module "matlisp-functions"
+;; :pathname "src/"
+;; :depends-on ("foreign-interface"
+;; "foreign-functions"
+;; "matlisp-essentials"
+;; "matlisp-blas-wrappers"
+;; "matlisp-lapack-wrappers")
+;; :components ((:file "compat")
+;; (:file "help")
+;; (:file "special")
+;; (:file "reader")
+;; (:file "trans")
+;; (:file "realimag")
+;; (:file "submat")
+;; (:file "reshape")
+;; (:file "join")
+;; (:file "svd")
+;; (:file "sum")
+;; (:file "norm")
+;; (:file "dot")
+;; (:file "trace")
+;; (:file "seq")
+;; (:file "vec")
+;; (:file "map")
+;; (:file "mplus")
+;; (:file "mminus")
+;; (:file "mtimes")
+;; (:file "mdivide")
+;; (:file "msqrt")
+;; (:file "fft")
+;; (:file "geqr")))
+;; (:module "special-functions"
+;; :pathname "src/"
+;; :depends-on ("matlisp-functions")
+;; :components
+;; ((:file "specfun")))))
;; Add-on packages
-(asdf:defsystem matlisp-quadpack
- :pathname #.(translate-logical-pathname "matlisp:srcdir;")
- :depends-on ("matlisp-f2cl-macros")
- :components
- ((:module "quadpack-interface"
- :pathname "src/"
- :components
- ((:file "quadpack")))
- (:module "lib-src"
- :components
- ((:module "quadpack"
- :components
- (
- ;; Support
- (:file "dqwgtf")
- (:file "dqcheb")
- (:file "dqk15w")
- (:file "dqwgts")
- (:file "dqwgtc")
- (:file "dgtsl")
- (:file "xerror")
+;; (asdf:defsystem matlisp-quadpack
+;; :pathname #.(translate-logical-pathname "matlisp:srcdir;")
+;; :depends-on ("matlisp-f2cl-macros")
+;; :components
+;; ((:module "quadpack-interface"
+;; :pathname "src/"
+;; :components
+;; ((:file "quadpack")))
+;; (:module "lib-src"
+;; :components
+;; ((:module "quadpack"
+;; :components
+;; (
+;; ;; Support
+;; (:file "dqwgtf")
+;; (:file "dqcheb")
+;; (:file "dqk15w")
+;; (:file "dqwgts")
+;; (:file "dqwgtc")
+;; (:file "dgtsl")
+;; (:file "xerror")
- ;; Core integration routines
- (:file "dqk15")
- (:file "dqk31")
- (:file "dqk41")
- (:file "dqk51")
- (:file "dqk61")
- (:file "dqk21")
- (:file "dqk15i")
- (:file "dqelg")
- (:file "dqpsrt")
- (:file "dqc25s"
- :depends-on ("dqcheb" "dqk15w"))
- (:file "dqmomo")
- (:file "dqc25c"
- :depends-on ("dqcheb"
- "dqk15w"))
- (:file "dqc25f"
- :depends-on ("dgtsl"
- "dqcheb"
- "dqk15w"
- "dqwgtf"))
- ;; Basic integrators
- (:file "dqage"
- :depends-on ("dqk15"
- "dqk31"
- "dqk41"
- "dqk51"
- "dqk61"
- "dqk21"
- "dqpsrt"))
- (:file "dqagie"
- :depends-on ("dqelg"
- "dqk15i"
- "dqpsrt"))
- (:file "dqagpe"
- :depends-on ("dqelg"
- "dqpsrt"
- "dqk21"
- ))
- (:file "dqagse"
- :depends-on ("dqk21"
- "dqelg"
- "dqpsrt"))
- (:file "dqawfe"
- :depends-on ("dqagie"
- "dqawoe"
- "dqelg"))
- (:file "dqawoe"
- :depends-on ("dqc25f"
- "dqpsrt"
- "dqelg"))
- (:file "dqawse"
- :depends-on ("dqc25s"
- "dqmomo"
- "dqpsrt"))
- (:file "dqawce"
- :depends-on ("dqc25c"
- "dqpsrt"))
- ;; Simplified interface routines
- (:file "dqng"
- :depends-on ("xerror"))
- (:file "dqag"
- :depends-on ("dqage"
- "xerror"))
- (:file "dqags"
- :depends-on ("dqagse"
- "xerror"))
- (:file "dqagi"
- :depends-on ("dqagie"
- "xerror"))
- (:file "dqawf"
- :depends-on ("dqawfe"
- "xerror"))
- (:file "dqawo"
- :depends-on ("dqawoe"
- "xerror"))
- (:file "dqaws"
- :depends-on ("dqawse"
- "xerror"))
- (:file "dqawc"
- :depends-on ("dqawce"
- "xerror"))))))))
+;; ;; Core integration routines
+;; (:file "dqk15")
+;; (:file "dqk31")
+;; (:file "dqk41")
+;; (:file "dqk51")
+;; (:file "dqk61")
+;; (:file "dqk21")
+;; (:file "dqk15i")
+;; (:file "dqelg")
+;; (:file "dqpsrt")
+;; (:file "dqc25s"
+;; :depends-on ("dqcheb" "dqk15w"))
+;; (:file "dqmomo")
+;; (:file "dqc25c"
+;; :depends-on ("dqcheb"
+;; "dqk15w"))
+;; (:file "dqc25f"
+;; :depends-on ("dgtsl"
+;; "dqcheb"
+;; "dqk15w"
+;; "dqwgtf"))
+;; ;; Basic integrators
+;; (:file "dqage"
+;; :depends-on ("dqk15"
+;; "dqk31"
+;; "dqk41"
+;; "dqk51"
+;; "dqk61"
+;; "dqk21"
+;; "dqpsrt"))
+;; (:file "dqagie"
+;; :depends-on ("dqelg"
+;; "dqk15i"
+;; "dqpsrt"))
+;; (:file "dqagpe"
+;; :depends-on ("dqelg"
+;; "dqpsrt"
+;; "dqk21"
+;; ))
+;; (:file "dqagse"
+;; :depends-on ("dqk21"
+;; "dqelg"
+;; "dqpsrt"))
+;; (:file "dqawfe"
+;; :depends-on ("dqagie"
+;; "dqawoe"
+;; "dqelg"))
+;; (:file "dqawoe"
+;; :depends-on ("dqc25f"
+;; "dqpsrt"
+;; "dqelg"))
+;; (:file "dqawse"
+;; :depends-on ("dqc25s"
+;; "dqmomo"
+;; "dqpsrt"))
+;; (:file "dqawce"
+;; :depends-on ("dqc25c"
+;; "dqpsrt"))
+;; ;; Simplified interface routines
+;; (:file "dqng"
+;; :depends-on ("xerror"))
+;; (:file "dqag"
+;; :depends-on ("dqage"
+;; "xerror"))
+;; (:file "dqags"
+;; :depends-on ("dqagse"
+;; "xerror"))
+;; (:file "dqagi"
+;; :depends-on ("dqagie"
+;; "xerror"))
+;; (:file "dqawf"
+;; :depends-on ("dqawfe"
+;; "xerror"))
+;; (:file "dqawo"
+;; :depends-on ("dqawoe"
+;; "xerror"))
+;; (:file "dqaws"
+;; :depends-on ("dqawse"
+;; "xerror"))
+;; (:file "dqawc"
+;; :depends-on ("dqawce"
+;; "xerror"))))))))
-(asdf:defsystem matlisp-minpack
- :pathname #.(translate-logical-pathname "matlisp:srcdir;")
- :depends-on ("matlisp-f2cl-macros")
- :components
- ((:module "lib-src"
- :components
- ((:module "minpack"
- :components
- ((:file "dpmpar")
- (:file "enorm")
- (:file "fdjac2")
- (:file "qrsolv")
- (:file "lmpar")
- (:file "qrfac")
- (:file "lmdif")
- (:file "lmdif1")
- (:file "lmder")
- (:file "lmder1")
- (:file "dogleg")
- (:file "qform")
- (:file "r1mpyq")
- (:file "r1updt")
- (:file "hybrj" :depends-on ("dogleg" "qform" "r1mpyq" "r1updt"))
- (:file "hybrj1" :depends-on ("hybrj"))
- ))))))
+;; (asdf:defsystem matlisp-minpack
+;; :pathname #.(translate-logical-pathname "matlisp:srcdir;")
+;; :depends-on ("matlisp-f2cl-macros")
+;; :components
+;; ((:module "lib-src"
+;; :components
+;; ((:module "minpack"
+;; :components
+;; ((:file "dpmpar")
+;; (:file "enorm")
+;; (:file "fdjac2")
+;; (:file "qrsolv")
+;; (:file "lmpar")
+;; (:file "qrfac")
+;; (:file "lmdif")
+;; (:file "lmdif1")
+;; (:file "lmder")
+;; (:file "lmder1")
+;; (:file "dogleg")
+;; (:file "qform")
+;; (:file "r1mpyq")
+;; (:file "r1updt")
+;; (:file "hybrj" :depends-on ("dogleg" "qform" "r1mpyq" "r1updt"))
+;; (:file "hybrj1" :depends-on ("hybrj"))
+;; ))))))
-(asdf:defsystem matlisp-odepack
- :pathname #.(translate-logical-pathname "matlisp:srcdir;")
- :depends-on ("matlisp-f2cl-macros")
- :components
- ((:module "src"
- :components
- ((:file "dlsode")))))
+;; (asdf:defsystem matlisp-odepack
+;; :pathname #.(translate-logical-pathname "matlisp:srcdir;")
+;; :depends-on ("matlisp-f2cl-macros")
+;; :components
+;; ((:module "src"
+;; :components
+;; ((:file "dlsode")))))
-(asdf:defsystem matlisp-colnew
- :pathname #.(translate-logical-pathname "matlisp:srcdir;")
- :components
- ((:module "src"
- :components
- ((:file "colnew")
- (:file "colnew-demo1" :depends-on ("colnew"))
- (:file "colnew-demo2" :depends-on ("colnew"))))))
+;; (asdf:defsystem matlisp-colnew
+;; :pathname #.(translate-logical-pathname "matlisp:srcdir;")
+;; :components
+;; ((:module "src"
+;; :components
+;; ((:file "colnew")
+;; (:file "colnew-demo1" :depends-on ("colnew"))
+;; (:file "colnew-demo2" :depends-on ("colnew"))))))
(defmethod perform ((op asdf:test-op) (c (eql (asdf:find-system :matlisp))))
(oos 'asdf:test-op 'matlisp-tests))
@@ -336,4 +368,4 @@
(defmethod perform ((op test-op) (c (eql (asdf:find-system :matlisp-tests))))
(or (funcall (intern "DO-TESTS" (find-package "RT")))
- (error "TEST-OP failed for MATLISP-TESTS")))
\ No newline at end of file
+ (error "TEST-OP failed for MATLISP-TESTS")))
diff --git a/packages.lisp b/packages.lisp
index 4134b4a..49d63b1 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -157,13 +157,16 @@
(:use :common-lisp)
(:export #:ensure-list
#:zip #:zip-eq
- #:get-arg #:cut-cons-chain!
- #:slot-values
+ #:cut-cons-chain!
+ #:slot-values
#:recursive-append
;;Macros
- #:when-let #:if-let #:if-ret #:with-gensyms
+ #:when-let #:if-let #:if-ret #:with-gensyms #:let-rec
#:mlet* #:make-array-allocator
- #:nconsc
+ #:nconsc #:define-constant
+ ;;
+ #:inlining #:definline
+ #:with-optimization #:quickly #:very-quickly #:slowly #:quickly-if
;;Structure-specific
#:foreign-vector #:make-foreign-vector #:foreign-vector-p
#:fv-ref #:fv-pointer #:fv-size #:fv-type))
@@ -176,13 +179,13 @@
#+(not (or sbcl cmu allegro)) (:use :common-lisp :cffi :utilities)
(:export
;; interface functions
- #:def-fortran-routine
+ #:def-fortran-routine
#:with-vector-data-addresses
)
(:documentation "Fortran foreign function interface"))
(defpackage :blas
- (:use :commmon-lisp :fortran-ffi-accessors)
+ (:use :common-lisp :fortran-ffi-accessors)
(:export
;;BLAS Level 1
;;------------
@@ -207,7 +210,7 @@
(:documentation "BLAS routines"))
(defpackage :lapack
- (:use :commmon-lisp :fortran-ffi-accessors)
+ (:use :common-lisp :fortran-ffi-accessors)
(:export
#:dgesv #:dgeev #:dgetrf #:dgetrs #:dgesvd
#:zgesv #:zgeev #:zgetrf #:zgetrs #:zgesvd
@@ -218,91 +221,90 @@
(:documentation "LAPACK routines"))
(defpackage :dfftpack
- (:use :commmon-lisp :fortran-ffi-accessors)
+ (:use :common-lisp :fortran-ffi-accessors)
(:export #:zffti #:zfftf #:zfftb #:zffti #:zfftf #:zfftb)
(:documentation "FFT routines"))
+;;Transitioning to using the tensor-datastructures; eventually move things back to :matlisp
+
;; Stolen from f2cl.
-(defpackage :f2cl-lib
- (:use :cl)
- (:documentation "The package holding all symbols used by the fortran to lisp library.")
- (:nicknames :fortran-to-lisp-library)
- (:export
- ;; constants
- #:%false% #:%true%
- ;; user-settable runtime options
- #:*check-array-bounds*
- ;; types
- #:integer4 #:integer2 #:integer1 #:real8 #:real4 #:complex8 #:complex16
- #:array-double-float #:array-single-float #:array-integer4 #:array-strings
- #:logical
- ;; macros
- #:fref #:fset #:with-array-data #:with-multi-array-data
- #:f2cl-init-string #:fref-string #:fset-string #:f2cl-set-string
- #:f2cl-// #:fstring-/= #:fstring-= #:fstring-> #:fstring->= #:fstring-< #:fstring-<=
- #:fortran_comment #:fdo #:f2cl/ #:arithmetic-if #:computed-goto
- #:assigned-goto
- #:fformat
- #:data-implied-do
- #:int-add #:int-sub #:int-mul
- ;; utilities
- #:array-slice #:array-initialize
- ;; intrinsic functions
- #:abs #:acos #:aimag #:aint #:alog #:alog10 #:amax0 #:amax1
- #:amin1 #:amod #:anint #:asin #:atan #:atan2
- #:cabs #:cexp #:fchar #:clog #:cmplx #:conjg #:ccos
- #:csin #:csqrt #:dabs #:dacos #:dasin
- #:datan #:datan2 #:dble #:dcos #:dcosh #:dexp #:dim
- #:dint #:dlog #:dlog10 #:dmax1 #:dmin1 #:dmod
- #:dnint #:dprod #:dsign #:dsin #:dsinh #:dsqrt #:dtan
- #:dtanh #:ffloat #:iabs #:ichar #:idim #:idint
- #:idnint #:ifix #:index #:int #:isign #:le #:len
- #:lge #:lgt #:flog #:log10 #:lt #:max #:max0
- #:max1 #:min0 #:min1 #:nint #:freal
- #:sign #:sngl #:fsqrt
- ;; other functions
- #:d1mach #:r1mach #:i1mach
- ))
+;; (defpackage :f2cl-lib
+;; (:use :cl)
+;; (:documentation "The package holding all symbols used by the fortran to lisp library.")
+;; (:nicknames :fortran-to-lisp-library)
+;; (:export
+;; ;; constants
+;; #:%false% #:%true%
+;; ;; user-settable runtime options
+;; #:*check-array-bounds*
+;; ;; types
+;; #:integer4 #:integer2 #:integer1 #:real8 #:real4 #:complex8 #:complex16
+;; #:array-double-float #:array-single-float #:array-integer4 #:array-strings
+;; #:logical
+;; ;; macros
+;; #:fref #:fset #:with-array-data #:with-multi-array-data
+;; #:f2cl-init-string #:fref-string #:fset-string #:f2cl-set-string
+;; #:f2cl-// #:fstring-/= #:fstring-= #:fstring-> #:fstring->= #:fstring-< #:fstring-<=
+;; #:fortran_comment #:fdo #:f2cl/ #:arithmetic-if #:computed-goto
+;; #:assigned-goto
+;; #:fformat
+;; #:data-implied-do
+;; #:int-add #:int-sub #:int-mul
+;; ;; utilities
+;; #:array-slice #:array-initialize
+;; ;; intrinsic functions
+;; #:abs #:acos #:aimag #:aint #:alog #:alog10 #:amax0 #:amax1
+;; #:amin1 #:amod #:anint #:asin #:atan #:atan2
+;; #:cabs #:cexp #:fchar #:clog #:cmplx #:conjg #:ccos
+;; #:csin #:csqrt #:dabs #:dacos #:dasin
+;; #:datan #:datan2 #:dble #:dcos #:dcosh #:dexp #:dim
+;; #:dint #:dlog #:dlog10 #:dmax1 #:dmin1 #:dmod
+;; #:dnint #:dprod #:dsign #:dsin #:dsinh #:dsqrt #:dtan
+;; #:dtanh #:ffloat #:iabs #:ichar #:idim #:idint
+;; #:idnint #:ifix #:index #:int #:isign #:le #:len
+;; #:lge #:lgt #:flog #:log10 #:lt #:max #:max0
+;; #:max1 #:min0 #:min1 #:nint #:freal
+;; #:sign #:sngl #:fsqrt
+;; ;; other functions
+;; #:d1mach #:r1mach #:i1mach
+;; ))
-(defpackage :fortran-to-lisp
- (:use :cl)
- (:documentation "the package holding all symbols need by the fortran to lisp converter")
- (:nicknames :f2cl)
- (:export
- ;; main routines
- #:f2cl
- #:f2cl-compile
- ))
+;; (defpackage :fortran-to-lisp
+;; (:use :cl)
+;; (:documentation "the package holding all symbols need by the fortran to lisp converter")
+;; (:nicknames :f2cl)
+;; (:export
+;; ;; main routines
+;; #:f2cl
+;; #:f2cl-compile
+;; ))
-(defpackage "QUADPACK"
- (:use "COMMON-LISP" "FORTRAN-TO-LISP")
- (:export
- ;; Do we want to export the core integration routines too?
+;; (defpackage "QUADPACK"
+;; (:use "COMMON-LISP" "FORTRAN-TO-LISP")
+;; (:export
+;; ;; Do we want to export the core integration routines too?
- ;; The basic integrators
- "DQAGE" "DQAGIE" "DQAGPE" "DQAGSE" "DQAWFE" "DQAWOE" "DQAWSE" "DQAWCE"
- ;; Simplified interface routines
- "DQNG" "DQAG" "DQAGS" "DQAGI" "DQAWS" "DQAWC")
- (:documentation "QUADPACK routines for numerical integration"))
+;; ;; The basic integrators
+;; "DQAGE" "DQAGIE" "DQAGPE" "DQAGSE" "DQAWFE" "DQAWOE" "DQAWSE" "DQAWCE"
+;; ;; Simplified interface routines
+;; "DQNG" "DQAG" "DQAGS" "DQAGI" "DQAWS" "DQAWC")
+;; (:documentation "QUADPACK routines for numerical integration"))
-(defpackage "MINPACK"
- (:use "COMMON-LISP" "FORTRAN-TO-LISP")
- (:export
- "LMDIF1")
- (:documentation "MINPACK routines for minimization"))
+;; (defpackage "MINPACK"
+;; (:use "COMMON-LISP" "FORTRAN-TO-LISP")
+;; (:export
+;; "LMDIF1")
+;; (:documentation "MINPACK routines for minimization"))
-(defpackage "MATLISP-LIB"
- (:use "COMMON-LISP" "F2CL")
- (:export
- "ZEROIN")
- (:documentation "Other useful routines"))
+;; (defpackage "MATLISP-LIB"
+;; (:use "COMMON-LISP" "F2CL")
+;; (:export
+;; "ZEROIN")
+;; (:documentation "Other useful routines"))
(defpackage :matlisp
- (:use :common-lisp :fortran-ffi-accessors :blas :lapack :dfftpack :quadpack :matlisp-lib :utilities)
- (:shadow #:real)
- (:export #:*print-matrix*
- ;;
- #:integer4-type #:integer4-array #:allocate-integer4-store
+ (:use :common-lisp :fortran-ffi-accessors :blas :lapack :dfftpack :utilities)
+ (:export #:integer4-type #:integer4-array #:allocate-integer4-store
#:index-type #:index-array #:allocate-index-store #:make-index-store
;;Standard-tensor
#:standard-tensor
@@ -318,170 +320,195 @@
#:tensor-store-ref
#:tensor-ref
;;Type checking
- #:tensor-type-p #:vector-p #:matrix-p #:square-p
-
- ;;Level 1 BLAS
- #:axpy! #:axpy
- #:copy! #:copy
- #:scal! #:scal
- ;;Level 2 BLAS
- #:gemv! #:gemv
- ;;Level 3 BLAS
- #:gemm! #:gemm
- ;;Fortran stuff
- #:blas-copyable-p #:blas-matrix-compatible-p
- #:fortran-op #:fortran-nop #:fortran-snop
- ;;Standard-matrix
- #:standard-matrix
- #:nrows #:ncols #:number-of-elements
- #:head #:row-stride #:col-stride
- #:store #:store-size
- ;;Generic functions on standard-matrix
- #:fill-matrix
- #:row-or-col-vector-p #:row-vector-p #:col-vector-p
- ;;Submatrix ops
- #:row~ #:row
- #:col~ #:col
- #:diag~ #:diag
- #:sub-matrix~ #:sub-matrix
- ;;Transpose
- #:transpose~ #:transpose! #:transpose
- #:ctranspose! #:ctranspose
- ;;Real-double-matrix
- #:real-matrix #:real-matrix-element-type #:real-matrix-store-type
- ;;Complex-double-matrix
- #:complex-matrix #:complex-matrix-element-type #:complex-matrix-store-type #:complex-coerce #:complex-double-float
- ;;Real and imaginary parts
- #:mrealpart~ #:mrealpart #:real
- #:mimagpart~ #:mimagpart #:imag
- ;;
- "CONVERT-TO-LISP-ARRAY"
- "DOT"
- "EIG"
- "EYE"
- "FFT"
- "FFT"
- "GEEV"
- "GELSY!"
- "GELSY"
- "GESV!"
- "GESV"
- "GETRF!"
- "GETRS"
- "GETRS!"
- "HELP"
- "IFFT"
- "JOIN"
- "LOAD-BLAS-&-LAPACK-BINARIES"
- "LOAD-BLAS-&-LAPACK-LIBRARIES"
- "LOAD-MATLISP"
- "LU"
- "M*!"
- "M*"
- "M+!"
- "M+"
- "M-"
- "M.*!"
- "M.*"
- "M.+!"
- "M.+"
- "M.-"
- "M./!"
- "M./"
- "M/!"
- "M/"
- "MACOS"
- "MACOSH"
- "MAKE-COMPLEX-MATRIX"
- "MAKE-COMPLEX-MATRIX-DIM"
- "MAKE-FLOAT-MATRIX"
- "MAKE-FLOAT-MATRIX-ARRAY"
- "MAKE-FLOAT-MATRIX-DIM"
- "MAKE-FLOAT-MATRIX-SEQ"
- "MAKE-FLOAT-MATRIX-SEQ-OF-SEQ"
- "MAKE-FLOAT-MATRIX-SEQUENCE"
- "MAKE-REAL-MATRIX"
- "MAKE-REAL-MATRIX-DIM"
- "MAP-MATRIX!"
- "MAP-MATRIX"
- "MASIN"
- "MASINH"
- "MATAN"
- "MATANH"
- "MATRIX-REF"
- "MCOS"
- "MCOSH"
- "MEXP"
- "MLOG"
- "MLOG10"
- "MREF"
- "MSIN"
- "MSINH"
- "MSQRT"
- "MTAN"
- "MTANH"
- "NCOLS"
- "NORM"
- "ONES"
- "PRINT-ELEMENT"
- "QR"
- "QR!"
- "GEQR!"
- "POTRF!"
- "POTRS!"
- "RAND"
- "RESHAPE!"
- "RESHAPE"
- "SAVE-MATLISP"
- "SEQ"
- "SET-M*!-SWAP-SIZE"
- "SIZE"
- "SQUARE-MATRIX-P"
- "STORE-INDEXING"
- "SUM"
- "SVD"
- "SWAP!"
- "TR"
- "UNLOAD-BLAS-&-LAPACK-LIBRARIES"
- "ZEROS"
- ;; From Quadpack
- "INTEGRATE-QNG"
- "INTEGRATE-QAG"
- "INTEGRATE-QAGS"
- "INTEGRATE-QAGI"
- "INTEGRATE-QAWS"
- "INTEGRATE-QAWC"
- ;; From CPOLY
- "POLYROOTS"
- ;; From TOMS-715
- "M-NORMAL-CDF"
- "M-BESSEL-SCALED-I0" "M-BESSEL-SCALED-I1"
- "M-BESSEL-SCALED-K0" "M-BESSEL-SCALED-K1"
- "M-BESSEL-I0" "M-BESSEL-I1"
- "M-BESSEL-J0" "M-BESSEL-J1"
- "M-BESSEL-K0" "M-BESSEL-K1"
- "M-BESSEL-Y0" "M-BESSEL-Y1"
- "M-DAWSON-INTEGRAL"
- "M-ERF" "M-ERFC" "M-ERFCX"
- "M-GAMMA" "M-LOG-GAMMA"
- "M-BESSEL-SERIES-I"
- "M-BESSEL-SERIES-J"
- "M-BESSEL-SERIES-K"
- "M-BESSEL-SERIES-Y")
+ #:tensor-type-p #:vector-p #:matrix-p #:square-p)
(:documentation "MATLISP routines"))
-(defpackage "MATLISP-USER"
- (:use "COMMON-LISP"
- "MATLISP"
- #+:allegro "EXCL"
- #+:cmu "EXT"
- #+:sbcl "SB-EXT")
- (:shadowing-import-from "MATLISP" "REAL")
- (:documentation "Matlisp user package meant for interacting with matlisp"))
+;; (defpackage :matlisp
+;; (:use :common-lisp :fortran-ffi-accessors :blas :lapack :dfftpack :quadpack :matlisp-lib :utilities)
+;; (:shadow #:real)
+;; (:export #:*print-matrix*
+;; ;;
+;; #:integer4-type #:integer4-array #:allocate-integer4-store
+;; #:index-type #:index-array #:allocate-index-store #:make-index-store
+;; ;;Standard-tensor
+;; #:standard-tensor
+;; #:rank #:dimensions #:number-of-elements
+;; #:head #:strides #:store-size #:store
+;; ;;Sub-tensor
+;; #:sub-tensor
+;; #:parent-tensor
+;; ;;Store indexers
+;; #:store-indexing
+;; #:store-indexing-internal #:store-indexing-vec #:store-indexing-lst
+;; ;;Store accessors
+;; #:tensor-store-ref
+;; #:tensor-ref
+;; ;;Type checking
+;; #:tensor-type-p #:vector-p #:matrix-p #:square-p
+
+;; ;;Level 1 BLAS
+;; #:axpy! #:axpy
+;; #:copy! #:copy
+;; #:scal! #:scal
+;; ;;Level 2 BLAS
+;; #:gemv! #:gemv
+;; ;;Level 3 BLAS
+;; #:gemm! #:gemm
+;; ;;Fortran stuff
+;; #:blas-copyable-p #:blas-matrix-compatible-p
+;; #:fortran-op #:fortran-nop #:fortran-snop
+;; ;;Standard-matrix
+;; #:standard-matrix
+;; #:nrows #:ncols #:number-of-elements
+;; #:head #:row-stride #:col-stride
+;; #:store #:store-size
+;; ;;Generic functions on standard-matrix
+;; #:fill-matrix
+;; #:row-or-col-vector-p #:row-vector-p #:col-vector-p
+;; ;;Submatrix ops
+;; #:row~ #:row
+;; #:col~ #:col
+;; #:diag~ #:diag
+;; #:sub-matrix~ #:sub-matrix
+;; ;;Transpose
+;; #:transpose~ #:transpose! #:transpose
+;; #:ctranspose! #:ctranspose
+;; ;;Real-double-matrix
+;; #:real-matrix #:real-matrix-element-type #:real-matrix-store-type
+;; ;;Complex-double-matrix
+;; #:complex-matrix #:complex-matrix-element-type #:complex-matrix-store-type #:complex-coerce #:complex-double-float
+;; ;;Real and imaginary parts
+;; #:mrealpart~ #:mrealpart #:real
+;; #:mimagpart~ #:mimagpart #:imag
+;; ;;
+;; "CONVERT-TO-LISP-ARRAY"
+;; "DOT"
+;; "EIG"
+;; "EYE"
+;; "FFT"
+;; "FFT"
+;; "GEEV"
+;; "GELSY!"
+;; "GELSY"
+;; "GESV!"
+;; "GESV"
+;; "GETRF!"
+;; "GETRS"
+;; "GETRS!"
+;; "HELP"
+;; "IFFT"
+;; "JOIN"
+;; "LOAD-BLAS-&-LAPACK-BINARIES"
+;; "LOAD-BLAS-&-LAPACK-LIBRARIES"
+;; "LOAD-MATLISP"
+;; "LU"
+;; "M*!"
+;; "M*"
+;; "M+!"
+;; "M+"
+;; "M-"
+;; "M.*!"
+;; "M.*"
+;; "M.+!"
+;; "M.+"
+;; "M.-"
+;; "M./!"
+;; "M./"
+;; "M/!"
+;; "M/"
+;; "MACOS"
+;; "MACOSH"
+;; "MAKE-COMPLEX-MATRIX"
+;; "MAKE-COMPLEX-MATRIX-DIM"
+;; "MAKE-FLOAT-MATRIX"
+;; "MAKE-FLOAT-MATRIX-ARRAY"
+;; "MAKE-FLOAT-MATRIX-DIM"
+;; "MAKE-FLOAT-MATRIX-SEQ"
+;; "MAKE-FLOAT-MATRIX-SEQ-OF-SEQ"
+;; "MAKE-FLOAT-MATRIX-SEQUENCE"
+;; "MAKE-REAL-MATRIX"
+;; "MAKE-REAL-MATRIX-DIM"
+;; "MAP-MATRIX!"
+;; "MAP-MATRIX"
+;; "MASIN"
+;; "MASINH"
+;; "MATAN"
+;; "MATANH"
+;; "MATRIX-REF"
+;; "MCOS"
+;; "MCOSH"
+;; "MEXP"
+;; "MLOG"
+;; "MLOG10"
+;; "MREF"
+;; "MSIN"
+;; "MSINH"
+;; "MSQRT"
+;; "MTAN"
+;; "MTANH"
+;; "NCOLS"
+;; "NORM"
+;; "ONES"
+;; "PRINT-ELEMENT"
+;; "QR"
+;; "QR!"
+;; "GEQR!"
+;; "POTRF!"
+;; "POTRS!"
+;; "RAND"
+;; "RESHAPE!"
+;; "RESHAPE"
+;; "SAVE-MATLISP"
+;; "SEQ"
+;; "SET-M*!-SWAP-SIZE"
+;; "SIZE"
+;; "SQUARE-MATRIX-P"
+;; "STORE-INDEXING"
+;; "SUM"
+;; "SVD"
+;; "SWAP!"
+;; "TR"
+;; "UNLOAD-BLAS-&-LAPACK-LIBRARIES"
+;; "ZEROS"
+;; ;; From Quadpack
+;; "INTEGRATE-QNG"
+;; "INTEGRATE-QAG"
+;; "INTEGRATE-QAGS"
+;; "INTEGRATE-QAGI"
+;; "INTEGRATE-QAWS"
+;; "INTEGRATE-QAWC"
+;; ;; From CPOLY
+;; "POLYROOTS"
+;; ;; From TOMS-715
+;; "M-NORMAL-CDF"
+;; "M-BESSEL-SCALED-I0" "M-BESSEL-SCALED-I1"
+;; "M-BESSEL-SCALED-K0" "M-BESSEL-SCALED-K1"
+;; "M-BESSEL-I0" "M-BESSEL-I1"
+;; "M-BESSEL-J0" "M-BESSEL-J1"
+;; "M-BESSEL-K0" "M-BESSEL-K1"
+;; "M-BESSEL-Y0" "M-BESSEL-Y1"
+;; "M-DAWSON-INTEGRAL"
+;; "M-ERF" "M-ERFC" "M-ERFCX"
+;; "M-GAMMA" "M-LOG-GAMMA"
+;; "M-BESSEL-SERIES-I"
+;; "M-BESSEL-SERIES-J"
+;; "M-BESSEL-SERIES-K"
+;; "M-BESSEL-SERIES-Y")
+;; (:documentation "MATLISP routines"))
+
+
-(in-package "MATLISP")
+;; (defpackage "MATLISP-USER"
+;; (:use "COMMON-LISP"
+;; "MATLISP"
+;; #+:allegro "EXCL"
+;; #+:cmu "EXT"
+;; #+:sbcl "SB-EXT")
+;; (:shadowing-import-from "MATLISP" "REAL")
+;; (:documentation "Matlisp user package meant for interacting with matlisp"))
-;; We've shadowed CL's REAL. Re-establish the real type.
-(deftype real (&optional low high)
- `(cl::real ,low ,high))
+;; (in-package "MATLISP")
+;; ;; We've shadowed CL's REAL. Re-establish the real type.
+;; (deftype real (&optional low high)
+;; `(cl::real ,low ,high))
diff --git a/src/blas-helpers.lisp b/src/blas-helpers.lisp
index 4869c2c..29f2813 100644
--- a/src/blas-helpers.lisp
+++ b/src/blas-helpers.lisp
@@ -1,11 +1,9 @@
(in-package :matlisp)
-(declaim (inline fortran-op))
-(defun fortran-op (op)
+(definline fortran-op (op)
(ecase op (:n "N") (:t "T")))
-(declaim (inline fortran-nop))
-(defun fortran-nop (op)
+(definline fortran-nop (op)
(ecase op (:t "N") (:n "T")))
(defun fortran-snop (sop)
@@ -15,17 +13,17 @@
(t (error "Unrecognised fortran-op."))))
(defun blas-copyable-p (matrix)
- (declare (optimize (safety 0) (speed 3))
- (type (or real-matrix complex-matrix) matrix))
+ (declare (type (or real-matrix complex-matrix) matrix))
(mlet* ((nr (nrows matrix) :type fixnum)
(nc (ncols matrix) :type fixnum)
(rs (row-stride matrix) :type fixnum)
(cs (col-stride matrix) :type fixnum)
(ne (number-of-elements matrix) :type fixnum))
- (cond
- ((or (= nc 1) (= cs (* nr rs))) (values t rs ne))
- ((or (= nr 1) (= rs (* nc cs))) (values t cs ne))
- (t (values nil -1 -1)))))
+ (very-quickly
+ (cond
+ ((or (= nc 1) (= cs (* nr rs))) (values t rs ne))
+ ((or (= nr 1) (= rs (* nc cs))) (values t cs ne))
+ (t (values nil -1 -1))))))
(defun blas-matrix-compatible-p (matrix &optional (op :n))
(declare (optimize (safety 0) (speed 3))
@@ -36,4 +34,4 @@
((= 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 "?")))))
diff --git a/src/blas.lisp b/src/blas.lisp
index 1e34345..8f3e25b 100644
--- a/src/blas.lisp
+++ b/src/blas.lisp
@@ -231,7 +231,7 @@
(n :integer :input)
(dx (* :double-float) :output)
(incx :integer :input)
- (dy (* :double-float :inc))
+ (dy (* :double-float))
(incy :integer :input)
)
diff --git a/src/complex-matrix.lisp b/src/complex-matrix.lisp
index 928d43f..a7bc004 100644
--- a/src/complex-matrix.lisp
+++ b/src/complex-matrix.lisp
@@ -52,7 +52,7 @@
;;
(defmethod initialize-instance ((matrix complex-matrix) &rest initargs)
- (setf (store-size matrix) (/ (length (get-arg :store initargs)) 2))
+ (setf (store-size matrix) (/ (length (getf :store initargs)) 2))
(call-next-method))
;;
diff --git a/src/complex-tensor.lisp b/src/complex-tensor.lisp
index 4a7368a..530aff9 100644
--- a/src/complex-tensor.lisp
+++ b/src/complex-tensor.lisp
@@ -1,4 +1,4 @@
-(in-package :tensor)
+(in-package :matlisp)
(eval-when (load eval compile)
(deftype complex-base-type ()
@@ -14,13 +14,15 @@
'(cl:complex (complex-base-type * *)))
)
;;
-(declaim (inline allocate-complex-store))
-(defun allocate-complex-store (size)
+
+(definline allocate-complex-store (size)
+"(allocate-complex-store size)
+Allocates real storage of size (* SIZE 2).
+Default initial-element = 0d0."
(make-array (* 2 size) :element-type 'complex-base-type
:initial-element (coerce 0 'complex-base-type)))
-(declaim (inline coerce-complex))
-(defun coerce-complex (x)
+(definline coerce-complex (x)
(coerce x 'complex-type))
;;
@@ -34,9 +36,14 @@
()
(:documentation "Sub-tensor class with complex elements."))
+;;Push the counter sub-class name into a hash-table so that we can
+;;refer to it later from class-ignorant functions.
+(setf (gethash 'complex-tensor *sub-tensor-counterclass*) 'complex-sub-tensor
+ (gethash 'complex-sub-tensor *sub-tensor-counterclass*) 'complex-sub-tensor)
+
;;
(defmethod initialize-instance ((tensor complex-tensor) &rest initargs)
- (mlet* ((2*ss (length (get-arg :store initargs)) :type index-type))
+ (mlet* ((2*ss (length (getf initargs :store)) :type index-type))
(unless (evenp 2*ss)
(error "Store is not of even length.
Cannot hold complex numbers."))
@@ -55,7 +62,16 @@ Cannot hold complex numbers."))
(aref (store tensor) (+ (* 2 idx) 1)) (coerce (imagpart value) 'complex-base-type)))
;;
+(defmethod print-element ((tensor complex-tensor)
+ element stream)
+ (let ((realpart (realpart element))
+ (imagpart (imagpart element)))
+ (format stream (if (zerop imagpart)
+ " ~11,4,,,,,'Eg "
+ "#C(~11,4,,,,,'Ee ~11,4,,,,,'Ee)")
+ realpart imagpart)))
+;;
(defun make-complex-tensor (&rest subs)
(let* ((dims (make-index-store subs))
(ss (reduce #'* dims))
diff --git a/src/conditions.lisp b/src/conditions.lisp
index 9fdb937..9b5586b 100644
--- a/src/conditions.lisp
+++ b/src/conditions.lisp
@@ -11,9 +11,36 @@
;;; Error conditions for matlisp
-;;(in-package :matlisp)
-(in-package :tensor)
+(in-package :matlisp)
+;;---------------------------------------------------------------;;
+(define-condition generic-error (error)
+ ((message :reader message :initarg :message :initform "")))
+
+(defmethod print-object ((c generic-error) stream)
+ (format stream (message c)))
+
+;;---------------------------------------------------------------;;
+(define-condition invalid-type (generic-error)
+ ((given-type :reader given :initarg :given)
+ (expected-type :reader expected :initarg :expected))
+ (:documentation "Given an unexpected type."))
+
+(defmethod print-object ((c invalid-type) stream)
+ (format stream "Given object of type ~A, expected ~A.~%" (given c) (expected c))
+ (call-next-method))
+
+;;---------------------------------------------------------------;;
+(define-condition invalid-value (generic-error)
+ ((given-value :reader given :initarg :given)
+ (expected-value :reader expected :initarg :expected))
+ (:documentation "Given an unexpected value."))
+
+(defmethod print-object ((c invalid-value) stream)
+ (format stream "Given object ~A, expected ~A.~%" (given c) (expected c))
+ (call-next-method))
+
+;;---------------------------------------------------------------;;
(define-condition matlisp-error (error)
;;Optional argument for error-handling.
((tensor :reader tensor :initarg :tensor)))
@@ -38,7 +65,6 @@
(:report (lambda (c stream)
(format stream "Store size is ~A, but maximum possible index is ~A." (store-size c) (max-idx c)))))
-
(define-condition tensor-index-out-of-bounds (matlisp-error)
((argument :reader argument :initarg :argument)
(index :reader index :initarg :index)
@@ -60,7 +86,6 @@
(:report (lambda (c stream)
(format stream "Head of the store must be >= 0, initialized with ~A." (head c)))))
-
(define-condition tensor-invalid-dimension-value (matlisp-error)
((argument :reader argument :initarg :argument)
(argument-dimension :reader dimension :initarg :dimension))
@@ -73,4 +98,10 @@
(argument-stride :reader stride :initarg :stride))
(:documentation "Incorrect value for one of the strides of the tensor storage.")
(:report (lambda (c stream)
- (format stream "Stride of argument ~A must be >= 0, initialized with ~A." (argument c) (stride c)))))
\ No newline at end of file
+ (format stream "Stride of argument ~A must be >= 0, initialized with ~A." (argument c) (stride c)))))
+
+(define-condition tensor-cannot-find-sub-class (matlisp-error)
+ ()
+ (:documentation "Cannot find sub-class of the given tensor")
+ (:report (lambda (c stream)
+ (format stream "Cannot find sub-class of the given tensor."))))
diff --git a/src/ffi-cffi-interpreter-specific.lisp b/src/ffi-cffi-interpreter-specific.lisp
index eda8343..c80216d 100644
--- a/src/ffi-cffi-interpreter-specific.lisp
+++ b/src/ffi-cffi-interpreter-specific.lisp
@@ -33,46 +33,6 @@
`(progn
,@body))
-;; Define specialised routines for CMUCL/SBCL
-;; Borrowed from ffi-sbcl/ffi-cmucl.lisp
-#+(or sbcl cmu ccl)
-(declaim (inline vector-data-address))
-#+(or sbcl cmu ccl)
-(defun vector-data-address (vec)
- "Return the physical address of where the actual data of the object
-VEC is stored.
-
- VEC - must be a either a (complex double-float), (complex single-float)
- or a specialized array type in CMU Lisp. This currently means
- VEC is a simple-array of one dimension of one of the following types:
-
- double-float
- single-float
- or a
- system-area-pointer
-
-Returns
- 1 - system area pointer to the actual data"
- (locally
- (declare (optimize (speed 1) (safety 3)))
- ;; It's quite important that the arrays have the write type.
- ;; Otherwise, we will probably get the address of the data wrong,
- ;; and then foreign function could be scribbling over who knows
- ;; where!
- ;;
- (check-type vec matlisp-specialized-array))
- (locally
- (declare (type matlisp-specialized-array vec)
- (optimize (speed 3) (safety 0) (space 0)))
- ;;vec is either a simple-array or a system-area-pointer itself.
- (if (typep vec '(simple-array * (*)))
- #+sbcl (sb-sys:vector-sap vec)
- #+cmu (system:vector-sap vec)
- #+ccl (let ((addr-vec (ccl:%null-ptr)))
- (declare (type ccl:macptr addr-vec))
- (ccl::%vect-data-to-macptr vec addr-vec))
- vec)))
-
(defmacro without-gcing (&body body)
(append
#+sbcl `(sb-sys::without-gcing)
@@ -80,6 +40,71 @@ Returns
#+ccl `(ccl::without-gcing)
body))
+(defmacro vector-sap-interpreter-specific (vec)
+ #+sbcl `(sb-sys:vector-sap ,vec)
+ #+cmu `(system:vector-sap ,vec)
+ #+ccl (let ((addr-vec (gensym)))
+ `(let ((,addr-vec (ccl:%null-ptr)))
+ (declare (type ccl:macptr ,addr-vec))
+ (ccl::%vect-data-to-macptr ,vec ,addr-vec))))
+
+(defmacro vector-data-address (vec)
+"
+Creates lisp code to return the physical address of where the actual
+data of the object VEC is stored.
+
+VEC - must be a either a (complex double-float), (complex single-float)
+or a specialized array type in CMU Lisp. This currently means
+VEC is a simple-array of one dimension of one of the following types:
+
+ double-float
+ single-float
+ or a
+ system-area-pointer
+
+Returns
+ 1 - system area pointer to the actual data
+"
+ `(progn
+ (with-optimization (:speed 1 :safety 3)
+ ;; It's quite important that the arrays have the right type.
+ ;; Otherwise, we will probably get the address of the data wrong,
+ ;; and then foreign function could be scribbling over who knows
+ ;; where!
+ (check-type ,vec matlisp-specialized-array))
+ (with-optimization (:speed 3 :safety 0 :space 0)
+ ;;vec is either a simple-array or a system-area-pointer itself.
+ (declare (type matlisp-specialized-array ,vec))
+ (if (typep ,vec '(simple-array * (*)))
+ (vector-sap-interpreter-specific ,vec)
+ vec))))
+
+;; #+(or sbcl cmu ccl)
+;; (progn
+;; (declaim (inline vector-data-address))
+
+;; (defun vector-data-address (vec)
+
+;; (locally
+;; (declare (optimize (speed 1) (safety 3)))
+;; ;; It's quite important that the arrays have the write type.
+;; ;; Otherwise, we will probably get the address of the data wrong,
+;; ;; and then foreign function could be scribbling over who knows
+;; ;; where!
+;; ;;
+;; (check-type vec matlisp-specialized-array))
+;; (locally
+;; (declare (type matlisp-specialized-array vec)
+;; (optimize (speed 3) (safety 0) (space 0)))
+;; ;;vec is either a simple-array or a system-area-pointer itself.
+;; (if (typep vec '(simple-array * (*)))
+;; #+sbcl (sb-sys:vector-sap vec)
+;; #+cmu (system:vector-sap vec)
+;; #+ccl (let ((addr-vec (ccl:%null-ptr)))
+;; (declare (type ccl:macptr addr-vec))
+;; (ccl::%vect-data-to-macptr vec addr-vec))
+;; vec))))
+
#+(or sbcl cmu ccl)
(defmacro with-vector-data-addresses (vlist &body body)
"
@@ -104,8 +129,10 @@ Returns
(without-gcing
(let (,@(mapcar #'(lambda (lst)
(destructuring-bind (addr-var var &key inc-type inc) lst
- `(,addr-var ,@(if inc
- `((inc-sap (vector-data-address ,var) ,inc-type ,inc))
- `((vector-data-address ,var))))))
+ `(,addr-var ,(recursive-append
+ (when inc
+ `(if (> ,inc 0)
+ (inc-sap (vector-data-address ,var) ,inc-type ,inc)))
+ `(vector-data-address ,var)))))
vlist))
,@body))))
diff --git a/src/ffi-cffi.lisp b/src/ffi-cffi.lisp
index 8dac403..3311dc6 100644
--- a/src/ffi-cffi.lisp
+++ b/src/ffi-cffi.lisp
@@ -9,17 +9,16 @@
;; Callbacks : (:function <output-type> {(params)})
-(in-package "FORTRAN-FFI-ACCESSORS")
+(in-package :ffi)
-(defconstant +ffi-types+ '(:single-float :double-float
- :complex-single-float :complex-double-float
- :integer :long
- :string
- :callback))
+(define-constant +ffi-types+ '(:single-float :double-float
+ :complex-single-float :complex-double-float
+ :integer :long
+ :string
+ :callback))
-(defconstant +ffi-styles+ '(:input :input-value :workspace
- ;;
- :input-output :output :workspace-output))
+(define-constant +ffi-styles+ '(:input :input-value :workspace
+ :input-output :output :workspace-output))
;; Create objects on the heap and run some stuff.
@@ -461,7 +460,7 @@
(setq ffi-var (scat "ADDR-" var))
(nconsc array-vars `((,ffi-var ,var)))
;;
- (when-let (arg (get-arg :inc type))
+ (when-let (arg (getf type :inc))
(nconsc defun-keyword-args
`((,arg 0)))
(nconc (car (last array-vars)) `(:inc-type ,(cadr type) :inc ,arg))))
@@ -581,7 +580,7 @@
(setq ffi-var (scat "ADDR-" var))
(setq func-var var)
(nconsc array-vars `((,func-var (make-foreign-vector :pointer ,ffi-var :type ,(second (->cffi-type type))
- :size ,(if-let (size (get-arg :size type))
+ :size ,(if-let (size (getf type :size))
size
1))))))
;;
@@ -666,15 +665,17 @@
;; Only support types that we currently use.
(deftype matlisp-specialized-array ()
`(or (simple-array double-float (*))
- ;;
(simple-array single-float (*))
;;
+ (simple-array (signed-byte 64) *)
(simple-array (signed-byte 32) *)
(simple-array (signed-byte 16) *)
- (simple-array (signed-byte 8) *)
+ (simple-array (signed-byte 8) *)
+ ;;
+ (simple-array (unsigned-byte 64) *)
(simple-array (unsigned-byte 32) *)
(simple-array (unsigned-byte 16) *)
- (simple-array (unsigned-byte 8) *)
+ (simple-array (unsigned-byte 8) *)
;;
cffi:foreign-pointer))
diff --git a/src/print.lisp b/src/print.lisp
index c7ccaae..06d2d4d 100644
--- a/src/print.lisp
+++ b/src/print.lisp
@@ -85,16 +85,15 @@
(in-package "MATLISP")
-#+nil (export '(*print-matrix*
- print-element))
-
-(defvar *print-matrix*
+(defvar *print-max-len*
5
- "Maximum number of columns and/or rows to print. Set this to NIL to
- print no elements (same as *PRINT-ARRAY* set to NIL). Set this to T
- to print all elements of the matrix.
+ "Maximum number of elements in any particular argument to print.
+ Set this to NIL to print no elements. Set this to T
+ to print all elements.")
- This is useful for preventing printing of huge matrices by accident.")
+(defvar *print-max-args* 5
+ "Maximum number of arguments of the tensor to print.
+ Set this to NIL to print none; to T to print all of them.")
(defun set-print-limits-for-matrix (n m)
(declare (type fixnum n m))
@@ -110,50 +109,38 @@
Required that *PRINT-MATRIX* be T,NIL or a positive INTEGER,
but got *PRINT-MATRIX* of type ~a"
(type-of *print-matrix*))))))
-
-
-(defgeneric print-element (matrix
- element
- stream)
- (:documentation "
- Syntax
- ======
- (PRINT-ELEMENT matrix element stream)
-
- Purpose
- =======
- This generic function is specialized to MATRIX to
- print ELEMENT to STREAM. Called by PRINT-MATRIX
- to format a matrix to STREAM.
-"))
-
-(defmethod print-element ((matrix standard-matrix)
- element
- stream)
- (format stream "~a" element))
-
-(defmethod print-element ((matrix real-matrix)
- element
- stream)
- (format stream "~11,5,,,,,'Eg" element))
-(defmethod print-element ((matrix complex-matrix)
- element
- stream)
-
- (let ((realpart (realpart element))
- (imagpart (imagpart element)))
-
- (if (zerop imagpart)
- (format stream " ~11,4,,,,,'Eg " realpart)
- (format stream "#C(~11,4,,,,,'Ee ~11,4,,,,,'Ee)"
- realpart
- imagpart))))
-
-(defvar *matrix-indent* 0
+(defvar *print-indent* 0
"Determines how many spaces will be printed before each row
of a matrix (default 0)")
+(defun print-tensor (tensor stream)
+ (let ((rank (rank tensor))
+ (dims (dimensions tensor)))
+ (labels ((two-print (tensor subs)
+ (dotimes (i (aref dims 0))
+ (dotimes (j (aref dims 1))
+ (format stream "~A~,4T" (apply #'tensor-ref (list tensor (append (list i j) subs)))))
+ (format stream "~%")))
+ (rec-print (tensor idx subs)
+ (if (> idx 1)
+ (dotimes (i (aref dims idx))
+ (rec-print tensor (1- idx) (cons i subs)))
+ (progn
+ (format stream "~A~%" (append (list '\: '\:) subs))
+ (two-print tensor subs)
+ (format stream "~%")))))
+ (format stream "~A ~A~%" rank dims)
+ (case rank
+ (1
+ (dotimes (i (aref dims 0))
+ (format stream "~A~,4T" (tensor-ref tensor `(,i))))
+ (format stream "~%"))
+ (2
+ (two-print tensor nil))
+ (t
+ (rec-print tensor (- rank 1) nil))))))
+
(defun print-matrix (matrix stream)
(with-slots (number-of-rows number-of-cols)
matrix
@@ -208,29 +195,34 @@ but got *PRINT-MATRIX* of type ~a"
(defmethod print-object ((matrix standard-matrix) stream)
(print-unreadable-object (matrix stream :type t :identity (not *print-matrix*))
- (when *print-matrix*
+ (when *print-max*
(print-matrix matrix stream))))
-#+nil
-(defmethod print-object ((matrix standard-matrix) stream)
- (format stream "#<~a" (type-of matrix))
- (if *print-matrix*
- (print-matrix matrix stream)
- (format stream "{~x}" (kernel:get-lisp-obj-address matrix)))
- (format stream " >~%"))
-
-#+nil
-(defmethod print-object ((matrix real-matrix) stream)
- (format stream "#<~a" (type-of matrix))
- (if *print-matrix*
- (print-matrix matrix stream)
- (format stream "{~x}" (kernel:get-lisp-obj-address matrix)))
- (format stream " >~%"))
-#+nil
-(defmethod print-object ((matrix complex-matrix) stream)
- (format stream "#<~a" (type-of matrix))
- (if *print-matrix*
- (print-matrix matrix stream)
- (format stream "{~x}" (kernel:get-lisp-obj-address matrix)))
- (format stream " >~%"))
+(defmethod print-object ((tensor standard-tensor) stream)
+ (print-unreadable-object (tensor stream :type t)
+ (let ((rank (rank tensor))
+ (dims (dimensions tensor)))
+ (labels ((two-print (tensor subs)
+ (dotimes (i (aref dims 0))
+ (dotimes (j (aref dims 1))
+ (format stream "~A~,4T" (apply #'tensor-ref (list tensor (append (list i j) subs)))))
+ (format stream "~%")))
+ (rec-print (tensor idx subs)
+ (if (> idx 1)
+ (dotimes (i (aref dims idx))
+ (rec-print tensor (1- idx) (cons i subs)))
+ (progn
+ (format stream "~A~%" (append (list '\: '\:) subs))
+ (two-print tensor subs)
+ (format stream "~%")))))
+ (format stream "~A ~A~%" rank dims)
+ (case rank
+ (1
+ (dotimes (i (aref dims 0))
+ (format stream "~A~,4T" (tensor-ref tensor `(,i))))
+ (format stream "~%"))
+ (2
+ (two-print tensor nil))
+ (t
+ (rec-print tensor (- rank 1) nil)))))))
\ No newline at end of file
diff --git a/src/real-matrix.lisp b/src/real-matrix.lisp
index c02b9cf..ec9199b 100644
--- a/src/real-matrix.lisp
+++ b/src/real-matrix.lisp
@@ -27,7 +27,7 @@
;;
(defmethod initialize-instance ((matrix real-matrix) &rest initargs)
- (setf (store-size matrix) (length (get-arg :store initargs)))
+ (setf (store-size matrix) (length (getf :store initargs)))
(call-next-method))
;;
diff --git a/src/real-tensor.lisp b/src/real-tensor.lisp
index d9e17b1..ff36e54 100644
--- a/src/real-tensor.lisp
+++ b/src/real-tensor.lisp
@@ -1,4 +1,4 @@
-(in-package :tensor)
+(in-package :matlisp)
(eval-when (load eval compile)
(deftype real-type ()
@@ -11,13 +11,11 @@
)
;;
-(declaim (inline allocate-real-store))
(make-array-allocator allocate-real-store 'real-type 0d0
"(allocate-real-store size [initial-element])
Allocates real storage. Default initial-element = 0d0.")
-(declaim (inline coerce-real))
-(defun coerce-real (x)
+(definline coerce-real (x)
(coerce x 'real-type))
;;
@@ -27,13 +25,18 @@ Allocates real storage. Default initial-element = 0d0.")
:type (real-array *)))
(:documentation "Tensor class with real elements."))
-(defclass real-sub-tensor (real-tensor sub-tensor)
+(defclass real-sub-tensor (real-tensor standard-sub-tensor)
()
(:documentation "Sub-tensor class with real elements."))
+;;Push the counter sub-class name into a hash-table so that we can
+;;refer to it later from class-ignorant functions.
+(setf (gethash 'real-tensor *sub-tensor-counterclass*) 'real-sub-tensor
+ (gethash 'real-sub-tensor *sub-tensor-counterclass*) 'real-sub-tensor)
+
;;
(defmethod initialize-instance ((tensor real-tensor) &rest initargs)
- (setf (store-size tensor) (length (get-arg :store initargs)))
+ (setf (store-size tensor) (length (getf initargs :store)))
(call-next-method))
;;
@@ -44,44 +47,14 @@ Allocates real storage. Default initial-element = 0d0.")
(setf (aref (store tensor) idx) (coerce-real value)))
;;
+(defmethod print-element ((tensor real-tensor)
+ element stream)
+ (format stream "~11,5,,,,,'Eg" element))
+
+;;
(defun make-real-tensor (&rest subs)
(let* ((dims (make-index-store subs))
(ss (reduce #'* dims))
(store (allocate-real-store ss)))
(make-instance 'real-tensor :store store :dimensions dims)))
-
-;;
-
-(defun collapse~ (tensor &rest subs)
- (declare (type standard-tensor tensor))
- (mlet* (((hd rank dims stds sto) (slot-values tensor '(head rank dimensions strides store))
- :type (index-type index-type (index-array *) (index-array *) (real-array *))))
- (labels ((parse-sub (rsubs i ndims nstds hd)
- (let ((val (car rsubs)))
- (cond
- ((< i 0)
- (unless (null val)
- (error "Too many subscripts for a tensor of rank ~A" rank))
- (values ndims nstds hd))
- ;;
- ((null val)
- (error "Too few subscripts for a tensor of rank ~A" rank))
- ;;
- ((eq val t)
- (parse-sub (cdr rsubs) (1- i) (cons (aref dims i) ndims) (cons (aref stds i) nstds) hd))
- ;;
- (t
- (unless (< -1 val (aref dims i))
- (error "Requested index ~A for argument ~A is out of bounds.
-Tensor only has dimension ~A for the ~A argument." val i (aref dims i) i))
- (parse-sub (cdr rsubs) (1- i) ndims nstds (+ hd (* val (aref stds i)))))))))
- (multiple-value-bind (ndims nstds nhd) (parse-sub (reverse subs) (- rank 1) nil nil hd)
- (if (null ndims)
- (apply #'tensor-ref (cons tensor subs))
- (make-instance (typecase tensor
- (real-tensor 'real-sub-tensor)
- (complex-tensor 'complex-sub-tensor))
- :store sto :dimensions (make-index-store ndims)
- :strides (make-index-store nstds) :head nhd
- :parent-tensor tensor))))))
\ No newline at end of file
diff --git a/src/standard-tensor.lisp b/src/standard-tensor.lisp
index c1b4138..d431c32 100644
--- a/src/standard-tensor.lisp
+++ b/src/standard-tensor.lisp
@@ -1,7 +1,4 @@
-(defpackage :tensor
- (:use :cl :utilities))
-
-(in-package :tensor)
+(in-package :matlisp)
;;
(eval-when (load eval compile)
@@ -12,19 +9,23 @@
;;
(deftype index-type ()
- 'fixnum)
+ '(signed-byte 64))
(deftype index-array (size)
`(simple-array index-type (,size)))
)
(declaim (inline allocate-integer4-store))
(make-array-allocator allocate-integer4-store 'integer4-type 0
-"(allocate-int32-store size [initial-element])
-Allocates integer-32 storage. Default initial-element = 0.")
+"
+(allocate-int32-store size [initial-element])
+Allocates integer-32 storage. Default initial-element = 0.
+")
(make-array-allocator allocate-index-store 'index-type 0
-"(allocate-index-store size [initial-element])
-Allocates index storage. Default initial-element = 0.")
+"
+(allocate-index-store size [initial-element])
+Allocates index storage. Default initial-element = 0.
+")
(defun make-index-store (contents)
@@ -33,24 +34,25 @@ Allocates index storage. Default initial-element = 0.")
:initial-contents contents)))
;;
-(defun store-indexing-internal (idx strides &optional (hd (the index-type 0)))
- "No explicit error checking, meant to be used internally.
- Returns
-
- length(strides)
- __
- hd + \ stride * idx
- /_ i i
- i = 0
-
- "
+(defun store-indexing-internal (idx hd strides)
+"
+No explicit error checking, meant to be used internally.
+Returns the sum:
+
+ length(strides)
+ __
+hd + \ stride * idx
+ /_ i i
+ i = 0
+
+"
(declare (optimize (safety 0) (speed 3))
(type index-type hd)
(type (index-array *) idx strides))
(let ((rank (length strides)))
(declare (type index-type rank))
- (the index-type
- (do ((i 0 (+ i 1))
+ (the index-type
+ (do ((i 0 (+ i 1))
(sto-idx (the index-type hd) (the index-type
(+ sto-idx
(the index-type
@@ -58,21 +60,22 @@ Allocates index storage. Default initial-element = 0.")
(aref idx i))
(the index-type
(aref strides i))))))))
- ((= i rank) sto-idx)))))
+ ((= i rank) sto-idx)
+ (declare (type index-type i sto-idx))))))
-(defun store-indexing-vec (idx strides dims &optional (hd (the index-type 0)))
- "
- Returns
+(defun store-indexing-vec (idx hd strides dims)
+"
+Returns the sum:
- length(strides)
- __
- hd + \ stride * idx
- /_ i i
- i = 0
+ length(strides)
+ __
+hd + \ stride * idx
+ /_ i i
+ i = 0
- "
+"
(declare (type index-type hd)
- (type (index-array *) idx strides))
+ (type (index-array *) idx strides dims))
(let ((rank (length strides)))
(declare (type index-type rank))
(if (not (= rank (length idx)))
@@ -92,22 +95,23 @@ Allocates index storage. Default initial-element = 0.")
(if (< -1 cidx (aref dims i))
cidx
(error 'tensor-index-out-of-bounds :argument i :index cidx :dimension (aref dims i)))))))))))
- ((= i rank) sto-idx))))))
+ ((= i rank) sto-idx)
+ (declare (type index-type i sto-idx)))))))
-(defun store-indexing-lst (idx strides dims &optional (hd (the index-type 0)))
- "
- Returns
+(defun store-indexing-lst (idx hd strides dims)
+"
+Returns the sum
- length(strides)
- __
- hd + \ stride * idx
- /_ i i
- i = 0
+ length(strides)
+ __
+hd + \ stride * idx
+ /_ i i
+ i = 0
- idx here is a list.
- "
+idx here is a list.
+"
(declare (type index-type hd)
- (type (index-array *) strides)
+ (type (index-array *) strides dims)
(type cons idx))
(let ((rank (length strides)))
(declare (type index-type rank))
@@ -123,7 +127,7 @@ Allocates index storage. Default initial-element = 0.")
(if (< -1 cidx (aref dims i))
...
[truncated message content] |
|
From: Akshay S. <ak...@us...> - 2012-05-29 18:14:20
|
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, tensor has been updated
via 1d9d45b7aac05a33ccb3cae5428a08cda19d00ce (commit)
via b7491a45a621cf8b4d5c266ec39a8850172d2f02 (commit)
via f9871bd640672b300b2b1790671f16694a67c184 (commit)
via a1fba66076d96b9abe83d35ac2780be0fc363e1c (commit)
via d19ddc6fed6d674cc555e2911c3a8a44334a0c20 (commit)
from 365629a9b8ca20f729635ec74047904caca9c8d9 (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 1d9d45b7aac05a33ccb3cae5428a08cda19d00ce
Author: Akshay Srinivasan <aks...@gm...>
Date: Tue May 29 22:55:53 2012 +0530
Added Mark-Kantrovitz' infix package - stolen from femlisp.
diff --git a/infix/infix.asd b/infix/infix.asd
new file mode 100644
index 0000000..1730a75
--- /dev/null
+++ b/infix/infix.asd
@@ -0,0 +1,7 @@
+;;;; -*- Mode: Lisp; Package: User; -*-
+
+(defpackage #:infix-system (:use #:asdf #:cl))
+(in-package #:infix-system)
+
+(defsystem infix
+ :components ((:file "src")))
diff --git a/infix/src.lisp b/infix/src.lisp
new file mode 100644
index 0000000..45de827
--- /dev/null
+++ b/infix/src.lisp
@@ -0,0 +1,1102 @@
+;;; Wed Jan 18 13:13:59 1995 by Mark Kantrowitz <mk...@FL...>
+;;; infix.cl -- 40545 bytes
+
+;;; **************************************************************************
+;;; Infix ********************************************************************
+;;; **************************************************************************
+;;;
+;;; This is an implementation of an infix reader macro. It should run in any
+;;; valid Common Lisp and has been tested in Allegro CL 4.1, Lucid CL 4.0.1,
+;;; MCL 2.0 and CMU CL. It allows the user to type arithmetic expressions in
+;;; the traditional way (e.g., 1+2) when writing Lisp programs instead of
+;;; using the normal Lisp syntax (e.g., (+ 1 2)). It is not intended to be a
+;;; full replacement for the normal Lisp syntax. If you want a more complete
+;;; alternate syntax for Lisp, get a copy Apple's MLisp or Pratt's CGOL.
+;;;
+;;; Although similar in concept to the Symbolics infix reader (#<DIAMOND>),
+;;; no real effort has been made to ensure compatibility beyond coverage
+;;; of at least the same set of basic arithmetic operators. There are several
+;;; differences in the syntax beyond just the choice of #I as the macro
+;;; character. (Our syntax is a little bit more C-like than the Symbolics
+;;; macro in addition to some more subtle differences.)
+;;;
+;;; We initially chose $ as a macro character because of its association
+;;; with mathematics in LaTeX, but unfortunately that character is already
+;;; used in MCL. We switched to #I() because it was one of the few options
+;;; remaining.
+;;;
+;;; Written by Mark Kantrowitz, School of Computer Science,
+;;; Carnegie Mellon University, March 1993.
+;;;
+;;; Copyright (c) 1993 by Mark Kantrowitz. All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted, so long as the following
+;;; conditions are met:
+;;; o no fees or compensation are charged for use, copies,
+;;; distribution or access to this software
+;;; o this copyright notice is included intact.
+;;; This software is made available AS IS, and no warranty is made about
+;;; the software or its performance.
+;;;
+;;; In no event will the author(s) or their institutions be liable to you for
+;;; damages, including lost profits, lost monies, or other special, incidental
+;;; or consequential damages, arising out of or in connection with the use or
+;;; inability to use (including but not limited to loss of data or data being
+;;; rendered inaccurate or losses sustained by third parties or a failure of
+;;; the program to operate as documented) the program, or for any claim by
+;;; any other party, whether in an action of contract, negligence, or
+;;; other tortious action.
+;;;
+;;; Please send bug reports, comments and suggestions to mk...@cs....
+;;;
+;;; The current version of this software and a variety of related utilities
+;;; may be obtained from the Lisp Repository by anonymous ftp
+;;; from ftp.cs.cmu.edu [128.2.206.173] in the directory
+;;; user/ai/lang/lisp/code/syntax/infix/
+;;; If your site runs the Andrew File System, you can cd to the AFS directory
+;;; /afs/cs.cmu.edu/project/ai-repository/ai/lang/lisp/code/syntax/infix/
+;;;
+;;; If you wish to be added to the Lis...@cs... mailing list,
+;;; send email to Lis...@cs... with your name, email
+;;; address, and affiliation. This mailing list is primarily for
+;;; notification about major updates, bug fixes, and additions to the Lisp
+;;; Utilities Repository. The mailing list is intended to have low traffic.
+;;;
+
+;;; ********************************
+;;; Documentation ******************
+;;; ********************************
+;;;
+;;; Syntax:
+;;;
+;;; Begin the reader macro with #I( and end it with ). For example,
+;;; #I( x^^2 + y^^2 )
+;;; is equivalent to the Lisp form
+;;; (+ (expt x 2) (expt y 2))
+;;; but much easier to read according to some folks.
+;;;
+;;; If you want to see the expansion, type a quote before the #I form
+;;; at the Lisp prompt:
+;;; > '#I(if x<y<=z then f(x)=x^^2+y^^2 else f(x)=x^^2-y^^2)
+;;; (IF (AND (< X Y) (<= Y Z))
+;;; (SETF (F X) (+ (EXPT X 2) (EXPT Y 2)))
+;;; (SETF (F X) (- (EXPT X 2) (EXPT Y 2))))
+;;;
+;;;
+;;; Operators:
+;;;
+;;; NOTE: == is equality, = is assignment (C-style).
+;;;
+;;; \ quoting character: x\-y --> x-y
+;;; ! lisp escape !(foo bar) --> (foo bar)
+;;; ; comment
+;;; x = y assignment (setf x y)
+;;; x += y increment (incf x y)
+;;; x -= y decrement (decf x y)
+;;; x *= y multiply and store (setf x (* x y))
+;;; x /= y divide and store (setf x (/ x y))
+;;; x|y bitwise logical inclusive or (logior x y)
+;;; x^y bitwise logical exclusive or (logxor x y)
+;;; x&y bitwise logical and (logand x y)
+;;; x<<y left shift (ash x y)
+;;; x>>y right shift (ash x (- y))
+;;; ~x ones complement (unary) (lognot x)
+;;; x and y conjunction (and x y)
+;;; x && y conjunction (and x y)
+;;; x or y disjunction (or x y)
+;;; x || y disjunction (or x y)
+;;; not x negation (not x)
+;;; x^^y exponentiation (expt x y)
+;;; x,y sequence (progn x y)
+;;; (x,y) sequence (progn x y)
+;;; also parenthesis (x+y)/z --> (/ (+ x y) z)
+;;; f(x,y) functions (f x y)
+;;; a[i,j] array reference (aref a i j)
+;;; x+y x*y arithmetic (+ x y) (* x y)
+;;; x-y x/y arithmetic (- x y) (/ x y)
+;;; -y value negation (- y)
+;;; x % y remainder (mod x y)
+;;; x<y x>y inequalities (< x y) (> x y)
+;;; x <= y x >= y inequalities (<= x y) (>= x y)
+;;; x == y equality (= x y)
+;;; x != y equality (not (= x y))
+;;; if p then q conditional (when p q)
+;;; if p then q else r conditional (if p q r)
+;;;
+
+;;; Precedence:
+;;;
+;;; The following precedence conventions are obeyed by the infix operators:
+;;; [ ( !
+;;; ^^
+;;; ~
+;;; * / %
+;;; + -
+;;; << >>
+;;; < == > <= != >=
+;;; &
+;;; ^
+;;; |
+;;; not
+;;; and
+;;; or
+;;; = += -= *= /=
+;;; ,
+;;; if
+;;; then else
+;;; ] )
+;;;
+;;; Note that logical negation has lower precedence than numeric comparison
+;;; so that "not a<b" becomes (not (< a b)), which is different from the
+;;; C precedence conventions. You can change the precedence conventions by
+;;; modifying the value of the variable *operator-ordering*.
+;;;
+
+;;; ********************************
+;;; To Do **************************
+;;; ********************************
+;;;
+;;; Write some more test cases.
+;;; Write some more syntactic optimizations.
+;;; Would really like ~x to be (not x), but need it for (lognot x).
+;;; Support for multiple languages, such as a Prolog parser, a
+;;; strictly C compatible parser, etc.
+
+;;; Create a more declarative format, where there is one big table of
+;;; operators with all the info on them, and also NOT have the list of
+;;; operators in the comment, where they are likely to become wrong when
+;;; changes are made to the code. For example, something like:
+
+;; (define-infix-operators
+;; ([ 30 :matchfix aref :end ])
+;; (* 20 :infix * )
+;; (+ 10 :infix + :prefix + )
+;; (& 10 :infix and )
+;; (+= 10 :infix #'+=-operator )
+;; ...)
+
+
+;;; ********************************
+;;; Change Log *********************
+;;; ********************************
+;;;
+;;; 9-MAR-93 mk Created
+;;; 12-MAR-93 mk Fixed defpackage form for Lucid.
+;;; 1.1:
+;;; 14-OCT-93 mk Changed macro character from #$ to #I(). Suggested by
+;;; Scott McKay.
+;;; 1.2:
+;;; 18-JAN-95 norvig Added *print-infix-copyright*, string->prefix, support
+;;; for #I"..." in addition to #i(...) which lets one
+;;; type #i"a|b" which doesn't confuse editors that aren't
+;;; |-aware. Also added := as a synonym for =, so that
+;;; '#i"car(a) := b" yields (SETF (CAR A) B).
+;;;
+;;; 1.3:
+;;; 28-JUN-96 mk Modified infix reader to allow whitespace between the #I
+;;; and the start of the expression.
+
+
+
+;;; ********************************
+;;; Implementation Notes ***********
+;;; ********************************
+;;;
+;;; Initially we tried implementing everything within the Lisp reader,
+;;; but found this to not be workable. Parameters had to be passed in
+;;; global variables, and some of the processing turned out to be
+;;; indelible, so it wasn't possible to use any kind of lookahead.
+;;; Center-embedded constructions were also a problem, due to the lack
+;;; of an explicit stack.
+;;;
+;;; So we took another tack, that used below. The #I macro binds the
+;;; *readtable* to a special readtable, which is used solely for tokenization
+;;; of the input. Then the problem is how to correctly parenthesize the input.
+;;; We do that with what is essentially a recursive-descent parser. An
+;;; expression is either a prefix operator followed by an expression, or an
+;;; expression followed by an infix operator followed by an expression. When
+;;; the latter expression is complex, the problem becomes a little tricky.
+;;; For example, suppose we have
+;;; exp1 op1 exp2 op2
+;;; We need to know whether to parenthesize it as
+;;; (exp1 op1 exp2) op2
+;;; or as
+;;; exp1 op1 (exp2 op2 ...)
+;;; The second case occurs either when op2 has precedence over op1 (e.g.,
+;;; * has precedence over +) or op2 and op1 are the same right-associative
+;;; operator (e.g., exponentiation). Thus the algorithm is as follows:
+;;; When we see op1, we want to gobble up exp2 op2 exp3 op3 ... opn expn+1
+;;; into an expression where op2 through opn all have higher precedence
+;;; than op1 (or are the same right-associative operator), and opn+1 doesn't.
+;;; This algorithm is implemented by the GATHER-SUPERIORS function.
+;;;
+;;; Because + and - are implemented in the infix readtable as terminating
+;;; macro cahracters, the exponentiation version of Lisp number syntax
+;;; 1e-3 == 0.001
+;;; doesn't work correctly -- it parses it as (- 1e 3). So we add a little
+;;; cleverness to GATHER-SUPERIORS to detect when the tokenizer goofed.
+;;; Since this requires the ability to lookahead two tokens, we use a
+;;; stack to implement the lookahead in PEEK-TOKEN and READ-TOKEN.
+;;;
+;;; Finally, the expression returned by GATHER-SUPERIORS sometimes needs to
+;;; be cleaned up a bit. For example, parsing a<b<c would normally return
+;;; (< (< a b) c), which obviously isn't correct. So POST-PROCESS-EXPRESSION
+;;; detects this and similar cases, replacing the expression with (< a b c).
+;;; For cases like a<b<=c, it replaces it with (and (< a b) (<= b c)).
+;;;
+
+;;; ********************************
+;;; Package Cruft ******************
+;;; ********************************
+
+(defpackage #:infix (:use #-:lucid #:common-lisp
+ #+:lucid "LISP" #+:lucid "LUCID-COMMON-LISP")
+ (:export #:test-infix #:string->prefix))
+
+(in-package #:infix)
+
+(pushnew :infix *features*)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *version* "1.3 28-JUN-96")
+ (defparameter *print-infix-copyright* t
+ "If non-NIL, prints a copyright notice upon loading this file.")
+
+ (defun infix-copyright (&optional (stream *standard-output*))
+ "Prints an INFIX copyright notice and header upon startup."
+ (format stream "~%;;; ~V,,,'*A" 73 "*")
+ (format stream "~%;;; Infix notation for Common Lisp.")
+ (format stream "~%;;; Version ~A." *version*)
+ (format stream "~%;;; Written by Mark Kantrowitz, ~
+ CMU School of Computer Science.")
+ (format stream "~%;;; Copyright (c) 1993-95. All rights reserved.")
+ (format stream "~%;;; May be freely redistributed, provided this ~
+ notice is left intact.")
+ (format stream "~%;;; This software is made available AS IS, without ~
+ any warranty.")
+ (format stream "~%;;; ~V,,,'*A~%" 73 "*")
+ (force-output stream))
+
+ ;; What this means is you can either turn off the copyright notice
+ ;; by setting the parameter, or you can turn it off by including
+ ;; (setf (get :infix :dont-print-copyright) t) in your lisp init file.
+ (when (and *print-infix-copyright*
+ (not (get :infix :dont-print-copyright)))
+ (infix-copyright)))
+
+;;; ********************************
+;;; Readtable **********************
+;;; ********************************
+
+(defparameter *infix-readtable* (copy-readtable nil))
+(defparameter *normal-readtable* (copy-readtable nil))
+
+(defmacro infix-error (format-string &rest args)
+ `(let ((*readtable* *normal-readtable*))
+ (error ,format-string ,@args)))
+
+(defun infix-reader (stream subchar arg)
+ ;; Read either #I(...) or #I"..."
+ (declare (ignore arg subchar))
+ (let ((first-char (peek-char nil stream t nil t)))
+ (cond ((char= first-char #\space)
+ (read-char stream) ; skip over whitespace
+ (infix-reader stream nil nil))
+ ((char= first-char #\")
+ ;; Read double-quote-delimited infix expressions.
+ (string->prefix (read stream t nil t)))
+ ((char= first-char #\()
+ (read-char stream) ; get rid of opening left parenthesis
+ (let ((*readtable* *infix-readtable*)
+ (*normal-readtable* *readtable*))
+ (read-infix stream)))
+ (t
+ (infix-error "Infix expression starts with ~A" first-char)))))
+
+(set-dispatch-macro-character #\# #\I #'infix-reader *readtable*) ; was #\# #\$
+
+(defun string->prefix (string)
+ "Convert a string to a prefix s-expression using the infix reader.
+ If the argument is not a string, just return it as is."
+ (if (stringp string)
+ (with-input-from-string (stream (concatenate 'string "#I(" string ")"))
+ (read stream))
+ string))
+
+(defun read-infix (stream)
+ (let* ((result (gather-superiors '\) stream)) ; %infix-end-token%
+ (next-token (read-token stream)))
+ (unless (same-token-p next-token '\)) ; %infix-end-token%
+ (infix-error "Infix expression ends with ~A." next-token))
+ result))
+
+(defun read-regular (stream)
+ (let ((*readtable* *normal-readtable*))
+ (read stream t nil t)))
+
+
+;;; ********************************
+;;; Reader Code ********************
+;;; ********************************
+
+(defun same-operator-p (x y)
+ (same-token-p x y))
+
+(defun same-token-p (x y)
+ (and (symbolp x)
+ (symbolp y)
+ (string-equal (symbol-name x) (symbol-name y))))
+
+;;; Peeking Token Reader
+
+(defvar *peeked-token* nil)
+(defun read-token (stream)
+ (if *peeked-token*
+ (pop *peeked-token*)
+ (read stream t nil t)))
+(defun peek-token (stream)
+ (unless *peeked-token*
+ (push (read stream t nil t) *peeked-token*))
+ (car *peeked-token*))
+
+;;; Hack to work around + and - being terminating macro characters,
+;;; so 1e-3 doesn't normally work correctly.
+
+(defun fancy-number-format-p (left operator stream)
+ (when (and (symbolp left)
+ (find operator '(+ -) :test #'same-operator-p))
+ (let* ((name (symbol-name left))
+ (length (length name)))
+ (when (and (valid-numberp (subseq name 0 (1- length)))
+ ;; Exponent, Single, Double, Float, or Long
+ (find (subseq name (1- length))
+ '("e" "s" "d" "f" "l")
+ :test #'string-equal))
+ (read-token stream)
+ (let ((right (peek-token stream)))
+ (cond ((integerp right)
+ ;; it is one of the fancy numbers, so return it
+ (read-token stream)
+ (let ((*readtable* *normal-readtable*))
+ (read-from-string (format nil "~A~A~A"
+ left operator right))))
+ (t
+ ;; it isn't one of the fancy numbers, so unread the token
+ (push operator *peeked-token*)
+ ;; and return nil
+ nil)))))))
+
+(defun valid-numberp (string)
+ (let ((saw-dot nil))
+ (dolist (char (coerce string 'list) t)
+ (cond ((char= char #\.)
+ (if saw-dot
+ (return nil)
+ (setq saw-dot t)))
+ ((not (find char "01234567890" :test #'char=))
+ (return nil))))))
+
+;;; Gobbles an expression from the stream.
+
+(defun gather-superiors (previous-operator stream)
+ "Gathers an expression whose operators all exceed the precedence of
+ the operator to the left."
+ (let ((left (get-first-token stream)))
+ (loop
+ (setq left (post-process-expression left))
+ (let ((peeked-token (peek-token stream)))
+ (let ((fancy-p (fancy-number-format-p left peeked-token stream)))
+ (when fancy-p
+ ;; i.e., we've got a number like 1e-3 or 1e+3 or 1f-1
+ (setq left fancy-p
+ peeked-token (peek-token stream))))
+ (unless (or (operator-lessp previous-operator peeked-token)
+ (and (same-operator-p peeked-token previous-operator)
+ (operator-right-associative-p previous-operator)))
+ ;; The loop should continue when the peeked operator is
+ ;; either superior in precedence to the previous operator,
+ ;; or the same operator and right-associative.
+ (return left)))
+ (setq left (get-next-token stream left)))))
+
+(defun get-first-token (stream)
+ (let ((token (read-token stream)))
+ (if (token-operator-p token)
+ ;; It's an operator in a prefix context.
+ (apply-token-prefix-operator token stream)
+ ;; It's a regular token
+ token)))
+
+(defun apply-token-prefix-operator (token stream)
+ (let ((operator (get-token-prefix-operator token)))
+ (if operator
+ (funcall operator stream)
+ (infix-error "~A is not a prefix operator" token))))
+
+(defun get-next-token (stream left)
+ (let ((token (read-token stream)))
+ (apply-token-infix-operator token left stream)))
+
+(defun apply-token-infix-operator (token left stream)
+ (let ((operator (get-token-infix-operator token)))
+ (if operator
+ (funcall operator stream left)
+ (infix-error "~A is not an infix operator" token))))
+
+;;; Fix to read-delimited-list so that it works with tokens, not
+;;; characters.
+
+(defun infix-read-delimited-list (end-token delimiter-token stream)
+ (do ((next-token (peek-token stream) (peek-token stream))
+ (list nil))
+ ((same-token-p next-token end-token)
+ ;; We've hit the end. Remove the end-token from the stream.
+ (read-token stream)
+ ;; and return the list of tokens.
+ ;; Note that this does the right thing with [] and ().
+ (nreverse list))
+ ;; Ignore the delimiters.
+ (when (same-token-p next-token delimiter-token)
+ (read-token stream))
+ ;; Gather the expression until the next delimiter.
+ (push (gather-superiors delimiter-token stream) list)))
+
+
+;;; ********************************
+;;; Precedence *********************
+;;; ********************************
+
+(defparameter *operator-ordering*
+ '(( \[ \( \! ) ; \[ is array reference
+ ( ^^ ) ; exponentiation
+ ( ~ ) ; lognot
+ ( * / % ) ; % is mod
+ ( + - )
+ ( << >> )
+ ( < == > <= != >= )
+ ( & ) ; logand
+ ( ^ ) ; logxor
+ ( \| ) ; logior
+ ( not )
+ ( and )
+ ( or )
+ ;; Where should setf and friends go in the precedence?
+ ( = |:=| += -= *= /= )
+ ( \, ) ; progn (statement delimiter)
+ ( if )
+ ( then else )
+ ( \] \) )
+ ( %infix-end-token% )) ; end of infix expression
+ "Ordered list of operators of equal precedence.")
+
+(defun operator-lessp (op1 op2)
+ (dolist (ops *operator-ordering* nil)
+ (cond ((find op1 ops :test #'same-token-p)
+ (return nil))
+ ((find op2 ops :test #'same-token-p)
+ (return t)))))
+
+(defparameter *right-associative-operators* '(^^ =))
+(defun operator-right-associative-p (operator)
+ (find operator *right-associative-operators*))
+
+
+;;; ********************************
+;;; Define Operators ***************
+;;; ********************************
+
+(defvar *token-operators* nil)
+(defvar *token-prefix-operator-table* (make-hash-table))
+(defvar *token-infix-operator-table* (make-hash-table))
+(defun token-operator-p (token)
+ (find token *token-operators*))
+(defun get-token-prefix-operator (token)
+ (gethash token *token-prefix-operator-table*))
+(defun get-token-infix-operator (token)
+ (gethash token *token-infix-operator-table*))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defmacro define-token-operator (operator-name &key
+ (prefix nil prefix-p)
+ (infix nil infix-p))
+ `(progn
+ (pushnew ',operator-name *token-operators*)
+ ,(when prefix-p
+ `(setf (gethash ',operator-name *token-prefix-operator-table*)
+ #'(lambda (stream)
+ ,@(cond ((and (consp prefix)
+ (eq (car prefix) 'infix-error))
+ ;; To avoid ugly compiler warnings.
+ `((declare (ignore stream))
+ ,prefix))
+ (t
+ (list prefix))))))
+ ,(when infix-p
+ `(setf (gethash ',operator-name *token-infix-operator-table*)
+ #'(lambda (stream left)
+ ,@(cond ((and (consp infix)
+ (eq (car infix) 'infix-error))
+ ;; To avoid ugly compiler warnings.
+ `((declare (ignore stream left))
+ ,infix))
+ (t
+ (list infix)))))))))
+
+;;; Readtable definitions for characters, so that the right token is returned.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defmacro define-character-tokenization (char function)
+ `(set-macro-character ,char ,function nil *infix-readtable*)))
+
+
+;;; ********************************
+;;; Operator Definitions ***********
+;;; ********************************
+
+(define-token-operator and
+ :infix `(and ,left ,(gather-superiors 'and stream)))
+(define-token-operator or
+ :infix `(or ,left ,(gather-superiors 'or stream)))
+(define-token-operator not
+ :prefix `(not ,(gather-superiors 'not stream)))
+
+(define-token-operator if
+ :prefix (let* ((test (gather-superiors 'if stream))
+ (then (cond ((same-token-p (peek-token stream) 'then)
+ (read-token stream)
+ (gather-superiors 'then stream))
+ (t
+ (infix-error "Missing THEN clause."))))
+ (else (when (same-token-p (peek-token stream) 'else)
+ (read-token stream)
+ (gather-superiors 'else stream))))
+ (cond ((and test then else)
+ `(if ,test ,then ,else))
+ ((and test then)
+ ;; no else clause
+ `(when ,test ,then))
+ ((and test else)
+ ;; no then clause
+ `(unless ,test ,else))
+ (t
+ ;; no then and else clauses --> always NIL
+ nil))))
+
+(define-token-operator then
+ :prefix (infix-error "THEN clause without an IF."))
+(define-token-operator else
+ :prefix (infix-error "ELSE clause without an IF."))
+
+(define-character-tokenization #\+
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (cond ((char= (peek-char nil stream t nil t) #\=)
+ (read-char stream t nil t)
+ '+=)
+ (t
+ '+))))
+(define-token-operator +
+ :infix `(+ ,left ,(gather-superiors '+ stream))
+ :prefix (gather-superiors '+ stream))
+(define-token-operator +=
+ :infix `(incf ,left ,(gather-superiors '+= stream)))
+
+(define-character-tokenization #\-
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (cond ((char= (peek-char nil stream t nil t) #\=)
+ (read-char stream t nil t)
+ '-=)
+ (t
+ '-))))
+(define-token-operator -
+ :infix `(- ,left ,(gather-superiors '- stream))
+ :prefix `(- ,(gather-superiors '- stream)))
+(define-token-operator -=
+ :infix `(decf ,left ,(gather-superiors '-= stream)))
+
+(define-character-tokenization #\*
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (cond ((char= (peek-char nil stream t nil t) #\=)
+ (read-char stream t nil t)
+ '*=)
+ (t
+ '*))))
+(define-token-operator *
+ :infix `(* ,left ,(gather-superiors '* stream)))
+(define-token-operator *=
+ :infix `(,(if (symbolp left)
+ 'setq
+ 'setf)
+ ,left
+ (* ,left ,(gather-superiors '*= stream))))
+
+(define-character-tokenization #\/
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (cond ((char= (peek-char nil stream t nil t) #\=)
+ (read-char stream t nil t)
+ '/=)
+ (t
+ '/))))
+(define-token-operator /
+ :infix `(/ ,left ,(gather-superiors '/ stream))
+ :prefix `(/ ,(gather-superiors '/ stream)))
+(define-token-operator /=
+ :infix `(,(if (symbolp left)
+ 'setq
+ 'setf)
+ ,left
+ (/ ,left ,(gather-superiors '/= stream))))
+
+(define-character-tokenization #\^
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (cond ((char= (peek-char nil stream t nil t) #\^)
+ (read-char stream t nil t)
+ '^^)
+ (t
+ '^))))
+(define-token-operator ^^
+ :infix `(expt ,left ,(gather-superiors '^^ stream)))
+(define-token-operator ^
+ :infix `(logxor ,left ,(gather-superiors '^ stream)))
+
+(define-character-tokenization #\|
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (cond ((char= (peek-char nil stream t nil t) #\|)
+ (read-char stream t nil t)
+ 'or)
+ (t
+ '\|))))
+(define-token-operator \|
+ :infix `(logior ,left ,(gather-superiors '\| stream)))
+
+(define-character-tokenization #\&
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (cond ((char= (peek-char nil stream t nil t) #\&)
+ (read-char stream t nil t)
+ 'and)
+ (t
+ '\&))))
+(define-token-operator \&
+ :infix `(logand ,left ,(gather-superiors '\& stream)))
+
+(define-character-tokenization #\%
+ #'(lambda (stream char)
+ (declare (ignore stream char))
+ '\%))
+(define-token-operator \%
+ :infix `(mod ,left ,(gather-superiors '\% stream)))
+
+(define-character-tokenization #\~
+ #'(lambda (stream char)
+ (declare (ignore stream char))
+ '\~))
+(define-token-operator \~
+ :prefix `(lognot ,(gather-superiors '\~ stream)))
+
+(define-character-tokenization #\,
+ #'(lambda (stream char)
+ (declare (ignore stream char))
+ '\,))
+(define-token-operator \,
+ :infix `(progn ,left ,(gather-superiors '\, stream)))
+
+(define-character-tokenization #\=
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (cond ((char= (peek-char nil stream t nil t) #\=)
+ (read-char stream t nil t)
+ '==)
+ (t
+ '=))))
+(define-token-operator ==
+ :infix `(= ,left ,(gather-superiors '== stream)))
+(define-token-operator =
+ :infix `(,(if (symbolp left)
+ 'setq
+ 'setf)
+ ,left
+ ,(gather-superiors '= stream)))
+
+(define-character-tokenization #\:
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (cond ((char= (peek-char nil stream t nil t) #\=)
+ (read-char stream t nil t)
+ '|:=|)
+ (t
+ '|:|))))
+(define-token-operator |:=|
+ :infix `(,(if (symbolp left)
+ 'setq
+ 'setf)
+ ,left
+ ,(gather-superiors '|:=| stream)))
+
+(define-character-tokenization #\<
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (cond ((char= (peek-char nil stream t nil t) #\=)
+ (read-char stream t nil t)
+ '<=)
+ ((char= (peek-char nil stream t nil t) #\<)
+ (read-char stream t nil t)
+ '<<)
+ (t
+ '<))))
+(define-token-operator <
+ :infix `(< ,left ,(gather-superiors '< stream)))
+(define-token-operator <=
+ :infix `(<= ,left ,(gather-superiors '<= stream)))
+(define-token-operator <<
+ :infix `(ash ,left ,(gather-superiors '<< stream)))
+
+(define-character-tokenization #\>
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (cond ((char= (peek-char nil stream t nil t) #\=)
+ (read-char stream t nil t)
+ '>=)
+ ((char= (peek-char nil stream t nil t) #\>)
+ (read-char stream t nil t)
+ '>>)
+ (t
+ '>))))
+(define-token-operator >
+ :infix `(> ,left ,(gather-superiors '> stream)))
+(define-token-operator >=
+ :infix `(>= ,left ,(gather-superiors '>= stream)))
+(define-token-operator >>
+ :infix `(ash ,left (- ,(gather-superiors '>> stream))))
+
+(define-character-tokenization #\!
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (cond ((char= (peek-char nil stream t nil t) #\=)
+ (read-char stream t nil t)
+ '!=)
+ (t
+ '!))))
+(define-token-operator !=
+ :infix `(not (= ,left ,(gather-superiors '!= stream))))
+(define-token-operator !
+ :prefix (read-regular stream))
+
+(define-character-tokenization #\[
+ #'(lambda (stream char)
+ (declare (ignore stream char))
+ '\[))
+(define-token-operator \[
+ :infix (let ((indices (infix-read-delimited-list '\] '\, stream)))
+ (if (null indices)
+ (infix-error "No indices found in array reference.")
+ `(aref ,left ,@indices))))
+
+(define-character-tokenization #\(
+ #'(lambda (stream char)
+ (declare (ignore stream char))
+ '\())
+(define-token-operator \(
+ :infix `(,left ,@(infix-read-delimited-list '\) '\, stream))
+ :prefix (let ((list (infix-read-delimited-list '\) '\, stream)))
+ (if (null (rest list))
+ ;; only one element in list. works correctly if list is NIL
+ (first list)
+ ;; several elements in list
+ `(progn ,@list))))
+
+(define-character-tokenization #\]
+ #'(lambda (stream char)
+ (declare (ignore stream char))
+ '\]))
+(define-token-operator \]
+ :infix (infix-error "Extra close brace \"]\" in infix expression"))
+
+(define-character-tokenization #\)
+ #'(lambda (stream char)
+ (declare (ignore stream char))
+ '\)))
+(define-token-operator \)
+ :infix (infix-error "Extra close paren \")\" in infix expression"))
+
+#|
+;;; Commented out because no longer using $ as the macro character.
+(define-character-tokenization #\$
+ #'(lambda (stream char)
+ (declare (ignore stream char))
+ '%infix-end-token%))
+(define-token-operator %infix-end-token%
+ :infix (infix-error "Prematurely terminated infix expression")
+ :prefix (infix-error "Prematurely terminated infix expression"))
+|#
+
+(define-character-tokenization #\;
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (do ((char (peek-char nil stream t nil t)
+ (peek-char nil stream t nil t)))
+ ((or (char= char #\newline) (char= char #\return)
+ ;; was #\$
+; (char= char #\))
+ )
+ ;; Gobble characters until the end of the line or the
+ ;; end of the input.
+ (cond ((or (char= char #\newline) (char= char #\return))
+ (read-char stream)
+ (read stream t nil t))
+ (t
+ ;; i.e., return %infix-end-token%
+ (read stream t nil t))))
+ (read-char stream))))
+
+
+;;; ********************************
+;;; Syntactic Modifications ********
+;;; ********************************
+
+;;; Post processes the expression to remove some unsightliness caused
+;;; by the way infix processes the input. Note that it is also required
+;;; for correctness in the a<b<=c case.
+
+(defun post-process-expression (expression)
+ (if (and (consp expression)
+ (= (length expression) 3))
+ (destructuring-bind (operator left right) expression
+ (cond ((and (consp left)
+ (same-operator-p (first left) operator)
+ (find operator '(+ * / - and or < > <= >= progn)
+ :test #'same-operator-p))
+ ;; Flatten the expression if possible
+ (cond ((and (eq operator '-)
+ (= (length left) 2))
+ ;; -a-b --> (+ (- a) (- b)).
+ `(+ ,left (- ,right)))
+ ((and (eq operator '/)
+ (= (length left) 2))
+ ;; ditto with /
+ `(/ (* ,(second left) ,right)))
+ (t
+ ;; merges a+b+c as (+ a b c).
+ (append left (list right)))))
+ ((and (consp left)
+ (eq operator '-)
+ (eq (first left) '+))
+ ;; merges a+b-c as (+ a b (- c)).
+ (append left (list `(- ,right))))
+ ((and (consp left)
+ (find operator '(< > <= >=))
+ (find (first left) '(< > <= >=)))
+ ;; a<b<c --> a<b and b<c
+ `(and ,left
+ (,operator ,(first (last left))
+ ,right)))
+ (t
+ expression)))
+ expression))
+
+
+;;; ********************************
+;;; Test Infix *********************
+;;; ********************************
+
+;;; Invoke with (infix:test-infix).
+;;; Prints out all the tests that fail and a count of the number of failures.
+
+(defparameter *test-cases*
+ ;; Note that in strings, we have to slashify \ as \\.
+ '(("1 * +2" (* 1 2))
+ ("1 * -2" (* 1 (- 2)))
+ ("1 * /2" (* 1 (/ 2)))
+ ("/2" (/ 2))
+ ("not true" (not true))
+ ("foo\\-bar" foo-bar)
+ ("a + b-c" (+ a b (- c)))
+ ("a + b\\-c" (+ a b-c))
+ ("f\\oo" |FoO|)
+ ("!foo-bar * 2" (* foo-bar 2))
+ ("!(foo bar baz)" (foo bar baz))
+ ("!foo-bar " foo-bar)
+ ;; The following now longer gives an eof error, since the close
+ ;; parenthesis terminates the token.
+ ("!foo-bar" foo-bar) ; eof error -- ! eats the close $
+ ("a+-b" (+ a (- b)))
+ ("a+b" (+ a b))
+ ("a+b*c" (+ a (* b c)))
+ ("a+b+c" (+ a b c))
+ ("a+b-c" (+ a b (- c)))
+ ("a+b-c+d" (+ a b (- c) d))
+ ("a+b-c-d" (+ a b (- c) (- d)))
+ ("a-b" (- a b))
+ ("a*b" (* a b))
+ ("a*b*c" (* a b c))
+ ("a*b+c" (+ (* a b) c))
+ ("a/b" (/ a b))
+ ("a^^b" (expt a b))
+ ("foo/-bar" (/ foo (- bar)))
+ ("1+2*3^^4" (+ 1 (* 2 (expt 3 4))))
+ ("1+2*3^^4+5" (+ 1 (* 2 (expt 3 4)) 5))
+ ("2*3^^4+1" (+ (* 2 (expt 3 4)) 1))
+ ("2+3^^4*5" (+ 2 (* (expt 3 4) 5)))
+ ("2^^3^^4" (expt 2 (expt 3 4)))
+ ("x^^2 + y^^2" (+ (expt x 2) (expt y 2)))
+ ("(1+2)/3" (/ (+ 1 2) 3))
+ ("(a=b)" (setq a b))
+ ("(a=b,b=c)" (progn (setq a b) (setq b c)))
+ ("1*(2+3)" (* 1 (+ 2 3)))
+ ("1+2/3" (+ 1 (/ 2 3)))
+ ("a,b" (progn a b))
+ ("a,b,c" (progn a b c))
+ ("foo(a,b,(c,d))" (foo a b (progn c d)))
+ ("foo(a,b,c)" (foo a b c))
+ ("(a+b,c)" (progn (+ a b) c))
+ ("1" 1)
+ ("-1" (- 1))
+ ("+1" 1)
+ ("1." 1)
+ ("1.1" 1.1)
+ ("1e3" 1000.0)
+ ("1e-3" 0.001)
+ ("1f-3" 1f-3)
+ ("1e-3e" (- 1e 3e))
+ ("!1e-3 " 0.001)
+ ("a and b and c" (and a b c))
+ ("a and b or c" (or (and a b) c))
+ ("a and b" (and a b))
+ ("a or b and c" (or a (and b c)))
+ ("a or b" (or a b))
+ ("a<b and b<c" (and (< a b) (< b c)))
+ ("if (if a then b else c) then e" (when (if a b c) e))
+ ("if 1 then 2 else 3+4" (if 1 2 (+ 3 4)))
+ ("(if 1 then 2 else 3)+4" (+ (if 1 2 3) 4))
+ ("if a < b then b else a" (if (< a b) b a))
+ ("if a and b then c and d else e and f"
+ (if (and a b) (and c d) (and e f)))
+ ("if a or b then c or d else e or f" (if (or a b) (or c d) (or e f)))
+ ("if a then (if b then c else d) else e" (if a (if b c d) e))
+ ("if a then (if b then c) else d" (if a (when b c) d))
+ ("if a then b else c" (if a b c))
+ ("if a then b" (when a b))
+ ("if a then if b then c else d else e" (if a (if b c d) e))
+ ("if a then if b then c else d" (when a (if b c d)))
+ ("if if a then b else c then e" (when (if a b c) e))
+ ("if not a and not b then c" (when (and (not a) (not b)) c))
+ ("if not a then not b else not c and d"
+ (if (not a) (not b) (and (not c) d)))
+ ("not a and not b" (and (not a) (not b)))
+ ("not a or not b" (or (not a) (not b)))
+ ("not a<b and not b<c" (and (not (< a b)) (not (< b c))))
+ ("not a<b" (not (< a b)))
+ ("a[i,k]*b[j,k]" (* (aref a i k) (aref b j k)))
+ ("foo(bar)=foo[bar,baz]" (setf (foo bar) (aref foo bar baz)))
+ ("foo(bar,baz)" (foo bar baz))
+ ("foo[bar,baz]" (aref foo bar baz))
+ ("foo[bar,baz]=barf" (setf (aref foo bar baz) barf))
+ ("max = if a < b then b else a" (setq max (if (< a b) b a)))
+ ("a < b < c" (< A B C))
+ ("a < b <= c" (and (< a b) (<= b c)))
+ ("a <= b <= c" (<= A B C))
+ ("a <= b <= c" (<= A B C))
+ ("a!=b and b<c" (and (not (= a b)) (< b c)))
+ ("a!=b" (not (= a b)))
+ ("a<b" (< a b))
+ ("a==b" (= a b))
+ ("a*b(c)+d" (+ (* a (b c)) d))
+ ("a+b(c)*d" (+ a (* (b c) d)))
+ ("a+b(c)+d" (+ a (b c) d))
+ ("d+a*b(c)" (+ d (* a (b c))))
+ ("+a+b" (+ a b))
+ ("-a+b" (+ (- a) b))
+ ("-a-b" (+ (- a) (- b)))
+ ("-a-b-c" (+ (- a) (- b) (- c)))
+ ("a*b/c" (/ (* a b) c))
+ ("a+b-c" (+ a b (- c)))
+ ("a-b-c" (- a b c))
+ ("a/b*c" (* (/ a b) c))
+ ("a/b/c" (/ a b c))
+ ("/a/b" (/ (* a b)))
+ ("a^^b^^c" (expt a (expt b c)))
+ ("a(d)^^b^^c" (expt (a d) (expt b c)))
+ ("a<b+c<d" (< a (+ b c) d))
+ ("1*~2+3" (+ (* 1 (lognot 2)) 3))
+ ("1+~2*3" (+ 1 (* (lognot 2) 3)))
+ ("1+~2+3" (+ 1 (lognot 2) 3))
+ ("f(a)*=g(b)" (setf (f a) (* (f a) (g b))))
+ ("f(a)+=g(b)" (incf (f a) (g b)))
+ ("f(a)-=g(b)" (decf (f a) (g b)))
+ ("f(a)/=g(b)" (setf (f a) (/ (f a) (g b))))
+ ("a&b" (logand a b))
+ ("a^b" (logxor a b))
+ ("a|b" (logior a b))
+ ("a<<b" (ash a b))
+ ("a>>b" (ash a (- b)))
+ ("~a" (lognot a))
+ ("a&&b" (and a b))
+ ("a||b" (or a b))
+ ("a%b" (mod a b))
+
+ ;; Comment character -- must have carriage return after semicolon.
+ ("x^^2 ; the x coordinate
+ + y^^2 ; the y coordinate" :error)
+ ("x^^2 ; the x coordinate
+ + y^^2 ; the y coordinate
+ " (+ (expt x 2) (expt y 2)))
+
+ ;; Errors
+ ("foo(bar,baz" :error) ; premature termination
+ ;; The following no longer gives an error
+ ("foo(bar,baz))" (foo bar baz)) ; extra close parenthesis
+ ("foo[bar,baz]]" :error) ; extra close bracket
+ ("[foo,bar]" :error) ; AREF is not a prefix operator
+ ("and a" :error) ; AND is not a prefix operator
+ ("< a" :error) ; < is not a prefix operator
+ ("=bar" :error) ; SETF is not a prefix operator
+ ("*bar" :error) ; * is not a prefix operator
+ ("a not b" :error) ; NOT is not an infix operator
+ ("a if b then c" :error) ; IF is not an infix operator
+ ("" :error) ; premature termination (empty clause)
+ (")a" :error) ; left parent is not a prefix operator
+ ("]a" :error) ; left bracket is not a prefix operator
+ ))
+
+(defun test-infix (&optional (tests *test-cases*))
+ (let ((count 0))
+ (dolist (test tests)
+ (destructuring-bind (string result) test
+ (unless (test-infix-case string result)
+ (incf count))))
+ (format t "~&~:(~R~) test~p failed." count count)
+ (values)))
+
+(defun test-infix-case (string result)
+ (multiple-value-bind (value error)
+ (let ((*package* (find-package "INFIX")))
+ (ignore-errors
+ (values (read-from-string (concatenate 'string "#I(" string ")")
+ t nil))))
+ (cond (error
+ (cond ((eq result :error)
+ t)
+ (t
+ (format t "~&Test #I(~A) failed with ERROR." string)
+ nil)))
+ ((eq result :error)
+ (format t "~&Test #I(~A) failed. ~
+ ~& Expected ERROR ~
+ ~& but got ~A."
+ string value)
+ nil)
+ ((not (equal value result))
+ (format t "~&Test #I(~A) failed. ~
+ ~& Expected ~A ~
+ ~& but got ~A."
+ string result value)
+ nil)
+ (t
+ t))))
+
+;;; *EOF*
commit b7491a45a621cf8b4d5c266ec39a8850172d2f02
Author: Akshay Srinivasan <aks...@gm...>
Date: Wed May 23 10:10:33 2012 +0530
Moved blas-helper functions to a separate file.
Tensor-computation is not trivial!
diff --git a/src/blas-helpers.lisp b/src/blas-helpers.lisp
new file mode 100644
index 0000000..4869c2c
--- /dev/null
+++ b/src/blas-helpers.lisp
@@ -0,0 +1,39 @@
+(in-package :matlisp)
+
+(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")))
+
+(defun fortran-snop (sop)
+ (cond
+ ((string= sop "N") "T")
+ ((string= sop "T") "N")
+ (t (error "Unrecognised fortran-op."))))
+
+(defun blas-copyable-p (matrix)
+ (declare (optimize (safety 0) (speed 3))
+ (type (or real-matrix complex-matrix) matrix))
+ (mlet* ((nr (nrows matrix) :type fixnum)
+ (nc (ncols matrix) :type fixnum)
+ (rs (row-stride matrix) :type fixnum)
+ (cs (col-stride matrix) :type fixnum)
+ (ne (number-of-elements matrix) :type fixnum))
+ (cond
+ ((or (= nc 1) (= cs (* nr rs))) (values t rs ne))
+ ((or (= nr 1) (= rs (* nc cs))) (values t cs ne))
+ (t (values nil -1 -1)))))
+
+(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 (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
diff --git a/src/tensor-copy.lisp b/src/tensor-copy.lisp
new file mode 100644
index 0000000..f06e6a8
--- /dev/null
+++ b/src/tensor-copy.lisp
@@ -0,0 +1,36 @@
+(in-package :tensor)
+
+;;
+(defmacro generate-typed-copy!-func (func store-type matrix-type blas-func)
+ ;;Be very careful when using functions generated by this macro.
+ ;;Indexes can be tricky and this has no safety net
+ ;;Use only after checking the arguments for compatibility.
+ `(defun ,func (mat-a mat-b)
+ (declare (type ,matrix-type mat-a mat-b)
+ (optimize (safety 0) (speed 3)))
+ (mlet* (((cp-a inc-a sz-a) (blas-copyable-p mat-a) :type (boolean fixnum nil))
+ ((cp-b inc-b sz-b) (blas-copyable-p mat-b) :type (boolean fixnum nil))
+ ((hd-a st-a sz) (slot-values mat-a '(head store number-of-elements)) :type (fixnum (,store-type *) fixnum))
+ ((hd-b st-b) (slot-values mat-b '(head store)) :type (fixnum (,store-type *))))
+ (if (and cp-a cp-b)
+ (,blas-func sz st-a inc-a st-b inc-b :head-x hd-a :head-y hd-b)
+ (mlet* (((nr-a nc-a rs-a cs-a) (slot-values mat-a '(number-of-rows number-of-cols row-stride col-stride))
+ :type (fixnum fixnum fixnum fixnum))
+ ((rs-b cs-b) (slot-values mat-b '(row-stride col-stride))
+ :type (fixnum fixnum)))
+ ;;Choose the smaller of the loops
+ (when (> (nrows mat-a) (ncols mat-a))
+ (rotatef nr-a nc-a)
+ (rotatef rs-a cs-a)
+ (rotatef rs-b cs-b))
+ (loop for i from 0 below nr-a
+ do (,blas-func nc-a st-a cs-a st-b cs-b :head-x (+ hd-a (* i rs-a)) :head-y (+ hd-b (* i rs-b)))))))
+ mat-b))
+
+
+(defun real-typed-copy!-func (ten-a ten-b)
+
+
+
+(defun find-longest-chain (stds dims))
+
commit f9871bd640672b300b2b1790671f16694a67c184
Author: Akshay Srinivasan <aks...@gm...>
Date: Wed May 23 10:08:32 2012 +0530
Making standard-matrix a subclass of standard-tensor. Not complete yet.
diff --git a/packages.lisp b/packages.lisp
index d3af8bb..4134b4a 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -156,20 +156,15 @@
(defpackage :utilities
(:use :common-lisp)
(:export #:ensure-list
- #:zip
- #:zip-eq
- #:cut-cons-chain!
- #:when-let
- #:if-let
- #:if-ret
- #:get-arg
- #:nconsc
- #:with-gensyms
+ #:zip #:zip-eq
+ #:get-arg #:cut-cons-chain!
#:slot-values
- #:mlet*
#:recursive-append
- #:make-array-allocator
- ;;
+ ;;Macros
+ #:when-let #:if-let #:if-ret #:with-gensyms
+ #:mlet* #:make-array-allocator
+ #:nconsc
+ ;;Structure-specific
#:foreign-vector #:make-foreign-vector #:foreign-vector-p
#:fv-ref #:fv-pointer #:fv-size #:fv-type))
@@ -186,42 +181,45 @@
)
(:documentation "Fortran foreign function interface"))
-(defpackage "BLAS"
- #+:cmu (:use "COMMON-LISP" "ALIEN" "C-CALL" "FORTRAN-FFI-ACCESSORS")
- #+:sbcl (:use "COMMON-LISP" "SB-ALIEN" "SB-C" "FORTRAN-FFI-ACCESSORS")
- #+:allegro (:use "COMMON-LISP" "FOREIGN-FUNCTIONS" "FORTRAN-FFI-ACCESSORS")
- #+(or ccl ecl) (:use "COMMON-LISP" "FORTRAN-FFI-ACCESSORS")
+(defpackage :blas
+ (:use :commmon-lisp :fortran-ffi-accessors)
(:export
- "IDAMAX" "DASUM" "DDOT" "DNRM2"
- "DROT" "DSCAL" "DSWAP" "DCOPY" "DAXPY"
- "DCABS1" "DZASUM" "DZNRM2" "IZAMAX"
- "ZDSCAL" "ZSCAL" "ZSWAP" "ZCOPY" "ZAXPY" "ZDOTC" "ZDOTU"
- "DGEMV" "DSYMV" "DTRMV" "DTRSV" "DGER" "DSYR" "DSYR2"
- "ZGEMV" "ZHEMV" "ZTRMV" "ZTRSV" "ZGERC" "ZGERU" "ZHER2"
- "DGEMM" "DSYRK" "DSYR2K" "DTRMM" "DTRSM"
- "ZGEMM" "ZTRMM" "ZTRSM" "ZHERK" "ZHER2K" )
+ ;;BLAS Level 1
+ ;;------------
+ ;;Real-double
+ #:ddot #:dnrm2 #:dasum #:dscal #:daxpy #:drot
+ #:dswap #:dcopy #:idamax
+ ;;Complex-double
+ #:zdotc #:zdotu #:zdscal #:zscal #:zswap #:zcopy #:zaxpy
+ #:dcabs1 #:dzasum #:dznrm2 #:izamax
+ ;;BLAS Level 2
+ ;;------------
+ ;;Real-double
+ #:dgemv #:dsymv #:dtrmv #:dtrsv #:dger #:dsyr #:dsyr2
+ ;;Complex-double
+ #:zgemv #:zhemv #:ztrmv #:ztrsv #:zgerc #:zgeru #:zher2
+ ;;BLAS Level 3
+ ;;------------
+ ;;Real-double
+ #:dgemm #:dsyrk #:dsyr2k #:dtrmm #:dtrsm
+ ;;Complex-double
+ #:zgemm #:ztrmm #:ztrsm #:zherk #:zher2k)
(:documentation "BLAS routines"))
-(defpackage "LAPACK"
- #+:cmu (:use "COMMON-LISP" "ALIEN" "C-CALL" "FORTRAN-FFI-ACCESSORS")
- #+:sbcl (:use "COMMON-LISP" "SB-ALIEN" "SB-C" "FORTRAN-FFI-ACCESSORS")
- #+:allegro (:use "COMMON-LISP" "FOREIGN-FUNCTIONS" "FORTRAN-FFI-ACCESSORS")
- #+(or ccl ecl) (:use "COMMON-LISP" "FORTRAN-FFI-ACCESSORS")
+(defpackage :lapack
+ (:use :commmon-lisp :fortran-ffi-accessors)
(:export
- "DGESV" "DGEEV" "DGETRF" "DGETRS" "DGESVD"
- "ZGESV" "ZGEEV" "ZGETRF" "ZGETRS" "ZGESVD"
- "DGEQRF" "ZGEQRF" "DGEQP3" "ZGEQP3"
- "DORGQR" "ZUNGQR"
- "DPOTRS" "ZPOTRS" "DPOTRF" "ZPOTRF"
- "DGELSY")
+ #:dgesv #:dgeev #:dgetrf #:dgetrs #:dgesvd
+ #:zgesv #:zgeev #:zgetrf #:zgetrs #:zgesvd
+ #:dgeqrf #:zgeqrf #:dgeqp3 #:zgeqp3
+ #:dorgqr #:zungqr
+ #:dpotrs #:zpotrs #:dpotrf #:zpotrf
+ #:dgelsy)
(:documentation "LAPACK routines"))
-(defpackage "DFFTPACK"
- #+:cmu (:use "COMMON-LISP" "ALIEN" "C-CALL" "FORTRAN-FFI-ACCESSORS")
- #+:sbcl (:use "COMMON-LISP" "SB-ALIEN" "SB-C" "FORTRAN-FFI-ACCESSORS")
- #+:allegro (:use "COMMON-LISP" "FOREIGN-FUNCTIONS" "FORTRAN-FFI-ACCESSORS")
- #+(or ccl ecl) (:use "COMMON-LISP" "FORTRAN-FFI-ACCESSORS")
- (:export "ZFFTI" "ZFFTF" "ZFFTB")
+(defpackage :dfftpack
+ (:use :commmon-lisp :fortran-ffi-accessors)
+ (:export #:zffti #:zfftf #:zfftb #:zffti #:zfftf #:zfftb)
(:documentation "FFT routines"))
;; Stolen from f2cl.
@@ -303,6 +301,25 @@
(:use :common-lisp :fortran-ffi-accessors :blas :lapack :dfftpack :quadpack :matlisp-lib :utilities)
(:shadow #:real)
(:export #:*print-matrix*
+ ;;
+ #:integer4-type #:integer4-array #:allocate-integer4-store
+ #:index-type #:index-array #:allocate-index-store #:make-index-store
+ ;;Standard-tensor
+ #:standard-tensor
+ #:rank #:dimensions #:number-of-elements
+ #:head #:strides #:store-size #:store
+ ;;Sub-tensor
+ #:sub-tensor
+ #:parent-tensor
+ ;;Store indexers
+ #:store-indexing
+ #:store-indexing-internal #:store-indexing-vec #:store-indexing-lst
+ ;;Store accessors
+ #:tensor-store-ref
+ #:tensor-ref
+ ;;Type checking
+ #:tensor-type-p #:vector-p #:matrix-p #:square-p
+
;;Level 1 BLAS
#:axpy! #:axpy
#:copy! #:copy
@@ -318,7 +335,7 @@
#:standard-matrix
#:nrows #:ncols #:number-of-elements
#:head #:row-stride #:col-stride
- #:store #:store-size
+ #:store #:store-size
;;Generic functions on standard-matrix
#:fill-matrix
#:row-or-col-vector-p #:row-vector-p #:col-vector-p
diff --git a/src/conditions.lisp b/src/conditions.lisp
index 66cbcf7..9fdb937 100644
--- a/src/conditions.lisp
+++ b/src/conditions.lisp
@@ -25,6 +25,12 @@
(:report (lambda (c stream)
(format stream "Requested index ~A, but store is only of size ~A." (index c) (store-size c)))))
+(define-condition tensor-not-matrix (matlisp-error)
+ ((tensor-rank :reader rank :initarg :rank))
+ (:documentation "Given tensor is not a matrix.")
+ (:report (lambda (c stream)
+ (format stream "Given tensor with rank ~A, is not a matrix." (rank c)))))
+
(define-condition insufficient-store (matlisp-error)
((store-size :reader store-size :initarg :store-size)
(max-idx :reader max-idx :initarg :max-idx))
diff --git a/src/standard-matrix.lisp b/src/standard-matrix.lisp
index 4e0deab..ce2afb3 100644
--- a/src/standard-matrix.lisp
+++ b/src/standard-matrix.lisp
@@ -1,142 +1,51 @@
-;; Definitions of STANDARD-MATRIX
(in-package :matlisp)
;;
-(declaim (inline allocate-integer4-store))
-
-(eval-when (load eval compile)
- (deftype integer4-matrix-element-type ()
- '(signed-byte 32))
- )
-
-(defun allocate-integer4-store (size &optional (initial-element 0))
- "(ALLOCATE-INTEGER-STORE SIZE [INITIAL-ELEMENT]). Allocates
-integer storage. Default INITIAL-ELEMENT = 0."
- (make-array size
- :element-type 'integer4-matrix-element-type
- :initial-element initial-element))
-
-;;
-(declaim (inline store-indexing))
-(defun store-indexing (row col head row-stride col-stride)
- (declare (type (and fixnum (integer 0)) row col head row-stride col-stride))
- (the fixnum (+ head (the fixnum (* row row-stride)) (the fixnum (* col col-stride)))))
-
-(defun blas-copyable-p (matrix)
- (declare (optimize (safety 0) (speed 3))
- (type (or real-matrix complex-matrix) matrix))
- (mlet* ((nr (nrows matrix) :type fixnum)
- (nc (ncols matrix) :type fixnum)
- (rs (row-stride matrix) :type fixnum)
- (cs (col-stride matrix) :type fixnum)
- (ne (number-of-elements matrix) :type fixnum))
- (cond
- ((or (= nc 1) (= cs (* nr rs))) (values t rs ne))
- ((or (= nr 1) (= rs (* nc cs))) (values t cs ne))
- (t (values nil -1 -1)))))
-
-(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 (fortran-nop op)))
- ((= rs 1) (values :col-major cs (fortran-op op)))
- ;;Lets not confound lisp's type declaration.
- (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")))
-
-(defun fortran-snop (sop)
- (cond
- ((string= sop "N") "T")
- ((string= sop "T") "N")
- (t (error "Unrecognised fortran-op."))))
-
-;;
-(defclass standard-matrix ()
- ((number-of-rows
- :initarg :nrows
- :initform 0
- :accessor nrows
- :type fixnum
- :documentation "Number of rows in the matrix")
- (number-of-cols
- :initarg :ncols
- :initform 0
- :accessor ncols
- :type fixnum
- :documentation "Number of columns in the matrix")
- (number-of-elements
- :initform 0
- :accessor number-of-elements
- :type fixnum
- :documentation "Total number of elements in the matrix (nrows * ncols)")
- ;;
- (head
- :initarg :head
- :initform 0
- :accessor head
- :type fixnum
- :documentation "Head for the store's accessor.")
- (row-stride
- :initarg :row-stride
- :accessor row-stride
- :type fixnum
- :documentation "Row stride for the store's accessor.")
- (col-stride
- :initarg :col-stride
- :accessor col-stride
- :type fixnum
- :documentation "Column stride for the store's accessor.")
- (store-size
- :accessor store-size
- :type fixnum
- :documentation "Total number of elements needed to store the matrix. (Usually
-the same as nels, but not necessarily so!")
- (store
- :initarg :store
- :accessor store
- :documentation "The actual storage for the matrix. It is typically a one dimensional
-array but not necessarily so. The float and complex matrices do use
-1-D arrays. The complex matrix actually stores the real and imaginary
-parts in successive elements of the matrix because Fortran stores them
-that way."))
+(defclass standard-matrix (standard-tensor)
+ ((rank
+ :accessor rank
+ :type index-type
+ :initform 2
+ :documentation "For a matrix, rank = 2."))
(:documentation "Basic matrix class."))
+(defun nrows (matrix)
+ (declare (type standard-matrix matrix))
+ (let ((dims (dimensions matrix)))
+ (declare (type (index-array 2) dims))
+ (aref dims 0)))
+
+(defun ncols (matrix)
+ (declare (type standard-matrix matrix))
+ (let ((dims (dimensions matrix)))
+ (declare (type (index-array 2) dims))
+ (aref dims 1)))
+
+(defun row-stride (matrix)
+ (declare (type standard-matrix matrix))
+ (let ((stds (strides matrix)))
+ (declare (type (index-array 2) stds))
+ (aref stds 0)))
+
+(defun col-stride (matrix)
+ (declare (type standard-matrix matrix))
+ (let ((stds (strides matrix)))
+ (declare (type (index-array 2) stds))
+ (aref stds 1)))
+
+(defun size (matrix)
+ (declare (type standard-matrix matrix))
+ (let ((dims (dimensions matrix)))
+ (declare (type (index-array 2) dims))
+ (list (aref dims 0) (aref dims 1))))
;;
+
(defmethod initialize-instance :after ((matrix standard-matrix) &rest initargs)
(declare (ignore initargs))
(mlet*
- (((nr nc hd ss) (slot-values matrix '(number-of-rows number-of-cols head store-size))
- :type (fixnum fixnum fixnum fixnum)))
- ;;Row-ordered by default.
- (unless (and (slot-boundp matrix 'row-stride) (slot-boundp matrix 'col-stride))
- (setf (row-stride matrix) nc)
- (setf (col-stride matrix) 1))
- (let* ((rs (row-stride matrix))
- (cs (col-stride matrix))
- (l-idx (store-indexing (- nr 1) (- nc 1) hd rs cs)))
- (declare (type fixnum rs cs))
- ;;Error checking is good if we use foreign-pointers as store types.
- (cond
- ((<= nr 0) (error "Number of rows must be > 0. Initialized with ~A." nr))
- ((<= nc 0) (error "Number of columns must be > 0. Initialized with ~A." nc))
- ;;
- ((< hd 0) (error "Head of the store must be >= 0. Initialized with ~A." hd))
- ((< rs 0) (error "Row-stride of the store must be >= 0. Initialized with ~A." rs))
- ((< cs 0) (error "Column-stride of the store must be >= 0. Initialized with ~A." cs))
- ((<= ss l-idx) (error "Store is not large enough to hold the matrix.
-Initialized with ~A, but the largest possible index is ~A." ss l-idx))))
- ;;
- (setf (number-of-elements matrix) (* nr nc))))
+ ((rank (rank matrix) :type index-type))
+ (unless (= rank 2)
+ (error 'tensor-not-matrix :rank rank :tensor matrix))))
;;
(defmacro matrix-ref (matrix row &optional col)
@@ -145,131 +54,41 @@ Initialized with ~A, but the largest possible index is ~A." ss l-idx))))
`(matrix-ref-1d ,matrix ,row)))
;;
-(defgeneric matrix-ref-1d (matrix store-idx)
- (:documentation "
- Syntax
- ======
- (matrix-REF-1d store store-idx)
-
- Purpose
- =======
- Return the element store-idx of the matrix store."))
-
-#+nil(defmethod matrix-ref-1d :before ((matrix standard-matrix) (idx fixnum))
- (unless (< -1 (- idx (head matrix)) (number-of-elements matrix))
- (error "Requested index ~A is out of bounds.
-Matrix only has ~A elements." idx (number-of-elements matrix))))
-
-;;
-(defgeneric (setf matrix-ref-1d) (value matrix idx))
-
-#+nil(defmethod (setf matrix-ref-1d) :before ((value t) (matrix standard-matrix) (idx fixnum))
- (unless (< -1 idx (number-of-elements matrix))
- (error "Requested index ~A is out of bounds.
-Matrix only has ~A elements." idx (number-of-elements matrix))))
-
-;;
-(defgeneric matrix-ref-2d (matrix rows cols)
- (:documentation "
- Syntax
- ======
- (MATRIX-REF-2d store i j)
-
- Purpose
- =======
- Return the element
- (+
- (* (row-stride store) i)
- (* (col-stride store) j))
- of the store "))
-
-(defmethod matrix-ref-2d :before ((matrix standard-matrix) (rows fixnum) (cols fixnum))
- (unless (and (< -1 rows (nrows matrix))
- (< -1 cols (ncols matrix)))
- (error "Requested index (~A ~A) is out of bounds." rows cols)))
-
-(defmethod matrix-ref-2d ((matrix standard-matrix) (rows fixnum) (cols fixnum))
- (matrix-ref-1d matrix (store-indexing rows cols (head matrix) (row-stride matrix) (col-stride matrix))))
-
-;;
-(defgeneric (setf matrix-ref-2d) (value matrix rows cols))
-
-(defmethod (setf matrix-ref-2d) ((value t) (matrix standard-matrix) (rows fixnum) (cols fixnum))
- (setf (matrix-ref-1d matrix (store-indexing rows cols (head matrix) (row-stride matrix) (col-stride matrix))) value))
-
-;;
-(defgeneric row-vector-p (matrix)
- (:documentation "
+(defun row-vector-p (matrix)
+ "
Syntax
======
(ROW-VECTOR-P x)
Purpose
======...
[truncated message content] |
|
From: Akshay S. <ak...@us...> - 2012-05-29 18:08: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 d4818f9fb12cb34d792c4bad8f0662f46f8ffcf0 (commit)
from 98b4fe1837ebeeb904783d78a2c23f996ae83d18 (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 d4818f9fb12cb34d792c4bad8f0662f46f8ffcf0
Author: Akshay Srinivasan <aks...@gm...>
Date: Tue May 29 23:34:42 2012 +0530
Fixed quirk with diag, made it setf-able
diff --git a/src/submat.lisp b/src/submat.lisp
index 078007b..4f1b00f 100644
--- a/src/submat.lisp
+++ b/src/submat.lisp
@@ -184,10 +184,13 @@ Cannot create a sub-matrix of size (~a ~a) starting at (~a ~a)" nr-s nc-s o-i o-
(copy! value (DIAG~ matrix d))
"))
-(defun diag (matrix &optional d)
+(defun (setf diag~) (value matrix &optional (d 0))
+ (copy! value (diag~ matrix d)))
+
+(defun diag (matrix &optional (d 0))
(copy (diag~ matrix d)))
-(defun (setf diag~) (value matrix &optional (d 0))
+(defun (setf diag) (value matrix &optional (d 0))
(copy! value (diag~ matrix d)))
(defmethod diag~ ((matrix real-matrix) &optional (d 0))
-----------------------------------------------------------------------
Summary of changes:
src/submat.lisp | 7 +++++--
1 files changed, 5 insertions(+), 2 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Raymond T. <rt...@us...> - 2012-04-25 04:57:05
|
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 98b4fe1837ebeeb904783d78a2c23f996ae83d18 (commit)
via 9980ae3686cf6361c2e8d8dec95d85f355b3a5d8 (commit)
via 0fc0b662754ddb98367d6add3aeb42f71a9301aa (commit)
via 83ad581a242f7fd2c6416dc115192692a7447c35 (commit)
from 40f4fcf5947519a52340322a27aeaeca4275fd29 (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 98b4fe1837ebeeb904783d78a2c23f996ae83d18
Merge: 40f4fcf 9980ae3
Author: Raymond Toy <toy...@gm...>
Date: Tue Apr 24 21:33:26 2012 -0700
Merge branch 'master' into matlisp-cffi
diff --cc matlisp.asd
index adf4dd6,c0a08b9..b9126f7
--- a/matlisp.asd
+++ b/matlisp.asd
@@@ -38,16 -38,16 +38,22 @@@
:components
((:file "packages")))
+ (asdf:defsystem matlisp-config
+ :pathname #.(translate-logical-pathname "matlisp:builddir;")
+ :depends-on ("matlisp-packages")
+ :components
+ ((:file "config")))
+
+
+(asdf:defsystem matlisp-utilities
+ :pathname #.(translate-logical-pathname "matlisp:srcdir;")
+ :depends-on ("matlisp-packages")
+ :components ((:module "utilities"
+ :pathname "src/"
+ :components ((:file "utilities")))))
-
(asdf:defsystem lazy-loader
:pathname #.(translate-logical-pathname "matlisp:lib;")
- :depends-on ("matlisp-packages")
+ :depends-on ("matlisp-packages" "matlisp-config")
:components
((:file "lazy-loader"
;; you need the load-only here,
-----------------------------------------------------------------------
Summary of changes:
config.lisp.in | 2 +-
lib-src/macros.l | 4 ++--
matlisp.asd | 12 +++++++++---
src/quadpack.lisp | 10 +++++-----
start.lisp.in | 3 ---
5 files changed, 17 insertions(+), 14 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-04-20 18:39: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 40f4fcf5947519a52340322a27aeaeca4275fd29 (commit)
from 20c39c7a913544c3f542fd338568aec439fbd838 (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 40f4fcf5947519a52340322a27aeaeca4275fd29
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Apr 21 00:04:53 2012 +0530
Added apy! for scalar, matrix addition.
Uses {d, z}axpy underneath to do this with a 0 strided vector.
diff --git a/packages.lisp b/packages.lisp
index 94f67e0..c79b02d 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -304,6 +304,7 @@
(:export #:*print-matrix*
;;Level 1 BLAS
#:axpy! #:axpy
+ #:apy! #:apy
#:copy! #:copy
#:scal! #:scal
;;Level 2 BLAS
diff --git a/src/axpy.lisp b/src/axpy.lisp
index 0891c60..097d7f3 100644
--- a/src/axpy.lisp
+++ b/src/axpy.lisp
@@ -72,7 +72,7 @@
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(in-package "MATLISP")
+(in-package #:matlisp)
(defmacro generate-typed-axpy!-func (func element-type store-type matrix-type blas-func)
`(defun ,func (alpha mat-a mat-b)
@@ -98,6 +98,33 @@
do (,blas-func nc-a alpha st-a cs-a st-b cs-b :head-x (+ hd-a (* i rs-a)) :head-y (+ hd-b (* i rs-b)))))))
mat-b))
+(defmacro generate-typed-apy!-func (func
+ element-type store-type matrix-type
+ blas-func id-decl)
+ ;;Be very careful when using functions generated by this macro.
+ ;;Indexes can be tricky and this has no safety net
+ ;;(you don't see a matrix-ref do you ?)
+ ;;Use only after checking the arguments for compatibility.
+ (destructuring-bind (id-maker id-type) id-decl
+ `(mlet* ((id (,@id-maker) :type ,id-type))
+ (defun ,func (alpha mat-b)
+ (declare (type ,element-type alpha)
+ (type ,matrix-type mat-b)
+ (optimize (safety 0) (speed 3)))
+ (mlet* (((cp-b inc-b sz-b) (blas-copyable-p mat-b) :type (boolean fixnum fixnum))
+ ((hd-b st-b) (slot-values mat-b '(head store)) :type (fixnum (,store-type *))))
+ (if cp-b
+ (,blas-func sz-b alpha id 0 st-b inc-b :head-y hd-b)
+ (mlet* (((nr-b nc-b rs-b cs-b) (slot-values mat-b '(number-of-rows number-of-cols row-stride col-stride))
+ :type (fixnum fixnum fixnum fixnum)))
+ ;;Choose the smaller of the loops
+ (when (> nr-b nc-b)
+ (rotatef nr-b nc-b)
+ (rotatef rs-b cs-b))
+ (loop for i from 0 below nr-b
+ do (,blas-func nc-b alpha id 0 st-b cs-b :head-y (+ hd-b (* i rs-b)))))))
+ mat-b))))
+
;;
(defgeneric axpy! (alpha x y)
(:documentation
@@ -121,7 +148,9 @@
(error "Arguments X,Y to AXPY! are of different dimensions."))))
;;
-(generate-typed-axpy!-func real-double-axpy!-typed double-float real-matrix-store-type real-matrix blas:daxpy)
+(generate-typed-axpy!-func real-double-axpy!-typed
+ double-float real-matrix-store-type real-matrix
+ blas:daxpy)
(defmethod axpy! ((alpha number) (x complex-matrix) (y real-matrix))
(error "cannot AXPY! a complex X to a real Y,
@@ -131,7 +160,9 @@ don't know how to coerce COMPLEX to REAL"))
(real-double-axpy!-typed (coerce alpha 'double-float) x y))
;;
-(generate-typed-axpy!-func complex-double-axpy!-typed complex-double-float complex-matrix-store-type complex-matrix blas:zaxpy)
+(generate-typed-axpy!-func complex-double-axpy!-typed
+ complex-double-float complex-matrix-store-type complex-matrix
+ blas:zaxpy)
(defmethod axpy! ((alpha cl:real) (x real-matrix) (y complex-matrix))
(real-double-axpy!-typed (coerce alpha 'double-float) x (mrealpart~ y)))
@@ -198,4 +229,77 @@ don't know how to coerce COMPLEX to REAL"))
(defmethod axpy ((alpha number) (x complex-matrix) (y complex-matrix))
(let ((result (copy y)))
- (axpy! alpha x result)))
\ No newline at end of file
+ (axpy! alpha x result)))
+
+;;;;
+(defgeneric apy! (alpha y)
+ (:documentation
+ "
+ Syntax
+ ======
+ (APY! alpha y)
+
+ Y <- alpha + y
+
+ Purpose
+ =======
+ Same as APY except that the result
+ is stored in Y and Y is returned.
+
+"))
+
+(generate-typed-apy!-func real-double-apy!-typed
+ double-float real-matrix-store-type real-matrix
+ blas:daxpy
+ ((let ((ret (allocate-real-store 1)))
+ (setf (aref ret 0) 1d0)
+ ret)
+ (real-matrix-store-type 1)))
+
+(defmethod apy! ((alpha cl:real) (y real-matrix))
+ (real-double-apy!-typed (coerce alpha 'double-float) y))
+
+;;
+
+(generate-typed-apy!-func complex-double-apy!-typed
+ complex-double-float complex-matrix-store-type complex-matrix
+ blas:zaxpy
+ ((let ((ret (allocate-complex-store 1)))
+ (setf (aref ret 0) 1d0
+ (aref ret 1) 0d0)
+ ret)
+ (complex-matrix-store-type 2)))
+
+(defmethod apy! ((alpha number) (y complex-matrix))
+ ;;Should this be split to handle real,complex alpha
+ ;;by making use of real-double-apy!-typed
+ (complex-double-apy!-typed (complex-coerce alpha) y))
+
+;;
+
+(defgeneric apy (alpha y)
+ (:documentation
+ "
+ Syntax
+ ======
+ (APY! alpha y)
+
+ Y <- alpha + y
+
+ Purpose
+ =======
+ Computes
+
+ ALPHA + Y
+
+ where ALPHA is a scalar and Y is a
+ matrix.
+
+ The result is stored in a new matrix
+ that has the same dimensions as Y.
+
+"))
+
+(defmethod apy ((alpha number) (y standard-matrix))
+ (let ((ret (copy y)))
+ (apy! alpha y)))
\ No newline at end of file
diff --git a/src/copy.lisp b/src/copy.lisp
index aa3cbda..8389e3c 100644
--- a/src/copy.lisp
+++ b/src/copy.lisp
@@ -76,7 +76,7 @@
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(in-package "MATLISP")
+(in-package #:matlisp)
;;
(defmacro generate-typed-copy!-func (func store-type matrix-type blas-func)
-----------------------------------------------------------------------
Summary of changes:
packages.lisp | 1 +
src/axpy.lisp | 112 ++++++++++++++++++++++++++++++++++++++++++++++++++++++--
src/copy.lisp | 2 +-
3 files changed, 110 insertions(+), 5 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-04-14 12:06:15
|
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, tensor has been created
at 365629a9b8ca20f729635ec74047904caca9c8d9 (commit)
- Log -----------------------------------------------------------------
commit 365629a9b8ca20f729635ec74047904caca9c8d9
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Apr 14 17:29:29 2012 +0530
Real-tensor class sort of works.
diff --git a/src/real-tensor.lisp b/src/real-tensor.lisp
new file mode 100644
index 0000000..e5bebaf
--- /dev/null
+++ b/src/real-tensor.lisp
@@ -0,0 +1,53 @@
+(in-package :tensor)
+
+(eval-when (load eval compile)
+ (deftype real-type ()
+ "The type of the elements stored in a REAL-MATRIX"
+ 'double-float)
+
+ (deftype real-array (size)
+ "The type of the storage structure for a REAL-MATRIX"
+ `(simple-array real-type (,size)))
+ )
+;;
+(declaim (inline allocate-real-store))
+(defun allocate-real-store (size &optional (initial-element 0d0))
+ (make-array size :element-type 'real-type
+ :initial-element (coerce initial-element 'real-type)))
+
+(declaim (inline coerce-real))
+(defun coerce-real (x)
+ (coerce x 'real-type))
+
+;;
+(defclass real-tensor (standard-tensor)
+ ((store
+ :initform nil
+ :type (real-array *)))
+ (:documentation "Tensor class with real elements."))
+
+(defclass sub-real-tensor (real-tensor)
+ ((parent-tensor
+ :initarg :parent-tensor
+ :accessor parent-tensor))
+ (:documentation "Sub-tensor class with real elements."))
+
+;;
+(defmethod initialize-instance ((tensor real-tensor) &rest initargs)
+ (setf (store-size tensor) (length (get-arg :store initargs)))
+ (call-next-method))
+;;
+
+(defmethod tensor-store-ref ((tensor real-tensor) (idx fixnum))
+ (aref (store tensor) idx))
+
+(defmethod (setf tensor-store-ref) ((value number) (tensor real-tensor) (idx fixnum))
+ (setf (aref (store tensor) idx) (coerce-real value)))
+
+;;
+
+(defun make-real-tensor (&rest subs)
+ (let* ((dims (apply #'make-index-store subs))
+ (ss (reduce #'* dims))
+ (store (allocate-real-store ss)))
+ (make-instance 'real-tensor :store store :dimensions dims)))
\ No newline at end of file
diff --git a/src/standard-tensor.lisp b/src/standard-tensor.lisp
new file mode 100644
index 0000000..959988c
--- /dev/null
+++ b/src/standard-tensor.lisp
@@ -0,0 +1,348 @@
+(defpackage :tensor
+ (:use :cl :utilities))
+
+(in-package :tensor)
+
+;;
+(declaim (inline allocate-integer4-store))
+
+(eval-when (load eval compile)
+ (deftype int32-type ()
+ '(signed-byte 32))
+ (deftype int32-array (size)
+ `(simple-array int32-type (,size)))
+
+ ;;
+ (deftype index-type ()
+ 'fixnum)
+ (deftype index-array (size)
+ `(simple-array index-type (,size)))
+ )
+
+(defun allocate-int32-store (size &optional (initial-element 0))
+ "(ALLOCATE-INTEGER-STORE SIZE [INITIAL-ELEMENT]). Allocates
+integer storage. Default INITIAL-ELEMENT = 0."
+ (make-array size
+ :element-type 'int32-type
+ :initial-element initial-element))
+
+(defun allocate-index-store (size &optional (initial-element 0))
+ (make-array size :element-type 'index-type
+ :initial-element initial-element))
+
+(defun make-index-store (&rest contents)
+ (let ((size (length contents)))
+ (make-array size :element-type 'index-type
+ :initial-contents contents)))
+
+;;
+(defun store-indexing-internal (idx strides &optional (hd (the index-type 0)))
+ "No explicit error checking, meant to be used internally.
+ Returns
+
+ length(strides)
+ __
+ hd + \ stride * idx
+ /_ i i
+ i = 0
+
+ "
+ (declare (type index-type hd)
+ (type (index-array *) idx strides))
+ (let ((rank (length strides)))
+ (declare (type index-type rank))
+ (the index-type (+ hd
+ (do ((i 0 (+ i 1))
+ (sto-idx (the index-type 0) (the index-type
+ (+ sto-idx
+ (the index-type
+ (* (the index-type
+ (aref idx i))
+ (the index-type
+ (aref strides i))))))))
+ ((= i rank) sto-idx))))))
+
+
+(defun store-indexing-vec (idx strides dims &optional (hd (the index-type 0)))
+ "
+ Returns
+
+ length(strides)
+ __
+ hd + \ stride * idx
+ /_ i i
+ i = 0
+
+ "
+ (declare (type index-type hd)
+ (type (index-array *) idx strides))
+ (let ((rank (length strides)))
+ (declare (type index-type rank))
+ (unless (= rank (length idx))
+ (error "Wrong number of subscripts for a array of rank ~A" rank))
+ (the index-type (+ hd
+ (do ((i 0 (+ i 1))
+ (sto-idx (the index-type 0) (the index-type
+ (+ sto-idx
+ (the index-type
+ (* (the index-type
+ (aref strides i))
+ ;;
+ (the index-type
+ (let ((cidx (aref idx i)))
+ (unless (< -1 cidx (aref dims i))
+ (error "Requested index ~A for argument ~A is out of bounds.
+Tensor only has dimension ~A for the ~A argument." cidx i (aref dims i) i))
+ cidx))))))))
+ ((= i rank) sto-idx))))))
+
+
+(defun store-indexing-lst (idx strides dims &optional (hd (the index-type 0)))
+ "
+ Returns
+
+ length(strides)
+ __
+ hd + \ stride * idx
+ /_ i i
+ i = 0
+
+ "
+ (declare (type index-type hd)
+ (type (index-array *) strides)
+ (type cons idx))
+ (let ((rank (length strides)))
+ (declare (type index-type rank))
+ (the index-type (+ hd
+ (let ((idx-sum (the index-type 0)))
+ (do ((i 0 (+ i 1))
+ (ilst idx (cdr ilst)))
+ ((= i rank) (if (null ilst)
+ idx-sum
+ (error "Too many subscripts for a tensor of rank ~A" rank)))
+ (let ((cidx (car ilst)))
+ (when (null cidx)
+ (error "Too few subscripts for a tensor of rank ~A" rank))
+ (unless (< -1 cidx (aref dims i))
+ (error "Requested index ~A for argument ~A is out of bounds.
+Tensor only has dimension ~A for the ~A argument." cidx i (aref dims i) i))
+ ;;
+ (setf idx-sum (the index-type (+ idx-sum
+ (the index-type
+ (*
+ (the index-type cidx)
+ (the index-type (aref strides i))))))))))))))
+
+;;
+(defclass standard-tensor ()
+ ((rank
+ :accessor rank
+ :type index-type
+ :documentation "Rank of the tensor: number of arguments for the tensor")
+ (dimensions
+ :accessor dimensions
+ :initarg :dimensions
+ :type (index-array *)
+ :documentation "Dimensions of the vector spaces in which the tensor's arguments reside.")
+ (number-of-elements
+ :accessor number-of-elements
+ :type index-type
+ :documentation "Total number of elements in the tensor.")
+ ;;
+ (head
+ :initarg :head
+ :initform 0
+ :accessor head
+ :type index-type
+ :documentation "Head for the store's accessor.")
+ (strides
+ :initarg :strides
+ :accessor strides
+ :type (index-array *)
+ :documentation "Strides for accesing elements of the tensor.")
+ (store-size
+ :accessor store-size
+ :type index-type
+ :documentation "Size of the store.")
+ (store
+ :initarg :store
+ :accessor store
+ :documentation "The actual storage for the tensor."))
+ (:documentation "Basic tensor class."))
+
+;;
+(defun store-indexing (idx tensor)
+ (declare (type standard-tensor tensor)
+ (type (or cons (index-array *)) idx))
+ (typecase idx
+ (cons (store-indexing-lst idx (strides tensor) (dimensions tensor) (head tensor)))
+ (vector (store-indexing-lst idx (strides tensor) (dimensions tensor) (head tensor)))))
+
+;;
+(defmethod initialize-instance :after ((tensor standard-tensor) &rest initargs)
+ (declare (ignore initargs))
+ (mlet*
+ (((dims hd ss) (slot-values tensor '(dimensions head store-size))
+ :type ((index-array *) index-type index-type))
+ (rank (length dims) :type index-type))
+ ;;Let the object be consistent.
+ (setf (rank tensor) rank)
+ ;;Row-ordered by default.
+ (unless (and (slot-boundp tensor 'strides)
+ (= (length (strides tensor)) rank))
+ (mlet* ((stds (allocate-index-store rank)
+ :type (index-array *)))
+ (setf (strides tensor) stds)
+ (do ((i (1- rank) (1- i))
+ (st 1 (* st (aref dims i))))
+ ((< i 0))
+ (setf (aref stds i) st))))
+ ;;
+ (mlet* ((stds (strides tensor) :type (index-array *))
+ (L-idx (store-indexing-vec (map `(index-array *) #'1- dims) stds dims hd) :type index-type))
+ ;;Error checking is good if we use foreign-pointers as store types.
+ (cond
+ ((< hd 0) (error "Head of the store must be >= 0. Initialized with ~A." hd))
+ ((<= ss L-idx) (error "Store is not large enough to hold the matrix.
+Initialized with ~A, but the largest possible index is ~A." ss L-idx)))
+ ;;
+ (dotimes (i rank)
+ (let ((ns (aref dims i))
+ (st (aref stds i)))
+ (cond
+ ((<= ns 0) (error "Dimension ~A must be > 0.
+Initialized with ~A." i ns))
+ ((< st 0) (error "Stride of dimension ~A must be >= 0.
+Initialized with ~A." i st))))))
+ ;;
+ (setf (number-of-elements tensor) (reduce #'* dims))))
+
+;;
+(defgeneric tensor-store-ref (tensor store-idx)
+ (:documentation "
+ Syntax
+ ======
+ (tensor-ref-1d store store-idx)
+
+ Purpose
+ =======
+ Return the element store-idx of the tensor store."))
+
+(defmethod tensor-store-ref :before ((tensor standard-tensor) (idx fixnum))
+ (unless (< -1 idx (store-size tensor))
+ (error "Requested index ~A is out of bounds.
+Tensor-store only has ~A elements." idx (store-size tensor))))
+
+;;
+(defgeneric (setf tensor-store-ref) (value matrix idx))
+
+(defmethod (setf tensor-store-ref) :before ((value t) (tensor standard-tensor) (idx fixnum))
+ (unless (< -1 idx (store-size tensor))
+ (error "Requested index ~A is out of bounds.
+Tensor-store only has ~A elements." idx (store-size tensor))))
+
+;;
+(defgeneric tensor-ref (tensor &rest subscripts)
+ (:documentation "
+ Syntax
+ ======
+ (tensor-ref store &rest subscripts)
+
+ Purpose
+ =======
+ Return the element:
+
+ (rank - 1)
+ __
+ hd + \ stride * sub
+ /_ i i
+ i = 0
+
+ of the store "))
+
+(defmethod tensor-ref ((tensor standard-tensor) &rest subscripts)
+ (let ((sto-idx (store-indexing subscripts tensor)))
+ (tensor-store-ref tensor sto-idx)))
+
+;;
+(defgeneric (setf tensor-ref) (value tensor &rest subscripts))
+
+(defmethod (setf tensor-ref) ((value t) (tensor standard-tensor) &rest subscripts)
+ (let ((sto-idx (store-indexing subscripts tensor)))
+ (setf (tensor-store-ref tensor sto-idx) value)))
+
+;;
+;; TODO: Pretty-ify by borrowing from src/print.lisp
+(defmethod print-object ((tensor standard-tensor) stream)
+ (let ((rank (rank tensor))
+ (dims (dimensions tensor)))
+ (labels ((rec-print (tensor idx subs)
+ (if (> idx 1)
+ (dotimes (i (aref dims idx))
+ (rec-print tensor (1- idx) (cons i subs)))
+ (progn
+ (format stream "~A~%" (append (list '\: '\:) subs))
+ (dotimes (i (aref dims 0))
+ (dotimes (j (aref dims 1))
+ (format stream "~A~,4T" (apply #'tensor-ref (cons tensor (append (list i j) subs)))))
+ (format stream "~%~%"))))))
+ (format stream "<TENSOR(~A) ~A>~%" rank dims)
+ (if (= rank 1)
+ (progn
+ (dotimes (i (aref dims 0))
+ (format stream "~A~,4T" (tensor-ref tensor i)))
+ (format stream "~%"))
+ (rec-print tensor (- rank 1) nil)))))
+;;
+(defun tensor-type-p (tensor &rest subscripts)
+ "
+ Syntax
+ ======
+ (tensor-ref tensor &rest subscripts)
+
+ Purpose
+ =======
+ Check if the given tensor is of particular sizes in particular
+ arguments.
+
+ Checking if the tensor is a vector would then be:
+ (tensor-type-p ten t)
+
+ Checking if it is a matrix with 2 columns would be:
+ (tensor-type-p ten t 2)
+ "
+ (declare (type standard-tensor tensor))
+ (mlet* (((rank dims) (slot-values tensor '(rank dimensions))
+ :type (index-type (index-array *))))
+ (let ((syms->val (make-hash-table)))
+ (labels ((parse-sub (lst i)
+ (let ((val (car lst)))
+ (cond
+ ((= i rank) t)
+ ((null val) nil)
+ ((eq val t) (parse-sub (cdr lst) (1+ i)))
+ (t (progn
+ (when (symbolp val)
+ (multiple-value-bind (hash-val existp) (gethash val syms->val)
+ (if existp
+ (setq val hash-val)
+ (setf (gethash val syms->val) (aref dims i)
+ val (aref dims i)))))
+ (if (= val (aref dims i))
+ (parse-sub (cdr lst) (1+ i))
+ nil)))))))
+ (parse-sub subscripts 0)))))
+
+(defun vector-p (tensor)
+ (declare (type standard-tensor tensor))
+ (tensor-type-p tensor t))
+
+(defun matrix-p (tensor)
+ (declare (type standard-tensor tensor))
+ (tensor-type-p tensor t t))
+
+(defun square-p (tensor)
+ (let* ((rank (rank tensor))
+ (sym (gensym))
+ (lst (make-list rank :initial-element sym)))
+ (apply #'tensor-type-p (cons tensor lst))))
\ No newline at end of file
-----------------------------------------------------------------------
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-04-14 10:16:01
|
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 20c39c7a913544c3f542fd338568aec439fbd838 (commit)
from b69c4cba35a5d7644c60cdc8b830f60bea9f4b1e (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 20c39c7a913544c3f542fd338568aec439fbd838
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Apr 14 15:42:11 2012 +0530
Moved tensor development to a new branch.
diff --git a/src/tensor.lisp b/src/tensor.lisp
deleted file mode 100644
index 5d3819f..0000000
--- a/src/tensor.lisp
+++ /dev/null
@@ -1,415 +0,0 @@
-;; Definitions of STANDARD-MATRIX
-;;(in-package :matlisp)
-
-;;
-(declaim (inline allocate-integer4-store))
-
-(eval-when (load eval compile)
- (deftype integer4-matrix-element-type ()
- '(signed-byte 32))
-
- (deftype index-type ()
- 'fixnum)
- (deftype index-array-type (size)
- '(simple-array index-type (,size)))
- )
-
-(defun allocate-integer4-store (size &optional (initial-element 0))
- "(ALLOCATE-INTEGER-STORE SIZE [INITIAL-ELEMENT]). Allocates
-integer storage. Default INITIAL-ELEMENT = 0."
- (make-array size
- :element-type 'integer4-matrix-element-type
- :initial-element initial-element))
-
-;;
-(defclass standard-tensor ()
- ((rank
- :accessor rank
- :type index-type
- :documentation "Rank of the matrix: number of arguments for the tensor")
- (dimensions
- :accessor dimensions
- :initarg :dimensions
- :type (index-array-type *)
- :documentation "Dimensions of the vector spaces in which the tensor's arguments reside.")
- (number-of-elements
- :accessor number-of-elements
- :type fixnum
- :documentation "Total number of elements in the tensor.")
- ;;
- (head
- :initarg :head
- :initform 0
- :accessor head
- :type index-type
- :documentation "Head for the store's accessor.")
- (strides
- :initarg :strides
- :accessor strides
- :type (index-array-type *)
- :documentation "Strides for accesing elements of the tensor.")
- (store-size
- :accessor store-size
- :type fixnum
- :documentation "Size of the store.")
- (store
- :initarg :store
- :accessor store
- :documentation "The actual storage for the tensor."))
- (:documentation "Basic matrix class."))
-
-;;
-(defmethod initialize-instance :after ((tensor standard-tensor) &rest initargs)
- (declare (ignore initargs))
- (mlet*
- (((dimensions hd) (slot-values tensor '(dimensions head))
- :type ((index-array-type *) fixnum fixnum)))
- (unless (slot-boundp tensor 'rank)
- (setf (rank tensor) (len
- ;;Row-ordered by default.
- (unless (and (slot-boundp matrix 'row-stride) (slot-boundp matrix 'col-stride))
- (setf (row-stride matrix) nc)
- (setf (col-stride matrix) 1))
- (let* ((rs (row-stride matrix))
- (cs (col-stride matrix))
- (l-idx (store-indexing (- nr 1) (- nc 1) hd rs cs)))
- (declare (type fixnum rs cs))
- ;;Error checking is good if we use foreign-pointers as store types.
- (cond
- ((<= nr 0) (error "Number of rows must be > 0. Initialized with ~A." nr))
- ((<= nc 0) (error "Number of columns must be > 0. Initialized with ~A." nc))
- ;;
- ((< hd 0) (error "Head of the store must be >= 0. Initialized with ~A." hd))
- ((< rs 0) (error "Row-stride of the store must be >= 0. Initialized with ~A." rs))
- ((< cs 0) (error "Column-stride of the store must be >= 0. Initialized with ~A." cs))
- ((<= ss l-idx) (error "Store is not large enough to hold the matrix.
-Initialized with ~A, but the largest possible index is ~A." ss l-idx))))
- ;;
- (setf (number-of-elements matrix) (* nr nc))))
-
-;;
-(defmacro matrix-ref (matrix row &optional col)
- (if col
- `(matrix-ref-2d ,matrix ,row ,col)
- `(matrix-ref-1d ,matrix ,row)))
-
-;;
-(defgeneric matrix-ref-1d (matrix store-idx)
- (:documentation "
- Syntax
- ======
- (matrix-REF-1d store store-idx)
-
- Purpose
- =======
- Return the element store-idx of the matrix store."))
-
-#+nil(defmethod matrix-ref-1d :before ((matrix standard-matrix) (idx fixnum))
- (unless (< -1 (- idx (head matrix)) (number-of-elements matrix))
- (error "Requested index ~A is out of bounds.
-Matrix only has ~A elements." idx (number-of-elements matrix))))
-
-;;
-(defgeneric (setf matrix-ref-1d) (value matrix idx))
-
-#+nil(defmethod (setf matrix-ref-1d) :before ((value t) (matrix standard-matrix) (idx fixnum))
- (unless (< -1 idx (number-of-elements matrix))
- (error "Requested index ~A is out of bounds.
-Matrix only has ~A elements." idx (number-of-elements matrix))))
-
-;;
-(defgeneric matrix-ref-2d (matrix rows cols)
- (:documentation "
- Syntax
- ======
- (MATRIX-REF-2d store i j)
-
- Purpose
- =======
- Return the element
- (+
- (* (row-stride store) i)
- (* (col-stride store) j))
- of the store "))
-
-(defmethod matrix-ref-2d :before ((matrix standard-matrix) (rows fixnum) (cols fixnum))
- (unless (and (< -1 rows (nrows matrix))
- (< -1 cols (ncols matrix)))
- (error "Requested index (~A ~A) is out of bounds." rows cols)))
-
-(defmethod matrix-ref-2d ((matrix standard-matrix) (rows fixnum) (cols fixnum))
- (matrix-ref-1d matrix (store-indexing rows cols (head matrix) (row-stride matrix) (col-stride matrix))))
-
-;;
-(defgeneric (setf matrix-ref-2d) (value matrix rows cols))
-
-(defmethod (setf matrix-ref-2d) ((value t) (matrix standard-matrix) (rows fixnum) (cols fixnum))
- (setf (matrix-ref-1d matrix (store-indexing rows cols (head matrix) (row-stride matrix) (col-stride matrix))) value))
-
-;;
-(defgeneric row-vector-p (matrix)
- (:documentation "
- Syntax
- ======
- (ROW-VECTOR-P x)
-
- Purpose
- =======
- Return T if X is a row vector (number of columns is 1)"))
-
-(declaim (inline row-vector-p))
-(defmethod row-vector-p ((matrix standard-matrix))
- (= (nrows matrix) 1))
-
-;;
-(defgeneric col-vector-p (matrix)
- (:documentation "
- Syntax
- ======
- (COL-VECTOR-P x)
-
- Purpose
- =======
- Return T if X is a column vector (number of rows is 1)"))
-
-(declaim (inline col-vector-p))
-(defmethod col-vector-p ((matrix standard-matrix))
- (= (ncols matrix) 1))
-
-;;
-(defgeneric row-or-col-vector-p (matrix)
- (:documentation "
- Syntax
- ======
- (ROW-OR-COL-VECTOR-P x)
-
- Purpose
- =======
- Return T if X is either a row or a column vector"))
-
-(declaim (inline row-or-col-vector-p))
-(defmethod row-or-col-vector-p ((matrix standard-matrix))
- (or (row-vector-p matrix) (col-vector-p matrix)))
-
-;;
-(defgeneric square-matrix-p (matrix)
- (:documentation "
- Syntax
- ======
- (SQUARE-MATRIX-P x)
-
- Purpose
- =======
- Return T if X is square matrix"))
-
-(declaim (inline square-matrix-p))
-(defmethod square-matrix-p ((matrix standard-matrix))
- (= (nrows matrix) (ncols matrix)))
-
-;;
-(defgeneric size (matrix)
- (:documentation "
- Syntax
- ======
- (SIZE x)
-
- Purpose
- =======
- Return the number of rows and columns of the matrix X as a list"))
-
-(defmethod size ((matrix standard-matrix))
- (list (nrows matrix) (ncols matrix)))
-
-;;
-(defgeneric fill-matrix (matrix fill-element)
- (:documentation
- "
- Syntax
- ======
- (FILL-MATRIX matrix fill-element)
-
- Purpose
- =======
- Fill MATRIX with FILL-ELEMENT.
-"))
-
-(defmethod fill-matrix ((matrix t) (fill t))
- (error "arguments MATRIX and FILL to FILL-MATRIX must be a
-matrix and a number"))
-
-;;
-(defmethod make-load-form ((matrix standard-matrix) &optional env)
- "MAKE-LOAD-FORM allows us to determine a load time value for
- matrices, for example #.(make-matrix ...)"
- (make-load-form-saving-slots matrix :environment env))
-
-;;
-#+nil(defmethod print-object ((matrix standard-matrix) stream)
- (dotimes (i (nrows matrix))
- (dotimes (j (ncols matrix))
- (format stream "~A " (matrix-ref-2d matrix i j)))
- (format stream "~%")))
-
-;;
-(defun transpose! (matrix)
-"
- Syntax
- ======
- (transpose! matrix)
-
- Purpose
- =======
- Exchange row and column strides so that effectively
- the matrix is destructively transposed in place
- (without much effort).
-"
- (cond
- ((typep matrix 'standard-matrix)
- (progn
- (rotatef (nrows matrix) (ncols matrix))
- (rotatef (row-stride matrix) (col-stride matrix))
- matrix))
- ((typep matrix 'number) matrix)
- (t (error "Don't know how to take the transpose of ~A." matrix))))
-
-(defmacro with-transpose! (matlst &rest body)
- `(progn
- ,@(mapcar #'(lambda (mat) `(transpose! ,mat)) matlst)
- ,@body
- ,@(mapcar #'(lambda (mat) `(transpose! ,mat)) matlst)))
-
-;;
-(defgeneric transpose (matrix)
- (:documentation
-"
- Syntax
- ======
- (transpose matrix)
-
- Purpose
- =======
- Create a new matrix object which represents the transpose of the
- the given matrix.
-
- Store is shared with \"matrix\".
-
- Settable
- ========
- (setf (transpose matrix) value)
-
- is basically the same as
-
- (copy! value (transpose matrix))
-"))
-
-(defun (setf transpose) (value matrix)
- (copy! value (transpose matrix)))
-
-(defmethod transpose ((matrix number))
- matrix)
-
-;;
-(defgeneric sub-matrix (matrix origin dim)
- (:documentation
-"
- Syntax
- ======
- (sub-matrix matrix origin dimensions)
-
- Purpose
- =======
- Create a block sub-matrix of \"matrix\" starting at \"origin\"
- of dimension \"dim\", sharing the store.
-
- origin, dim are lists with two elements.
-
- Store is shared with \"matrix\"
-
- Settable
- ========
- (setf (sub-matrix matrix origin dim) value)
-
- is basically the same as
-
- (copy! value (sub-matrix matrix origin dim))
-"))
-
-(defun (setf sub-matrix) (value matrix origin dim)
- (copy! value (sub-matrix matrix origin dim)))
-
-;;
-(defgeneric row (matrix i)
- (:documentation
-"
- Syntax
- ======
- (row matrix i)
-
- Purpose
- =======
- Returns the i'th row of the matrix.
- Store is shared with \"matrix\".
-
- Settable
- ========
- (setf (row matrix i) value)
-
- is basically the same as
-
- (copy! value (row matrix i))
-"))
-
-(defun (setf row) (value matrix i)
- (copy! value (row matrix i)))
-
-;;
-(defgeneric col (matrix j)
- (:documentation
-"
- Syntax
- ======
- (col matrix j)
-
- Purpose
- =======
- Returns the j'th column of the matrix.
- Store is shared with \"matrix\".
-
- Settable
- ========
- (setf (col matrix j) value)
-
- is basically the same as
-
- (copy! value (col matrix j))
-"))
-
-(defun (setf col) (value matrix j)
- (copy! value (col matrix j)))
-
-;;
-(defgeneric diag (matrix &optional d)
- (:documentation
-"
- Syntax
- ======
- (diag matrix &optional (d 0))
-
- Purpose
- =======
- Returns a row-vector representing the d'th diagonal of the matrix.
- [a_{ij} : j - i = d]
-
- Store is shared with \"matrix\".
-
- Settable
- ========
- (setf (diag matrix d) value)
-
- is basically the same as
-
- (copy! value (diag matrix d))
-"))
-
-(defun (setf diag) (value matrix &optional (d 0))
- (copy! value (diag matrix d)))
\ No newline at end of file
-----------------------------------------------------------------------
Summary of changes:
src/tensor.lisp | 415 -------------------------------------------------------
1 files changed, 0 insertions(+), 415 deletions(-)
delete mode 100644 src/tensor.lisp
hooks/post-receive
--
matlisp
|
|
From: Raymond T. <rt...@us...> - 2012-03-31 03:16:41
|
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 b69c4cba35a5d7644c60cdc8b830f60bea9f4b1e (commit)
from 21d8ce7bad4335a01727786b8114af348c31d3c9 (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 b69c4cba35a5d7644c60cdc8b830f60bea9f4b1e
Author: Raymond Toy <toy...@gm...>
Date: Fri Mar 30 20:16:18 2012 -0700
Use with-fortran-matrices.
diff --git a/src/colnew-demo2.lisp b/src/colnew-demo2.lisp
index f358b9c..f5ad007 100644
--- a/src/colnew-demo2.lisp
+++ b/src/colnew-demo2.lisp
@@ -9,95 +9,100 @@
(defvar *xt* (sqrt (/ (* 2 (- *gamma* 1)) *gamma*)))
-(defun fsub (x z f)
- (setf (fv-ref f 0)
- (+ (/ (fv-ref z 0) x x)
- (- (/ (fv-ref z 1) x))
- (/ (- (fv-ref z 0)
- (* (fv-ref z 2)
- (- 1 (/ (fv-ref z 0)
- x)))
- (* *gamma* x (- 1
- (* x x 0.5d0))))
- *eps4mu*)))
- (setf (fv-ref f 1)
- (+ (/ (fv-ref z 2) x x)
- (/ (- (fv-ref z 3)) x)
- (* (fv-ref z 0)
- (/ (- 1 (/ (fv-ref z 0) 2 x))
- *dmu*)))))
+(defun fsub (x a-z a-f)
+ (utilities::with-fortran-matrices ((z a-z (1 2))
+ (f a-f (1 4)))
+ (setf (f 1)
+ (+ (/ (z 1) x x)
+ (- (/ (z 2) x))
+ (/ (- (z 1)
+ (* (z 3)
+ (- 1 (/ (z 1)
+ x)))
+ (* *gamma* x (- 1
+ (* x x 0.5d0))))
+ *eps4mu*)))
+ (setf (f 2)
+ (+ (/ (z 3) x x)
+ (/ (- (z 4)) x)
+ (* (z 1)
+ (/ (- 1 (/ (z 1) 2 x))
+ *dmu*))))))
-(defun dfsub (x z df)
- (let ((nrows 2))
- (flet ((column-major-index (r c)
- (+ (- r 1)
- (* (- c 1) nrows))))
- (setf (fv-ref df (column-major-index 1 1))
- (+ (/ 1 x x)
- (/ (+ 1
- (/ (fv-ref z 2)
+(defun dfsub (x a-z a-df)
+ (utilities::with-fortran-matrices ((d a-df (1 2) (1 4))
+ (z a-z (1 4)))
+ (setf (d 1 1)
+ (+ (/ 1 x x)
+ (/ (+ 1
+ (/ (z 3)
+ x))
+ *eps4mu*)))
+ (setf (d 1 2)
+ (/ -1 x))
+ (setf (d 1 3)
+ (- (/ (- 1 (/ (z 1)
x))
- *eps4mu*)))
- (setf (fv-ref df (column-major-index 1 2))
- (/ -1 x))
- (setf (fv-ref df (column-major-index 1 3))
- (- (/ (- 1 (/ (fv-ref z 0)
- x))
- *eps4mu*)))
- (setf (fv-ref df (column-major-index 1 4))
- 0d0)
- (setf (fv-ref df (column-major-index 2 1))
- (/ (- 1
- (/ (fv-ref z 0)
- x))
- *dmu*))
- (setf (fv-ref df (column-major-index 2 2))
- 0d0)
- (setf (fv-ref df (column-major-index 2 3))
- (/ 1 x x))
- (setf (fv-ref df (column-major-index 2 4))
- (/ -1 x)))))
+ *eps4mu*)))
+ (setf (d 1 4)
+ 0d0)
+ (setf (d 2 1)
+ (/ (- 1
+ (/ (z 1)
+ x))
+ *dmu*))
+ (setf (d 2 2)
+ 0d0)
+ (setf (d 2 3)
+ (/ 1 x x))
+ (setf (d 2 4)
+ (/ -1 x))))
-(defun gsub (i z g)
- (case i
- ((or 1 3)
- (setf (fv-ref g 0) (fv-ref z 0)))
- (2
- (setf (fv-ref g 0) (fv-ref z 2)))
- (4
- (setf (fv-ref g 0) (+ (fv-ref z 3)
- (* -0.3d0 (fv-ref z 2))
- 0.7d0)))))
+(defun gsub (i a-z a-g)
+ (utilities::with-fortran-matrices ((z a-z (1 4))
+ (g a-g (1 4)))
+ (case i
+ ((or 1 3)
+ (setf (g 1) (z 1)))
+ (2
+ (setf (g 1) (z 3)))
+ (4
+ (setf (g 1) (+ (z 4)
+ (* -0.3d0 (z 3))
+ 0.7d0))))))
-(defun dgsub (i z dg)
- (dotimes (k 4)
- (setf (fv-ref dg k) 0d0))
- (case i
- ((or 1 3)
- (setf (fv-ref dg 0) 1d0))
- (2
- (setf (fv-ref dg 2) 1d0))
- (4
- (setf (fv-ref dg 3) 1d0)
- (setf (fv-ref dg 2) -0.3d0))))
+(defun dgsub (i a-z a-dg)
+ (utilities::with-fortran-matrices ((dg a-dg (1 4)))
+ (loop for k from 1 upto 4 do
+ (setf (dg k) 0d0))
+ (case i
+ ((or 1 3)
+ (setf (dg 1) 1d0))
+ (2
+ (setf (dg 3) 1d0))
+ (4
+ (setf (dg 4) 1d0)
+ (setf (dg 3) -0.3d0)))))
(defun guess (x z dmval)
(let ((con (* *gamma* x (- 1 (* 0.5d0 x x))))
(dcon (* *gamma* (- 1 (* 1.5d0 x x))))
(d2con (* -3 *gamma* x)))
- (cond ((<= x *xt*)
- (setf (fv-ref z 0) (* 2 x))
- (setf (fv-ref z 1) 2d0)
- (setf (fv-ref z 2) (+ (* -2 x) con))
- (setf (fv-ref z 3) (+ dcon -2d0))
- (setf (fv-ref dmval 1) d2con))
- (t
- (setf (fv-ref z 0) 0d0)
- (setf (fv-ref z 1) 0d0)
- (setf (fv-ref z 2) (- con))
- (setf (fv-ref z 3) (- dcon))
- (setf (fv-ref dmval 1) (- d2con))))
- (setf (fv-ref dmval 0) 0d0)))
+ (utilities::with-fortran-matrices ((z z (1 4))
+ (dmval dmval (1 2)))
+ (cond ((<= x *xt*)
+ (setf (z 1) (* 2 x))
+ (setf (z 2) 2d0)
+ (setf (z 3) (+ (* -2 x) con))
+ (setf (z 4) (+ dcon -2d0))
+ (setf (dmval 2) d2con))
+ (t
+ (setf (z 1) 0d0)
+ (setf (z 2) 0d0)
+ (setf (z 3) (- con))
+ (setf (z 4) (- dcon))
+ (setf (dmval 2) (- d2con))))
+ (setf (dmval 1) 0d0))))
(defun colnew-prob2 ()
-----------------------------------------------------------------------
Summary of changes:
src/colnew-demo2.lisp | 165 +++++++++++++++++++++++++------------------------
1 files changed, 85 insertions(+), 80 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Raymond T. <rt...@us...> - 2012-03-31 02:36:48
|
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 21d8ce7bad4335a01727786b8114af348c31d3c9 (commit)
from 45e57ae1f888c8c271a91d42b9231b99bd55691e (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 21d8ce7bad4335a01727786b8114af348c31d3c9
Author: Raymond Toy <toy...@gm...>
Date: Fri Mar 30 19:36:29 2012 -0700
Add WITH-FORTRAN-MATRICES to make it a little easier to deal with
Fortran arrays in callback functions.
diff --git a/src/utilities.lisp b/src/utilities.lisp
index 5bf4237..bbd8ad2 100644
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -225,4 +225,80 @@ else run else-body"
(unless (< -1 n ss)
(error "Index N out of bounds."))
(setf (cffi:mem-aref sap sty n) value)))
+
+
+;;; Rudimentary support for making it a bit easier to deal with Fortran
+;;; arrays in callbacks.
+
+;; If the Array dimensions are (d1, d2, d3, ...)
+;;
+;; Then x(n1, n2, n3, ...) means the index is, essentially,
+;;
+;; n1 + d1*(n2 + d2*(n3 + d3*(n4 + d4*(n5))))
;;
+;; Return an expression that computes the column major index given the
+;; indices (a list) and a list of the bounds on each dimension. Each
+;; bound is a list of the upper and lower bounds for each dimension.
+;; For example, for the Fortran array declared as x(3:10, -4:2), the
+;; bounds would be written as ((3 10) (-4 2)). If the lower bound is
+;; the default of 1, you can omit the lower bound.
+(defun col-major-index (indices dims)
+ ;; Return a form that computes the column major index of a Fortran array.
+ (flet ((get-offset (n bound)
+ (let ((lo (first bound)))
+ (if (and (numberp lo) (zerop lo))
+ n
+ `(the fixnum (- (the fixnum ,n) (the fixnum ,lo))))))
+ (get-size (bound)
+ (destructuring-bind (lo hi)
+ bound
+ (cond ((numberp lo)
+ (cond ((numberp hi)
+ (1+ (- hi lo)))
+ ((= lo 1)
+ hi)
+ (t
+ `(- ,hi ,(- lo 1)))))
+ (t
+ `(the fixnum (- ,hi (the fixnum (- (the fixnum ,lo) 1)))))))))
+ (let* ((rev-idx (reverse indices))
+ (rev-dim (reverse dims))
+ (idx (get-offset (first rev-idx) (first rev-dim))))
+ (do ((d (rest rev-dim) (rest d))
+ (n (rest rev-idx) (rest n)))
+ ((endp d)
+ idx)
+ (setf idx `(the fixnum (+ ,(get-offset (first n) (first d))
+ (the fixnum (* ,(get-size (first d)) ,idx)))))))))
+
+(defmacro with-fortran-matrix ((name fv &rest dims) &body body)
+ (let ((indices (gensym (symbol-name '#:indices-))))
+ `(macrolet ((,name (&rest ,indices)
+ `(fv-ref ,',fv ,(col-major-index ,indices ',dims))))
+ ,@body)))
+
+;; WITH-FORTRAN-MATRICES is a convenience macro for accessing Fortran
+;; arrays that have been passed in as parameters of a callback.
+;;
+;; For example, Fortran callback function that might be
+;;
+;; subroutine sub(z, f)
+;; real z(4), df(2, 4)
+;; df(1,4) = 3*z(2)
+;; end
+;;
+;; This can be written in a Lisp call back as
+;;
+;; (defun fsub (z-arg f-arg)
+;; (with-fortran-matrices ((z z-arg (1 4))
+;; (f f-arg ((1 2) (1 4))))
+;; (setf (f 1 4) (* 3 (z 2)))))
+;;
+
+(defmacro with-fortran-matrices ((&rest array-list) &body body)
+ (if (cdr array-list)
+ `(with-fortran-matrix ,(car array-list)
+ (with-fortran-matrices ,(cdr array-list)
+ ,@body))
+ `(with-fortran-matrix ,(car array-list)
+ ,@body)))
\ No newline at end of file
-----------------------------------------------------------------------
Summary of changes:
src/utilities.lisp | 76 ++++++++++++++++++++++++++++++++++++++++++++++++++++
1 files changed, 76 insertions(+), 0 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Raymond T. <rt...@us...> - 2012-03-27 05:40:23
|
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 45e57ae1f888c8c271a91d42b9231b99bd55691e (commit)
from d54f0adc84bb64c23dbbc4bbb1c7885e8cd610e6 (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 45e57ae1f888c8c271a91d42b9231b99bd55691e
Author: Raymond Toy <toy...@gm...>
Date: Mon Mar 26 22:39:54 2012 -0700
Add demo2 for colnew
src/colnew-demo2.lisp:
o Second example program for colnew.
src/colnew.lisp:
o Compute the dimensions of the vectors in the callbacks correctly.
matlisp.asd:
o Add colnew-demo2.lisp.
diff --git a/matlisp.asd b/matlisp.asd
index b72039e..adf4dd6 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -320,8 +320,7 @@
:components
((:file "colnew")
(:file "colnew-demo1" :depends-on ("colnew"))
- #+nil
- (:file "colnew-demo4" :depends-on ("colnew"))))))
+ (:file "colnew-demo2" :depends-on ("colnew"))))))
(defmethod perform ((op asdf:test-op) (c (eql (asdf:find-system :matlisp))))
(oos 'asdf:test-op 'matlisp-tests))
diff --git a/src/colnew-demo2.lisp b/src/colnew-demo2.lisp
new file mode 100644
index 0000000..f358b9c
--- /dev/null
+++ b/src/colnew-demo2.lisp
@@ -0,0 +1,145 @@
+;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: :matlisp; Base: 10 -*-
+
+(in-package #:matlisp)
+
+(defvar *gamma* 1.1d0)
+(defvar *eps* .01d0)
+(defvar *dmu* *eps*)
+(defvar *eps4mu* (/ (expt *eps* 4) *dmu*))
+(defvar *xt* (sqrt (/ (* 2 (- *gamma* 1)) *gamma*)))
+
+
+(defun fsub (x z f)
+ (setf (fv-ref f 0)
+ (+ (/ (fv-ref z 0) x x)
+ (- (/ (fv-ref z 1) x))
+ (/ (- (fv-ref z 0)
+ (* (fv-ref z 2)
+ (- 1 (/ (fv-ref z 0)
+ x)))
+ (* *gamma* x (- 1
+ (* x x 0.5d0))))
+ *eps4mu*)))
+ (setf (fv-ref f 1)
+ (+ (/ (fv-ref z 2) x x)
+ (/ (- (fv-ref z 3)) x)
+ (* (fv-ref z 0)
+ (/ (- 1 (/ (fv-ref z 0) 2 x))
+ *dmu*)))))
+
+(defun dfsub (x z df)
+ (let ((nrows 2))
+ (flet ((column-major-index (r c)
+ (+ (- r 1)
+ (* (- c 1) nrows))))
+ (setf (fv-ref df (column-major-index 1 1))
+ (+ (/ 1 x x)
+ (/ (+ 1
+ (/ (fv-ref z 2)
+ x))
+ *eps4mu*)))
+ (setf (fv-ref df (column-major-index 1 2))
+ (/ -1 x))
+ (setf (fv-ref df (column-major-index 1 3))
+ (- (/ (- 1 (/ (fv-ref z 0)
+ x))
+ *eps4mu*)))
+ (setf (fv-ref df (column-major-index 1 4))
+ 0d0)
+ (setf (fv-ref df (column-major-index 2 1))
+ (/ (- 1
+ (/ (fv-ref z 0)
+ x))
+ *dmu*))
+ (setf (fv-ref df (column-major-index 2 2))
+ 0d0)
+ (setf (fv-ref df (column-major-index 2 3))
+ (/ 1 x x))
+ (setf (fv-ref df (column-major-index 2 4))
+ (/ -1 x)))))
+
+(defun gsub (i z g)
+ (case i
+ ((or 1 3)
+ (setf (fv-ref g 0) (fv-ref z 0)))
+ (2
+ (setf (fv-ref g 0) (fv-ref z 2)))
+ (4
+ (setf (fv-ref g 0) (+ (fv-ref z 3)
+ (* -0.3d0 (fv-ref z 2))
+ 0.7d0)))))
+
+(defun dgsub (i z dg)
+ (dotimes (k 4)
+ (setf (fv-ref dg k) 0d0))
+ (case i
+ ((or 1 3)
+ (setf (fv-ref dg 0) 1d0))
+ (2
+ (setf (fv-ref dg 2) 1d0))
+ (4
+ (setf (fv-ref dg 3) 1d0)
+ (setf (fv-ref dg 2) -0.3d0))))
+
+(defun guess (x z dmval)
+ (let ((con (* *gamma* x (- 1 (* 0.5d0 x x))))
+ (dcon (* *gamma* (- 1 (* 1.5d0 x x))))
+ (d2con (* -3 *gamma* x)))
+ (cond ((<= x *xt*)
+ (setf (fv-ref z 0) (* 2 x))
+ (setf (fv-ref z 1) 2d0)
+ (setf (fv-ref z 2) (+ (* -2 x) con))
+ (setf (fv-ref z 3) (+ dcon -2d0))
+ (setf (fv-ref dmval 1) d2con))
+ (t
+ (setf (fv-ref z 0) 0d0)
+ (setf (fv-ref z 1) 0d0)
+ (setf (fv-ref z 2) (- con))
+ (setf (fv-ref z 3) (- dcon))
+ (setf (fv-ref dmval 1) (- d2con))))
+ (setf (fv-ref dmval 0) 0d0)))
+
+
+(defun colnew-prob2 ()
+ (let* (
+ (aleft 0d0)
+ (aright 1d0)
+ ;; Two differential equations
+ (ncomp 2)
+ ;; Orders of each equation
+ (m (make-array 2 :element-type '(signed-byte 32)
+ :initial-contents '(2 2)))
+ ;; Locations of side conditions
+ (zeta (make-array 4 :element-type 'double-float
+ :initial-contents '(0d0 0d0 1d0 1d0)))
+ (ipar (make-array 11 :element-type '(signed-byte 32)
+ :initial-element 0))
+ ;; Error tolerances on u and its second derivative
+ (ltol (make-array 4 :element-type '(signed-byte 32)
+ :initial-contents '(1 2 3 4)))
+ (tol (make-array 4 :element-type 'double-float
+ :initial-contents '(1d-5 1d-5 1d-5 1d-5)))
+ (fspace (make-array 40000 :element-type 'double-float))
+ (ispace (make-array 2500 :element-type '(signed-byte 32)))
+ (fixpnt (make-array 1 :element-type 'double-float)))
+ ;; Set up parameters of the problem.
+ (setf (aref ipar 0) 1) ; nonlinear problem
+ (setf (aref ipar 1) 4) ; 4 collocation points per subinterval
+ (setf (aref ipar 2) 10) ; Initial uniform mesh of 10 subintervals
+ (setf (aref ipar 7) 0)
+ (setf (aref ipar 4) 40000) ; Size of fspace
+ (setf (aref ipar 5) 2500) ; Size of ispace
+ (setf (aref ipar 6) -1) ; Full output
+ (setf (aref ipar 8) 1) ; Initial approx provided
+ (setf (aref ipar 9) 0) ; Regular problem
+ (setf (aref ipar 10) 0) ; No fixed points in mesh
+ (setf (aref ipar 3) 4) ; Tolerances on all components
+
+ (colnew ncomp m aleft aright zeta ipar ltol tol fixpnt ispace fspace 0
+ #'fsub #'dfsub #'gsub #'dgsub #'guess)
+ (let ((x 0d0)
+ (z (make-array 4 :element-type 'double-float)))
+ (dotimes (j 21)
+ (appsln x z fspace ispace)
+ (format t "~5,2f ~{~15,5e~}~%" x (coerce z 'list))
+ (incf x 0.05d0)))))
diff --git a/src/colnew.lisp b/src/colnew.lisp
index d47f76c..adefa60 100644
--- a/src/colnew.lisp
+++ b/src/colnew.lisp
@@ -4,6 +4,10 @@
(cffi:use-foreign-library colnew)
+(defun m* (ncomp m)
+ (loop for k from 0 below ncomp
+ sum (aref m k)))
+
(def-fortran-routine colnew :void
"COLNEW"
(ncomp :integer :input)
@@ -20,24 +24,24 @@
(iflag :integer :output)
(fsub (:callback :void
(x :double-float :input)
- (z (* :double-float :size (aref m 0)) :input)
- (f (* :double-float :size (aref m 0)) :output)))
+ (z (* :double-float :size (m* ncomp m)) :input)
+ (f (* :double-float :size ncomp) :output)))
(dfsub (:callback :void
(x :double-float :input)
- (z (* :double-float :size (aref m 0)) :input)
- (df (* :double-float :size (aref m 0)) :output)))
+ (z (* :double-float :size (m* ncomp m)) :input)
+ (df (* :double-float :size (* ncomp (m* ncomp m))) :output)))
(gsub (:callback :void
(i :integer :input)
- (z (* :double-float :size (aref m 0)) :input)
- (g (* :double-float :size (aref m 0)) :output)))
+ (z (* :double-float :size (m* ncomp m)) :input)
+ (g (* :double-float :size (m* ncomp m)) :output)))
(dgsub (:callback :void
(i :integer :input)
- (z (* :double-float :size (aref m 0)) :input)
- (dg (* :double-float :size (aref m 0)) :output)))
+ (z (* :double-float :size (m* ncomp m)) :input)
+ (dg (* :double-float :size (expt (m* ncomp m) 2)) :output)))
(guess (:callback :void
(x :double-float :input)
- (z (* :double-float) :output)
- (dmval (* :double-float) :output))))
+ (z (* :double-float :size (m* ncomp m)) :output)
+ (dmval (* :double-float :size ncomp) :output))))
(def-fortran-routine appsln :void
-----------------------------------------------------------------------
Summary of changes:
matlisp.asd | 3 +-
src/colnew-demo2.lisp | 145 +++++++++++++++++++++++++++++++++++++++++++++++++
src/colnew.lisp | 24 +++++----
3 files changed, 160 insertions(+), 12 deletions(-)
create mode 100644 src/colnew-demo2.lisp
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-03-25 03:39:31
|
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 d54f0adc84bb64c23dbbc4bbb1c7885e8cd610e6 (commit)
via 4010f091a89e7b2b0a606cdc3251124b609699c3 (commit)
from db5331565aae1b08109f11abba655999d3774c6e (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 d54f0adc84bb64c23dbbc4bbb1c7885e8cd610e6
Merge: db53315 4010f09
Author: Akshay Srinivasan <aks...@gm...>
Date: Sun Mar 25 09:06:04 2012 +0530
Merge branch 'local-cffi' into matlisp-cffi
commit 4010f091a89e7b2b0a606cdc3251124b609699c3
Author: Akshay Srinivasan <aks...@gm...>
Date: Sun Mar 25 09:02:55 2012 +0530
Move matrix modification routines into trans.lisp and sub-mat.lisp
diff --git a/src/real-matrix.lisp b/src/real-matrix.lisp
index b6b90a2..c02b9cf 100644
--- a/src/real-matrix.lisp
+++ b/src/real-matrix.lisp
@@ -56,73 +56,8 @@
don't know how to coerce COMPLEX to REAL"))
;;
-(defmethod transpose ((matrix real-matrix))
- (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
- :type (fixnum fixnum fixnum fixnum fixnum (real-matrix-store-type *))))
- (make-instance 'sub-real-matrix
- :nrows nc :ncols nr
- :store st
- :head hd
- :row-stride cs :col-stride rs
- :parent matrix)))
;;
-(defmethod sub-matrix ((matrix real-matrix) (origin list) (dim list))
- (destructuring-bind (o-i o-j) origin
- (destructuring-bind (nr-s nc-s) dim
- (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
- :type (fixnum fixnum fixnum fixnum fixnum (real-matrix-store-type *))))
- (unless (and (< -1 o-i (+ o-j nr-s) nr) (< -1 o-j (+ o-j nc-s) nc))
- (error "Bad index and/or size.
-Cannot create a sub-matrix of size (~a ~a) starting at (~a ~a)" nr-s nc-s o-i o-j))
- (make-instance 'sub-real-matrix
- :nrows nr-s :ncols nc-s
- :store st
- :head (store-indexing o-i o-j hd rs cs)
- :row-stride rs :col-stride cs)))))
-
-;;
-(defmethod row ((matrix real-matrix) (i fixnum))
- (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
- :type (fixnum fixnum fixnum fixnum fixnum (real-matrix-store-type *))))
- (unless (< -1 i nr)
- (error "Index ~a is outside the valid range for the given matrix." i))
- (make-instance 'sub-real-matrix
- :nrows 1 :ncols nc
- :store st
- :head (store-indexing i 0 hd rs cs)
- :row-stride rs :col-stride cs)))
-
-;;
-(defmethod col ((matrix real-matrix) (j fixnum))
- (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
- :type (fixnum fixnum fixnum fixnum fixnum (real-matrix-store-type *))))
- (unless (< -1 j nc)
- (error "Index ~a is outside the valid range for the given matrix." j))
- (make-instance 'sub-real-matrix
- :nrows nr :ncols 1
- :store st
- :head (store-indexing 0 j hd rs cs)
- :row-stride rs :col-stride cs)))
-
-;;
-(defmethod diag ((matrix real-matrix) &optional (d 0))
- (declare (type fixnum d))
- (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
- :type (fixnum fixnum fixnum fixnum fixnum (real-matrix-store-type *)))
- ((f-i f-j) (if (< d 0)
- (values (- d) 0)
- (values 0 d))
- :type (fixnum fixnum)))
- (unless (and (< -1 f-i nr) (< -1 f-j nc))
- (error "Index ~a is outside the valid range for the given matrix." d))
- (let ((d-s (min (- nr f-i) (- nc f-j))))
- (declare (type fixnum d-s))
- (make-instance 'sub-real-matrix
- :nrows 1 :ncols d-s
- :store st
- :head (store-indexing f-i f-j hd rs cs)
- :row-stride 1 :col-stride (+ rs cs)))))
;;
(defun make-real-matrix-dim (n m &key (fill 0.0d0) (order :row-major))
-----------------------------------------------------------------------
Summary of changes:
src/real-matrix.lisp | 65 --------------------------------------------------
1 files changed, 0 insertions(+), 65 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Raymond T. <rt...@us...> - 2012-03-25 02:58:36
|
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 db5331565aae1b08109f11abba655999d3774c6e (commit)
via 7fa7c24b0d56039a1fef930ffe2051b74c11ebeb (commit)
from 8191e3e96c966fc09587e44f98a09e42cd5985e9 (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 db5331565aae1b08109f11abba655999d3774c6e
Author: Raymond Toy <toy...@gm...>
Date: Sat Mar 24 19:58:21 2012 -0700
Document DEF-FORTRAN-ROUTINE (mostly taken from ffi-cmu.lisp).
diff --git a/src/ffi-cffi.lisp b/src/ffi-cffi.lisp
index 5146374..8dac403 100644
--- a/src/ffi-cffi.lisp
+++ b/src/ffi-cffi.lisp
@@ -215,6 +215,179 @@
;; ,@doc
,@new-pars ,@aux-pars))))
+;;
+;; DEF-FORTRAN-ROUTINE
+;;
+;; An external Fortran routine definition form (DEF-FORTRAN-ROUTINE
+;; MY-FUN ...) creates two functions:
+;;
+;; 1. a raw FFI (foreign function interface),
+;; 2. an easier to use lisp interface to the raw interface.
+;;
+;; The documentation given here relates in the most part to the
+;; simplified lisp interface.
+;;
+;; Example:
+;; ========
+;; libblas.a contains the fortran subroutine DCOPY(N,X,INCX,Y,INCY)
+;; which copies the vector Y of N double-float's to the vector X.
+;; The function name in libblas.a is \"dcopy_\" (by Fortran convention).
+;;
+;; (DEF-FORTRAN-ROUTINE DCOPY :void
+;; (N :integer :input)
+;; (X (* :double-float) :output)
+;; (INCX :integer :input)
+;; (Y (* :double-float) :input)
+;; (INCY :integer :input))
+;;
+;; will expand into:
+;;
+;; (CFFI:DEFCFUN ("dcopy_" FORTRAN-DCOPY) :VOID
+;; (N :POINTER :INT)
+;; (DX :POINTER :DOUBLE)
+;; (INCX :POINTER :INT)
+;; (DY :POINTER :DOUBLE)
+;; (INCY :POINTER :INT))
+;;
+;; and
+;;
+;; (DEFUN DCOPY (N,X,INCX,Y,INCY)
+;; ...
+;;
+;; In turn, the lisp function DCOPY calls FORTRAN-DCOPY which calls
+;; the Fortran function "dcopy_" in libblas.a.
+;;
+;; Arguments:
+;; ==========
+;;
+;;
+;; NAME Name of the lisp interface function that will be created.
+;; The name of the raw FFI will be derived from NAME via
+;; the function MAKE-FFI-NAME. The name of foreign function
+;; (presumable a Fortran Function in an external library)
+;; will be derived from NAME via MAKE-FORTRAN-NAME.
+;;
+;; RETURN-TYPE
+;; The type of data that will be returned by the external
+;; (presumably Fortran) function.
+;;
+;; (MEMBER RETURN-TYPE '(:VOID :INTEGER :SINGLE-FLOAT :DOUBLE-FLOAT
+;; :COMPLEX-SINGLE-FLOAT :COMPLEX-DOUBLE-FLOAT))
+;;
+;; See GET-READ-OUT-TYPE.
+;;
+;; BODY A list of parameter forms. A parameter form is:
+;;
+;; (VARIABLE TYPE &optional (STYLE :INPUT))
+;;
+;; The VARIABLE is the name of a parameter accepted by the
+;; external (presumably Fortran) routine. TYPE is the type of
+;; VARIABLE. The recognized TYPE's are:
+;;
+;; TYPE Corresponds to Fortran Declaration
+;; ---- ----------------------------------
+;; :STRING CHARACTER*(*)
+;; :INTEGER INTEGER
+;; :SINGLE-FLOAT REAL
+;; :DOUBLE-FLOAT DOUBLE PRECISION
+;; :COMPLEX-SINGLE-FLOAT COMPLEX
+;; :COMPLEX-DOUBLE-FLOAT COMPLEX*16
+;; (* X) An array of type X.
+;; (:CALLBACK args) A description of a function or subroutine
+;;
+;; (MEMBER X '(:INTEGER :SINGLE-FLOAT :DOUBLE-FLOAT
+;; :COMPLEX-SINGLE-FLOAT :COMPLEX-DOUBLE-FLOAT)
+;;
+;;
+;; The STYLE (default :INPUT) defines how VARIABLE is treated.
+;; This is by far the most difficult quantity to learn. To
+;; begin with:
+;;
+;;
+;; (OR (MEMBER STYLE '(:INPUT :OUTPUT :INPUT-OUTPUT))
+;; (MEMBER STYLE '(:IN :COPY :IN-OUT :OUT)))
+;;
+;; TYPE STYLE Description
+;; ---- ----- -----------
+;; X :INPUT Value will be used but not modified.
+;;
+;; :OUTPUT Input value not used (but some value must be given),
+;; a value is returned as one of the values lisp
+;; function NAME. Similar to the :IN-OUT style
+;; of DEF-ALIEN-ROUTINE.
+;; :INPUT-OUTPUT Input value may be used, a value is returned
+;; as one of the values from the lisp function
+;; NAME.
+;;
+;; ** Note: In all 3 cases above the input VARIABLE will not be destroyed
+;; or modified directly, a copy is taken and a pointer of that
+;; copy is passed to the (presumably Fortran) external routine.
+;;
+;; (OR (* X) :INPUT Array entries are used but not modified.
+;; :STRING) :OUTPUT Array entries need not be initialized on input,
+;; but will be *modified*. In addition, the array
+;; will be returned via the Lisp command VALUES
+;; from the lisp function NAME.
+;;
+;; :INPUT-OUTPUT Like :OUTPUT but initial values on entry may be used.
+;;
+;; The keyword :WORKSPACE is a nickname for :INPUT. The
+;; keywords :INPUT-OR-OUTPUT, :WORKSPACE-OUTPUT,
+;; :WORKSPACE-OR-OUTPUT are nicknames for :OUTPUT.
+;;
+;; This is complicated. Suggestions are encouraged to
+;; interface a *functional language* to a *pass-by-reference
+;; language*.
+;;
+;; CALLBACKS
+;;
+;; A callback here means a function (or subroutine) that is passed into the Fortran
+;; routine which calls it as needed to compute something.
+;;
+;; The syntax of :CALLBACK is similar to the DEF-FORTRAN-ROUTINE:
+;;
+;; (name (:CALLBACK return-type
+;; {arg-description}))
+;;
+;; The RETURN-TYPE is the same as for DEF-FORTRAN-ROUTINE. The arg description is the
+;; same syntax as list of parameter forms for DEF-FORTRAN-ROUTINE. However, if the type
+;; is a pointer type (like (* :double-float)), then a required keyword option must be
+;; specified:
+;;
+;; (name (* type :size size) &optional style)
+;;
+;; The size specifies the total length of the Fortran array. This array is treated as a
+;; one dimentionsal vector and should be accessed using the function FV-REF, which is
+;; analogous to AREF. The SIZE parameter can be any Lisp form and can refer to any of the
+;; arguments to the Fortran routine.
+;;
+;; For example, a fortran routine can have the callback
+;;
+;; (def-fortran-routine foo :void
+;; (m (* :integer) :input)
+;; (fsub (:callback :void
+;; (x :double-float :input)
+;; (z (* :double-float :size (aref m 0)) :input)
+;; (f (* :double-float :size (aref m 0)) :output)))))
+;;
+;; This means that the arrays Z and F in FSUB have a dimension of (AREF M 0), the first
+;; element of the vector M. The function FSUB can be written in Lisp as
+;;
+;; (defun fsub (x z f)
+;; (setf (fv-ref f 0) (* x x (fv-ref z 3))))
+;;
+;; Further Notes:
+;; ===============
+;;
+;; Some Fortran routines use Fortran character strings in the
+;; parameter list. The definition here is suitable for Solaris
+;; where the Fortran character string is converted to a C-style null
+;; terminated string, AND an extra hidden parameter that is appended
+;; to the parameter list to hold the length of the string.
+;;
+;; If your Fortran does this differently, you'll have to change this
+;; definition accordingly!
+
;; Call defcfun to define the foreign function.
;; Also creates a nice lisp helper function.
(defmacro def-fortran-routine (func-name return-type &rest body)
commit 7fa7c24b0d56039a1fef930ffe2051b74c11ebeb
Author: Raymond Toy <toy...@gm...>
Date: Sat Mar 24 19:58:00 2012 -0700
Regenerated.
diff --git a/configure b/configure
index 2c91c83..d6d18d8 100755
--- a/configure
+++ b/configure
@@ -15340,7 +15340,7 @@ case $host in
*) share_ext=so ;;
esac
-ac_config_files="$ac_config_files matlisp.mk Makefile start.lisp config.lisp lib/lazy-loader.lisp LAPACK/SRC/Makefile LAPACK/BLAS/SRC/Makefile dfftpack/Makefile lib-src/toms715/Makefile lib-src/odepack/Makefile lib-src/compat/Makefile src/f77-mangling.lisp"
+ac_config_files="$ac_config_files matlisp.mk Makefile start.lisp config.lisp lib/lazy-loader.lisp src/f77-mangling.lisp LAPACK/SRC/Makefile LAPACK/BLAS/SRC/Makefile dfftpack/Makefile lib-src/toms715/Makefile lib-src/compat/Makefile lib-src/odepack/Makefile lib-src/colnew/Makefile"
echo FLIBS = $FLIBS
@@ -16469,13 +16469,14 @@ do
"start.lisp") CONFIG_FILES="$CONFIG_FILES start.lisp" ;;
"config.lisp") CONFIG_FILES="$CONFIG_FILES config.lisp" ;;
"lib/lazy-loader.lisp") CONFIG_FILES="$CONFIG_FILES lib/lazy-loader.lisp" ;;
+ "src/f77-mangling.lisp") CONFIG_FILES="$CONFIG_FILES src/f77-mangling.lisp" ;;
"LAPACK/SRC/Makefile") CONFIG_FILES="$CONFIG_FILES LAPACK/SRC/Makefile" ;;
"LAPACK/BLAS/SRC/Makefile") CONFIG_FILES="$CONFIG_FILES LAPACK/BLAS/SRC/Makefile" ;;
"dfftpack/Makefile") CONFIG_FILES="$CONFIG_FILES dfftpack/Makefile" ;;
"lib-src/toms715/Makefile") CONFIG_FILES="$CONFIG_FILES lib-src/toms715/Makefile" ;;
- "lib-src/odepack/Makefile") CONFIG_FILES="$CONFIG_FILES lib-src/odepack/Makefile" ;;
"lib-src/compat/Makefile") CONFIG_FILES="$CONFIG_FILES lib-src/compat/Makefile" ;;
- "src/f77-mangling.lisp") CONFIG_FILES="$CONFIG_FILES src/f77-mangling.lisp" ;;
+ "lib-src/odepack/Makefile") CONFIG_FILES="$CONFIG_FILES lib-src/odepack/Makefile" ;;
+ "lib-src/colnew/Makefile") CONFIG_FILES="$CONFIG_FILES lib-src/colnew/Makefile" ;;
*) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;;
esac
-----------------------------------------------------------------------
Summary of changes:
configure | 7 +-
src/ffi-cffi.lisp | 173 +++++++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 177 insertions(+), 3 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Raymond T. <rt...@us...> - 2012-03-24 22:08:31
|
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 8191e3e96c966fc09587e44f98a09e42cd5985e9 (commit)
via b53c930a62d5eadcb565e1c77b13a33ac3f24297 (commit)
from 7f20064540e1c4bbb9ba535c37fb1533831cb217 (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 8191e3e96c966fc09587e44f98a09e42cd5985e9
Author: Raymond Toy <toy...@gm...>
Date: Sat Mar 24 15:08:07 2012 -0700
Add support for colnew.
Makefile.am:
o Build and install the colnew library.
configure.ac:
o Add lib-src/colnew/Makefile to list of output files.
lib/lazy-loader.lisp.in:
o Define the colnew library.
matlisp.asd:
o Add defsystem for colnew
src/colnew.lisp:
o New file defining interface to main routines in the colnew package.
src/colnew-demo1.lisp:
o New file giving a simple demo of colnew.
diff --git a/Makefile.am b/Makefile.am
index b073e06..35fb5c5 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -16,6 +16,7 @@ all :
(cd lib-src/toms715; $(MAKE) install)
(cd lib-src/odepack; $(MAKE) install)
(cd lib-src/compat; $(MAKE) install)
+ (cd lib-src/colnew; $(MAKE) install)
if !ATLAS
(cd LAPACK/BLAS/SRC; $(MAKE) install)
(cd LAPACK/SRC; $(MAKE) install)
diff --git a/configure.ac b/configure.ac
index 9bbb440..89f0f1b 100644
--- a/configure.ac
+++ b/configure.ac
@@ -421,13 +421,14 @@ AC_CONFIG_FILES([
start.lisp
config.lisp
lib/lazy-loader.lisp
+ src/f77-mangling.lisp
LAPACK/SRC/Makefile
LAPACK/BLAS/SRC/Makefile
dfftpack/Makefile
lib-src/toms715/Makefile
- lib-src/odepack/Makefile
lib-src/compat/Makefile
- src/f77-mangling.lisp
+ lib-src/odepack/Makefile
+ lib-src/colnew/Makefile
])
echo FLIBS = $FLIBS
diff --git a/lib/lazy-loader.lisp.in b/lib/lazy-loader.lisp.in
index ba1296c..46afb45 100644
--- a/lib/lazy-loader.lisp.in
+++ b/lib/lazy-loader.lisp.in
@@ -137,6 +137,10 @@
(:darwin "libodepack.dylib")
(t (:default "@libdir@/libodepack")))
+(cffi:define-foreign-library colnew
+ (:darwin "libcolnew.dylib")
+ (t (:default "@libdir@/libcolnew")))
+
(cffi:define-foreign-library matlisp
(:darwin "libmatlisp.dylib")
(t (:default "@libdir@/libmatlisp")))
diff --git a/matlisp.asd b/matlisp.asd
index 2c8019c..b72039e 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -311,7 +311,17 @@
:components
((:module "src"
:components
- ((:file "dlsode")))))
+ ((:file "dlsode")))))
+
+(asdf:defsystem matlisp-colnew
+ :pathname #.(translate-logical-pathname "matlisp:srcdir;")
+ :components
+ ((:module "src"
+ :components
+ ((:file "colnew")
+ (:file "colnew-demo1" :depends-on ("colnew"))
+ #+nil
+ (:file "colnew-demo4" :depends-on ("colnew"))))))
(defmethod perform ((op asdf:test-op) (c (eql (asdf:find-system :matlisp))))
(oos 'asdf:test-op 'matlisp-tests))
diff --git a/src/colnew-demo1.lisp b/src/colnew-demo1.lisp
new file mode 100644
index 0000000..ae5d53c
--- /dev/null
+++ b/src/colnew-demo1.lisp
@@ -0,0 +1,91 @@
+;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: :matlisp; Base: 10 -*-
+
+(in-package #:matlisp)
+
+(defun fsub (x z f)
+ (setf (fv-ref f 0) (/ (- 1
+ (* 6 x x (fv-ref z 3))
+ (* 6 x (fv-ref z 2)))
+ (* x x x))))
+(defun dfsub (x z df)
+ (setf (fv-ref df 0) 0d0)
+ (setf (fv-ref df 1) 0d0)
+ (setf (fv-ref df 2) (/ -6 x x))
+ (setf (fv-ref df 3) (/ -6 x)))
+
+(defun gsub (i z g)
+ (setf (fv-ref g 0)
+ (if (or (= i 1) (= i 3))
+ (fv-ref z 0)
+ (fv-ref z 2))))
+
+(defun dgsub (i z dg)
+ (dotimes (k 4)
+ (setf (fv-ref dg k) 0d0))
+ (if (or (= i 1) (= i 3))
+ (setf (fv-ref dg 0) 1d0)
+ (setf (fv-ref dg 2) 1d0)))
+
+(defun guess (x z dmval)
+ )
+
+(defun exact (x)
+ (declare (type double-float x))
+ (let ((result (make-array 4 :element-type 'double-float)))
+ (setf (aref result 0)
+ (+ (* .25d0 (- (* 10 (log 2d0)) 3)
+ (- 1 x))
+ (* 0.5d0 (+ (/ x)
+ (* (+ 3 x) (log x))
+ (- x)))))
+ (setf (aref result 1)
+ (+ (* -0.25d0 (- (* 10 (log 2d0)) 3))
+ (* .5d0
+ (+ (/ -1 x x)
+ (log x)
+ (/ (+ 3 x) x)
+ -1))))
+ (setf (aref result 2)
+ (* 0.5d0
+ (+ (/ 2 (expt x 3))
+ (/ x)
+ (/ -3 x x))))
+ (setf (aref result 3)
+ (* 0.5d0
+ (+ (/ -6 (expt x 4))
+ (/ -1 x x)
+ (/ 6 (expt x 3)))))
+ result))
+
+(defun colnew-prob1 ()
+ (let ((m (make-array 1 :element-type '(signed-byte 32)
+ :initial-element 4))
+ (zeta (make-array 4 :element-type 'double-float
+ :initial-contents '(1d0 1d0 2d0 2d0)))
+ (ipar (make-array 11 :element-type '(signed-byte 32)
+ :initial-element 0))
+ (ltol (make-array 2 :element-type '(signed-byte 32)
+ :initial-contents '(1 3)))
+ (tol (make-array 2 :element-type 'double-float
+ :initial-contents '(1d-7 1d-7)))
+ (fspace (make-array 2000 :element-type 'double-float))
+ (ispace (make-array 200 :element-type '(signed-byte 32)))
+ (fixpnt (make-array 1 :element-type 'double-float))
+ (errors (make-array 4 :element-type 'double-float)))
+ (setf (aref ipar 2) 1)
+ (setf (aref ipar 3) 2)
+ (setf (aref ipar 4) 2000)
+ (setf (aref ipar 5) 200)
+ (colnew 1 m 1d0 2d0 zeta ipar ltol tol fixpnt ispace fspace 0
+ #'fsub #'dfsub #'gsub #'dgsub #'guess)
+ (let ((x 1d0)
+ (z (make-array 4 :element-type 'double-float)))
+ (dotimes (j 100)
+ (appsln x z fspace ispace)
+ (map-into errors #'(lambda (a b c)
+ (max a (abs (- b c))))
+ errors
+ (exact x)
+ z))
+ (format t "The exact errors are: ~{ ~11,4e~}~%" (coerce errors 'list)))))
+
\ No newline at end of file
diff --git a/src/colnew.lisp b/src/colnew.lisp
new file mode 100644
index 0000000..d47f76c
--- /dev/null
+++ b/src/colnew.lisp
@@ -0,0 +1,48 @@
+;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: :matlisp; Base: 10 -*-
+
+(in-package #:matlisp)
+
+(cffi:use-foreign-library colnew)
+
+(def-fortran-routine colnew :void
+ "COLNEW"
+ (ncomp :integer :input)
+ (m (* :integer) :input)
+ (aleft :double-float :input)
+ (aright :double-float :input)
+ (zeta (* :double-float) :input)
+ (ipar (* :integer) :input)
+ (ltol (* :integer) :input)
+ (tol (* :double-float) :input)
+ (fixpnt (* :double-float) :input)
+ (ispace (* :integer) :input-output)
+ (fspace (* :double-float) :input-output)
+ (iflag :integer :output)
+ (fsub (:callback :void
+ (x :double-float :input)
+ (z (* :double-float :size (aref m 0)) :input)
+ (f (* :double-float :size (aref m 0)) :output)))
+ (dfsub (:callback :void
+ (x :double-float :input)
+ (z (* :double-float :size (aref m 0)) :input)
+ (df (* :double-float :size (aref m 0)) :output)))
+ (gsub (:callback :void
+ (i :integer :input)
+ (z (* :double-float :size (aref m 0)) :input)
+ (g (* :double-float :size (aref m 0)) :output)))
+ (dgsub (:callback :void
+ (i :integer :input)
+ (z (* :double-float :size (aref m 0)) :input)
+ (dg (* :double-float :size (aref m 0)) :output)))
+ (guess (:callback :void
+ (x :double-float :input)
+ (z (* :double-float) :output)
+ (dmval (* :double-float) :output))))
+
+
+(def-fortran-routine appsln :void
+ (x :double-float :input)
+ (z (* :double-float) :output)
+ (fspace (* :double-float) :input)
+ (ispace (* :double-float) :input))
+
commit b53c930a62d5eadcb565e1c77b13a33ac3f24297
Author: Raymond Toy <toy...@gm...>
Date: Sat Mar 24 15:04:56 2012 -0700
Add source files for colnew.
diff --git a/lib-src/colnew/Makefile.am b/lib-src/colnew/Makefile.am
new file mode 100644
index 0000000..9562b0b
--- /dev/null
+++ b/lib-src/colnew/Makefile.am
@@ -0,0 +1,35 @@
+lib_LTLIBRARIES = libcolnew.la
+
+AM_FFLAGS = $(F2C)
+if LIB32
+AM_FFLAGS += -m32
+endif
+
+libcolnew_la_LDFLAGS = $(FLIBS_OPTS)
+libcolnew_la_LIBADD = $(FLIBS)
+
+libcolnew_la_SOURCES = \
+approx.f \
+appsln.f \
+colnew.f \
+consts.f \
+contrl.f \
+dgefa.f \
+dgesl.f \
+dmzsol.f \
+errchk.f \
+factrb.f \
+fcblok.f \
+gblock.f \
+gderiv.f \
+horder.f \
+lsyslv.f \
+newmsh.f \
+rkbas.f \
+sbblok.f \
+shiftb.f \
+skale.f \
+subbak.f \
+subfor.f \
+vmonde.f \
+vwblok.f
\ No newline at end of file
diff --git a/lib-src/colnew/approx.f b/lib-src/colnew/approx.f
new file mode 100644
index 0000000..1f9b93c
--- /dev/null
+++ b/lib-src/colnew/approx.f
@@ -0,0 +1,120 @@
+ SUBROUTINE APPROX (I, X, ZVAL, A, COEF, XI, N, Z, DMZ, K,
+ 1 NCOMP, MMAX, M, MSTAR, MODE, DMVAL, MODM )
+C
+C**********************************************************************
+C
+C purpose
+C (1) (m1-1) (mncomp-1)
+C evaluate z(u(x))=(u (x),u (x),...,u (x),...,u (x) )
+C 1 1 1 mncomp
+C at one point x.
+C
+C variables
+C a - array of mesh independent rk-basis coefficients
+C basm - array of mesh dependent monomial coefficients
+C xi - the current mesh (having n subintervals)
+C z - the current solution vector
+C dmz - the array of mj-th derivatives of the current solution
+C mode - determines the amount of initialization needed
+C = 4 forms z(u(x)) using z, dmz and ha
+C = 3 as in =4, but computes local rk-basis
+C = 2 as in =3, but determines i such that
+C xi(i) .le. x .lt. xi(i+1) (unless x=xi(n+1))
+C = 1 retrieve z=z(u(x(i))) directly
+C
+C**********************************************************************
+C
+ IMPLICIT REAL*8 (A-H,O-Z)
+ DIMENSION ZVAL(1), DMVAL(1), XI(1), M(1), A(7,1), DM(7)
+ DIMENSION Z(1), DMZ(1), BM(4), COEF(1)
+C
+ COMMON /COLOUT/ PRECIS, IOUT, IPRINT
+C
+ GO TO (10, 30, 80, 90), MODE
+C
+C... mode = 1 , retrieve z( u(x) ) directly for x = xi(i).
+C
+ 10 X = XI(I)
+ IZ = (I-1) * MSTAR
+ DO 20 J = 1, MSTAR
+ IZ = IZ + 1
+ ZVAL(J) = Z(IZ)
+ 20 CONTINUE
+ RETURN
+C
+C... mode = 2 , locate i so xi(i) .le. x .lt. xi(i+1)
+C
+ 30 CONTINUE
+ IF ( X .GE. XI(1)-PRECIS .AND. X .LE. XI(N+1)+PRECIS )
+ 1 GO TO 40
+ IF (IPRINT .LT. 1) WRITE(IOUT,900) X, XI(1), XI(N+1)
+ IF ( X .LT. XI(1) ) X = XI(1)
+ IF ( X .GT. XI(N+1) ) X = XI(N+1)
+ 40 IF ( I .GT. N .OR. I .LT. 1 ) I = (N+1) / 2
+ ILEFT = I
+ IF ( X .LT. XI(ILEFT) ) GO TO 60
+ DO 50 L = ILEFT, N
+ I = L
+ IF ( X .LT. XI(L+1) ) GO TO 80
+ 50 CONTINUE
+ GO TO 80
+ 60 IRIGHT = ILEFT - 1
+ DO 70 L = 1, IRIGHT
+ I = IRIGHT + 1 - L
+ IF ( X .GE. XI(I) ) GO TO 80
+ 70 CONTINUE
+C
+C... mode = 2 or 3 , compute mesh independent rk-basis.
+C
+ 80 CONTINUE
+ S = (X - XI(I)) / (XI(I+1) - XI(I))
+ CALL RKBAS ( S, COEF, K, MMAX, A, DM, MODM )
+C
+C... mode = 2, 3, or 4 , compute mesh dependent rk-basis.
+C
+ 90 CONTINUE
+ BM(1) = X - XI(I)
+ DO 95 L = 2, MMAX
+ BM(L) = BM(1) / DFLOAT(L)
+ 95 CONTINUE
+C
+C... evaluate z( u(x) ).
+C
+ 100 IR = 1
+ IZ = (I-1) * MSTAR + 1
+ IDMZ = (I-1) * K * NCOMP
+ DO 140 JCOMP = 1, NCOMP
+ MJ = M(JCOMP)
+ IR = IR + MJ
+ IZ = IZ + MJ
+ DO 130 L = 1, MJ
+ IND = IDMZ + JCOMP
+ ZSUM = 0.D0
+ DO 110 J = 1, K
+ ZSUM = ZSUM + A(J,L) * DMZ(IND)
+ 110 IND = IND + NCOMP
+ DO 120 LL = 1, L
+ LB = L + 1 - LL
+ 120 ZSUM = ZSUM * BM(LB) + Z(IZ-LL)
+ 130 ZVAL(IR-L) = ZSUM
+ 140 CONTINUE
+ IF ( MODM .EQ. 0 ) RETURN
+C
+C... for modm = 1 evaluate dmval(j) = mj-th derivative of uj.
+C
+ DO 150 JCOMP = 1, NCOMP
+ 150 DMVAL(JCOMP) = 0.D0
+ IDMZ = IDMZ + 1
+ DO 170 J = 1, K
+ FACT = DM(J)
+ DO 160 JCOMP = 1, NCOMP
+ DMVAL(JCOMP) = DMVAL(JCOMP) + FACT * DMZ(IDMZ)
+ IDMZ = IDMZ + 1
+ 160 CONTINUE
+ 170 CONTINUE
+ RETURN
+C--------------------------------------------------------------------
+ 900 FORMAT(37H ****** DOMAIN ERROR IN APPROX ******
+ 1 /4H X =,D20.10, 10H ALEFT =,D20.10,
+ 2 11H ARIGHT =,D20.10)
+ END
diff --git a/lib-src/colnew/appsln.f b/lib-src/colnew/appsln.f
new file mode 100644
index 0000000..7edb726
--- /dev/null
+++ b/lib-src/colnew/appsln.f
@@ -0,0 +1,31 @@
+C
+C----------------------------------------------------------------------
+C p a r t 4
+C polynomial and service routines
+C----------------------------------------------------------------------
+C
+ SUBROUTINE APPSLN (X, Z, FSPACE, ISPACE)
+C
+C*****************************************************************
+C
+C purpose
+C
+C set up a standard call to approx to evaluate the
+C approximate solution z = z( u(x) ) at a point x
+C (it has been computed by a call to colnew ).
+C the parameters needed for approx are retrieved
+C from the work arrays ispace and fspace .
+C
+C*****************************************************************
+C
+ IMPLICIT REAL*8 (A-H,O-Z)
+ DIMENSION Z(1), FSPACE(1), ISPACE(1), A(28), DUMMY(1)
+ IS6 = ISPACE(6)
+ IS5 = ISPACE(1) + 2
+ IS4 = IS5 + ISPACE(4) * (ISPACE(1) + 1)
+ I = 1
+ CALL APPROX (I, X, Z, A, FSPACE(IS6), FSPACE(1), ISPACE(1),
+ 1 FSPACE(IS5), FSPACE(IS4), ISPACE(2), ISPACE(3),
+ 2 ISPACE(5), ISPACE(8), ISPACE(4), 2, DUMMY, 0)
+ RETURN
+ END
diff --git a/lib-src/colnew/colnew.f b/lib-src/colnew/colnew.f
new file mode 100644
index 0000000..06aa822
--- /dev/null
+++ b/lib-src/colnew/colnew.f
@@ -0,0 +1,740 @@
+c From research!csnet!CSNET-RELAY!mit-multics.arpa!UBC.mailnet!USER=NBAF Tue, 3 Feb 87 15:25:36 PST
+C**********************************************************************
+C this package solves boundary value problems for
+C ordinary differential equations, as described below.
+C
+C COLNEW is a modification of the package COLSYS by ascher,
+C christiansen and russell [1]. It incorporates a new basis
+C representation replacing b-splines, and improvements for
+C the linear and nonlinear algebraic equation solvers.
+C the package can be referenced as either COLNEW or COLSYS.
+C**********************************************************************
+C----------------------------------------------------------------------
+C p a r t 1
+C main storage allocation and program control subroutines
+C----------------------------------------------------------------------
+C
+ SUBROUTINE COLNEW (NCOMP, M, ALEFT, ARIGHT, ZETA, IPAR, LTOL,
+ 1 TOL, FIXPNT, ISPACE, FSPACE, IFLAG,
+ 2 FSUB, DFSUB, GSUB, DGSUB, GUESS)
+C
+C
+C**********************************************************************
+C
+C written by
+C u. ascher,
+C department of computer science,
+C university of british columbia,
+C vancouver, b. c., canada v6t 1w5
+C g. bader,
+C institut f. angewandte mathematik
+C university of heidelberg
+C im neuenheimer feld 294
+C d-6900 heidelberg 1
+C
+C**********************************************************************
+C
+C purpose
+C
+C this package solves a multi-point boundary value
+C problem for a mixed order system of ode-s given by
+C
+C (m(i))
+C u = f ( x; z(u(x)) ) i = 1, ... ,ncomp
+C i i
+C
+C aleft .lt. x .lt. aright,
+C
+C
+C g ( zeta(j); z(u(zeta(j))) ) = 0 j = 1, ... ,mstar
+C j
+C mstar = m(1)+m(2)+...+m(ncomp),
+C
+C
+C where t
+C u = (u , u , ... ,u ) is the exact solution vector
+C 1 2 ncomp
+C
+C (mi)
+C u is the mi=m(i) th derivative of u
+C i i
+C
+C (1) (m1-1) (mncomp-1)
+C z(u(x)) = ( u (x),u (x),...,u (x),...,u (x) )
+C 1 1 1 ncomp
+C
+C f (x,z(u)) is a (generally) nonlinear function of
+C i
+C z(u)=z(u(x)).
+C
+C g (zeta(j);z(u)) is a (generally) nonlinear function
+C j
+C used to represent a boundary condition.
+C
+C the boundary points satisfy
+C aleft .le. zeta(1) .le. .. .le. zeta(mstar) .le. aright
+C
+C the orders mi of the differential equations satisfy
+C 1 .le. m(i) .le. 4.
+C
+C
+C**********************************************************************
+C
+C method
+C
+C the method used to approximate the solution u is
+C collocation at gaussian points, requiring m(i)-1 continuous
+C derivatives in the i-th component, i = 1, ..., ncomp.
+C here, k is the number of collocation points (stages) per
+C subinterval and is chosen such that k .ge. max m(i).
+C a runge-kutta-monomial solution representation is utilized.
+C
+C references
+C
+C [1] u. ascher, j. christiansen and r.d. russell,
+C collocation software for boundary-value odes,
+C acm trans. math software 7 (1981), 209-222.
+C this paper contains EXAMPLES where use of the code
+C is demonstrated.
+C
+C [2] g. bader and u. ascher,
+C a new basis implementation for a mixed order
+C boundary value ode solver,
+C siam j. scient. stat. comput. (1987).
+C
+C [3] u. ascher, j. christiansen and r.d. russell,
+C a collocation solver for mixed order
+C systems of boundary value problems,
+C math. comp. 33 (1979), 659-679.
+C
+C [4] u. ascher, j. christiansen and r.d. russell,
+C colsys - a collocation code for boundary
+C value problems,
+C lecture notes comp.sc. 76, springer verlag,
+C b. childs et. al. (eds.) (1979), 164-185.
+C
+C [5] c. deboor and r. weiss,
+C solveblok: a package for solving almost block diagonal
+C linear systems,
+C acm trans. math. software 6 (1980), 80-87.
+C
+C**********************************************************************
+C
+C *************** input to colnew ***************
+C
+C variables
+C
+C ncomp - no. of differential equations (ncomp .le. 20)
+C
+C m(j) - order of the j-th differential equation
+C ( mstar = m(1) + ... + m(ncomp) .le. 40 )
+C
+C aleft - left end of interval
+C
+C aright - right end of interval
+C
+C zeta(j) - j-th side condition point (boundary point). must
+C have zeta(j) .le. zeta(j+1). all side condition
+C points must be mesh points in all meshes used,
+C see description of ipar(11) and fixpnt below.
+C
+C ipar - an integer array dimensioned at least 11.
+C a list of the parameters in ipar and their meaning follows
+C some parameters are renamed in colnew; these new names are
+C given in parentheses.
+C
+C ipar(1) ( = nonlin )
+C = 0 if the problem is linear
+C = 1 if the problem is nonlinear
+C
+C ipar(2) = no. of collocation points per subinterval (= k )
+C where max m(i) .le. k .le. 7 . if ipar(2)=0 then
+C colnew sets k = max ( max m(i)+1, 5-max m(i) )
+C
+C ipar(3) = no. of subintervals in the initial mesh ( = n ).
+C if ipar(3) = 0 then colnew arbitrarily sets n = 5.
+C
+C ipar(4) = no. of solution and derivative tolerances. ( = ntol )
+C we require 0 .lt. ntol .le. mstar.
+C
+C ipar(5) = dimension of fspace. ( = ndimf )
+C
+C ipar(6) = dimension of ispace. ( = ndimi )
+C
+C ipar(7) - output control ( = iprint )
+C = -1 for full diagnostic printout
+C = 0 for selected printout
+C = 1 for no printout
+C
+C ipar(8) ( = iread )
+C = 0 causes colnew to generate a uniform initial mesh.
+C = 1 if the initial mesh is provided by the user. it
+C is defined in fspace as follows: the mesh
+C aleft=x(1).lt.x(2).lt. ... .lt.x(n).lt.x(n+1)=aright
+C will occupy fspace(1), ..., fspace(n+1). the
+C user needs to supply only the interior mesh
+C points fspace(j) = x(j), j = 2, ..., n.
+C = 2 if the initial mesh is supplied by the user
+C as with ipar(8)=1, and in addition no adaptive
+C mesh selection is to be done.
+C
+C ipar(9) ( = iguess )
+C = 0 if no initial guess for the solution is
+C provided.
+C = 1 if an initial guess is provided by the user
+C in subroutine guess.
+C = 2 if an initial mesh and approximate solution
+C coefficients are provided by the user in fspace.
+C (the former and new mesh are the same).
+C = 3 if a former mesh and approximate solution
+C coefficients are provided by the user in fspace,
+C and the new mesh is to be taken twice as coarse;
+C i.e.,every second point from the former mesh.
+C = 4 if in addition to a former initial mesh and
+C approximate solution coefficients, a new mesh
+C is provided in fspace as well.
+C (see description of output for further details
+C on iguess = 2, 3, and 4.)
+C
+C ipar(10)= 0 if the problem is regular
+C = 1 if the first relax factor is =rstart, and the
+C nonlinear iteration does not rely on past covergence
+C (use for an extra sensitive nonlinear problem only).
+C = 2 if we are to return immediately upon (a) two
+C successive nonconvergences, or (b) after obtaining
+C error estimate for the first time.
+C
+C ipar(11)= no. of fixed points in the mesh other than aleft
+C and aright. ( = nfxpnt , the dimension of fixpnt)
+C the code requires that all side condition points
+C other than aleft and aright (see description of
+C zeta ) be included as fixed points in fixpnt.
+C
+C ltol - an array of dimension ipar(4). ltol(j) = l specifies
+C that the j-th tolerance in tol controls the error
+C in the l-th component of z(u). also require that
+C 1.le.ltol(1).lt.ltol(2).lt. ... .lt.ltol(ntol).le.mstar
+C
+C tol - an array of dimension ipar(4). tol(j) is the
+C error tolerance on the ltol(j) -th component
+C of z(u). thus, the code attempts to satisfy
+C for j=1,...,ntol on each subinterval
+C abs(z(v)-z(u)) .le. tol(j)*abs(z(u)) +tol(j)
+C ltol(j) ltol(j)
+C
+C if v(x) is the approximate solution vector.
+C
+C fixpnt - an array of dimension ipar(11). it contains
+C the points, other than aleft and aright, which
+C are to be included in every mesh.
+C
+C ispace - an integer work array of dimension ipar(6).
+C its size provides a constraint on nmax,
+C the maximum number of subintervals. choose
+C ipar(6) according to the formula
+C ipar(6) .ge. nmax*nsizei
+C where
+C nsizei = 3 + kdm
+C with
+C kdm = kd + mstar ; kd = k * ncomp ;
+C nrec = no. of right end boundary conditions.
+C
+C
+C fspace - a real work array of dimension ipar(5).
+C its size provides a constraint on nmax.
+C choose ipar(5) according to the formula
+C ipar(5) .ge. nmax*nsizef
+C where
+C nsizef = 4 + 3 * mstar + (5+kd) * kdm +
+C (2*mstar-nrec) * 2*mstar.
+C
+C
+C iflag - the mode of return from colnew.
+C = 1 for normal return
+C = 0 if the collocation matrix is singular.
+C =-1 if the expected no. of subintervals exceeds storage
+C specifications.
+C =-2 if the nonlinear iteration has not converged.
+C =-3 if there is an input data error.
+C
+C
+C**********************************************************************
+C
+C ************* user supplied subroutines *************
+C
+C
+C the following subroutines must be declared external in the
+C main program which calls colnew.
+C
+C
+C fsub - name of subroutine for evaluating f(x,z(u(x))) =
+C t
+C (f ,...,f ) at a point x in (aleft,aright). it
+C 1 ncomp
+C should have the heading
+C
+C subroutine fsub (x , z , f)
+C
+C where f is the vector containing the value of fi(x,z(u))
+C in the i-th component and t
+C z(u(x))=(z(1),...,z(mstar))
+C is defined as above under purpose .
+C
+C
+C dfsub - name of subroutine for evaluating the jacobian of
+C f(x,z(u)) at a point x. it should have the heading
+C
+C subroutine dfsub (x , z , df)
+C
+C where z(u(x)) is defined as for fsub and the (ncomp) by
+C (mstar) array df should be filled by the partial deriv-
+C atives of f, viz, for a particular call one calculates
+C df(i,j) = dfi / dzj, i=1,...,ncomp
+C j=1,...,mstar.
+C
+C
+C gsub - name of subroutine for evaluating the i-th component of
+C g(x,z(u(x))) = g (zeta(i),z(u(zeta(i)))) at a point x =
+C i
+C zeta(i) where 1.le.i.le.mstar. it should have the heading
+C
+C subroutine gsub (i , z , g)
+C
+C where z(u) is as for fsub, and i and g=g are as above.
+C i
+C note that in contrast to f in fsub , here
+C only one value per call is returned in g.
+C
+C
+C dgsub - name of subroutine for evaluating the i-th row of
+C the jacobian of g(x,u(x)). it should have the heading
+C
+C subroutine dgsub (i , z , dg)
+C
+C where z(u) is as for fsub, i as for gsub and the mstar-
+C vector dg should be filled with the partial derivatives
+C of g, viz, for a particular call one calculates
+C dg(i,j) = dgi / dzj j=1,...,mstar.
+C
+C
+C guess - name of subroutine to evaluate the initial
+C approximation for z(u(x)) and for dmval(u(x))= vector
+C of the mj-th derivatives of u(x). it should have the
+C heading
+C
+C subroutine guess (x , z , dmval)
+C
+C note that this subroutine is needed only if using
+C ipar(9) = 1, and then all mstar components of z
+C and ncomp components of dmval should be specified
+C for any x, aleft .le. x .le. aright .
+C
+C
+C**********************************************************************
+C
+C ************ use of output from colnew ************
+C
+C *** solution evaluation ***
+C
+C on return from colnew, the arrays fspace and ispace
+C contain information specifying the approximate solution.
+C the user can produce the solution vector z( u(x) ) at
+C any point x, aleft .le. x .le. aright, by the statement,
+C
+C call appsln (x, z, fspace, ispace)
+C
+C when saving the coefficients for later reference, only
+C ispace(1),...,ispace(7+ncomp) and
+C fspace(1),...,fspace(ispace(7)) need to be saved as
+C these are the quantities used by appsln.
+C
+C
+C *** simple continuation ***
+C
+C
+C a formerly obtained solution can easily be used as the
+C first approximation for the nonlinear iteration for a
+C new problem by setting (iguess =) ipar(9) = 2, 3 or 4.
+C
+C if the former solution has just been obtained then the
+C values needed to define the first approximation are
+C already in ispace and fspace.
+C alternatively, if the former solution was obtained in a
+C previous run and its coefficients were saved then those
+C coefficients must be put back into
+C ispace(1),..., ispace(7+ncomp) and
+C fspace(1),..., fspace(ispace(7)).
+C
+C for ipar(9) = 2 or 3 set ipar(3) = ispace(1) ( = the
+C size of the previous mesh ).
+C
+C for ipar(9) = 4 the user specifies a new mesh of n subintervals
+C as follows.
+C the values in fspace(1),...,fspace(ispace(7)) have to be
+C shifted by n+1 locations to fspace(n+2),..,fspace(ispace(7)+n+1)
+C and the new mesh is then specified in fspace(1),..., fspace(n+1).
+C also set ipar(3) = n.
+C
+C
+C**********************************************************************
+C
+C *************** package subroutines ***************
+C
+C the following description gives a brief overview of how the
+C procedure is broken down into the subroutines which make up
+C the package called colnew . for further details the
+C user should refer to documentation in the various subroutines
+C and to the references cited above.
+C
+C the subroutines fall into four groups:
+C
+C part 1 - the main storage allocation and program control subr
+C
+C colnew - tests input values, does initialization and breaks up
+C the work areas, fspace and ispace, into the arrays
+C used by the program.
+C colsys - another name for colnew
+C
+C contrl - is the actual driver of the package. this routine
+C contains the strategy for nonlinear equation solving.
+C
+C skale - provides scaling for the control
+C of convergence in the nonlinear iteration.
+C
+C
+C part 2 - mesh selection and error estimation subroutines
+C
+C consts - is called once by colnew to initialize constants
+C which are used for error estimation and mesh selection.
+C
+C newmsh - generates meshes. it contains the test to decide
+C whether or not to redistribute a mesh.
+C
+C errchk - produces error estimates and checks against the
+C tolerances at each subinterval
+C
+C
+C part 3 - collocation system set-up subroutines
+C
+C lsyslv - controls the set-up and solution of the linear
+C algebraic systems of collocation equations which
+C arise at each newton iteration.
+C
+C gderiv - is used by lsyslv to set up the equation associated
+C with a side condition point.
+C
+C vwblok - is used by lsyslv to set up the equation(s) associated
+C with a collocation point.
+C
+C gblock - is used by lsyslv to construct a block of the global
+C collocation matrix or the corresponding right hand
+C side.
+C
+C
+C part 4 - service subroutines
+C
+C appsln - sets up a standard call to approx .
+C
+C approx - evaluates a piecewise polynomial solution.
+C
+C rkbas - evaluates the mesh independent runge-kutta basis
+C
+C vmonde - solves a vandermonde system for given right hand
+C side
+C
+C horder - evaluates the highest order derivatives of the
+C current collocation solution used for mesh refinement.
+C
+C
+C part 5 - linear algebra subroutines
+C
+C to solve the global linear systems of collocation equations
+C constructed in part 3, colnew uses a column oriented version
+C of the package solveblok originally due to de boor and weiss.
+C
+C to solve the linear systems for static parameter condensation
+C in each block of the collocation equations, the linpack
+C routines dgefa and dgesl are included. but these
+C may be replaced when solving problems on vector processors
+C or when solving large scale sparse jacobian problems.
+C
+C----------------------------------------------------------------------
+ IMPLICIT REAL*8 (A-H,O-Z)
+ DIMENSION M(1), ZETA(1), IPAR(1), LTOL(1), TOL(1), DUMMY(1),
+ 1 FIXPNT(1), ISPACE(1), FSPACE(1)
+C
+ COMMON /COLOUT/ PRECIS, IOUT, IPRINT
+ COMMON /COLLOC/ RHO(7), COEF(49)
+ COMMON /COLORD/ K, NC, MSTAR, KD, MMAX, MT(20)
+ COMMON /COLAPR/ N, NOLD, NMAX, NZ, NDMZ
+ COMMON /COLMSH/ MSHFLG, MSHNUM, MSHLMT, MSHALT
+ COMMON /COLSID/ TZETA(40), TLEFT, TRIGHT, IZETA, IDUM
+ COMMON /COLNLN/ NONLIN, ITER, LIMIT, ICARE, IGUESS
+ COMMON /COLEST/ TTL(40), WGTMSH(40), WGTERR(40), TOLIN(40),
+ 1 ROOT(40), JTOL(40), LTTOL(40), NTOL
+C
+ EXTERNAL FSUB, DFSUB, GSUB, DGSUB, GUESS
+C
+C this subroutine can be called either COLNEW or COLSYS
+C
+ ENTRY COLSYS (NCOMP, M, ALEFT, ARIGHT, ZETA, IPAR, LTOL,
+ 1 TOL, FIXPNT, ISPACE, FSPACE, IFLAG,
+ 2 FSUB, DFSUB, GSUB, DGSUB, GUESS)
+C
+C*********************************************************************
+C
+C the actual subroutine colnew serves as an interface with
+C the package of subroutines referred to collectively as
+C colnew. the subroutine serves to test some of the input
+C parameters, rename some of the parameters (to make under-
+C standing of the coding easier), to do some initialization,
+C and to break the work areas fspace and ispace up into the
+C arrays needed by the program.
+C
+C**********************************************************************
+C
+C... specify machine dependent output unit iout and compute machine
+C... dependent constant precis = 100 * machine unit roundoff
+C
+ IF ( IPAR(7) .LE. 0 ) WRITE(6,99)
+ 99 FORMAT(//,33H VERSION *COLNEW* OF COLSYS . ,//)
+C
+ IOUT = 6
+ PRECIS = 1.D0
+ 10 PRECIS = PRECIS / 2.D0
+ PRECP1 = PRECIS + 1.D0
+ IF ( PRECP1 .GT. 1.D0 ) GO TO 10
+ PRECIS = PRECIS * 100.D0
+C
+C... in case incorrect input data is detected, the program returns
+C... immediately with iflag=-3.
+C
+ IFLAG = -3
+ IF ( NCOMP .LT. 1 .OR. NCOMP .GT. 20 ) RETURN
+ DO 20 I=1,NCOMP
+ IF ( M(I) .LT. 1 .OR. M(I) .GT. 4 ) RETURN
+ 20 CONTINUE
+C
+C... rename some of the parameters and set default values.
+C
+ NONLIN = IPAR(1)
+ K = IPAR(2)
+ N = IPAR(3)
+ IF ( N .EQ. 0 ) N = 5
+ IREAD = IPAR(8)
+ IGUESS = IPAR(9)
+ IF ( NONLIN .EQ. 0 .AND. IGUESS .EQ. 1 ) IGUESS = 0
+ IF ( IGUESS .GE. 2 .AND. IREAD .EQ. 0 ) IREAD = 1
+ ICARE = IPAR(10)
+ NTOL = IPAR(4)
+ NDIMF = IPAR(5)
+ NDIMI = IPAR(6)
+ NFXPNT = IPAR(11)
+ IPRINT = IPAR(7)
+ MSTAR = 0
+ MMAX = 0
+ DO 30 I = 1, NCOMP
+ MMAX = MAX0 ( MMAX, M(I) )
+ MSTAR = MSTAR + M(I)
+ MT(I) = M(I)
+ 30 CONTINUE
+ IF ( K .EQ. 0 ) K = MAX0( MMAX + 1 , 5 - MMAX )
+ DO 40 I = 1, MSTAR
+ 40 TZETA(I) = ZETA(I)
+ DO 50 I = 1, NTOL
+ LTTOL(I) = LTOL(I)
+ 50 TOLIN(I) = TOL(I)
+ TLEFT = ALEFT
+ TRIGHT = ARIGHT
+ NC = NCOMP
+ KD = K * NCOMP
+C
+C... print the input data for checking.
+C
+ IF ( IPRINT .GT. -1 ) GO TO 80
+ IF ( NONLIN .GT. 0 ) GO TO 60
+ WRITE (IOUT,260) NCOMP, (M(IP), IP=1,NCOMP)
+ GO TO 70
+ 60 WRITE (IOUT,270) NCOMP, (M(IP), IP=1,NCOMP)
+ 70 WRITE (IOUT,280) (ZETA(IP), IP=1,MSTAR)
+ IF ( NFXPNT .GT. 0 )
+ 1 WRITE (IOUT,340) NFXPNT, (FIXPNT(IP), IP=1,NFXPNT)
+ WRITE (IOUT,290) K
+ WRITE (IOUT,300) (LTOL(IP), IP=1,NTOL)
+ WRITE (IOUT,310) (TOL(IP), IP=1,NTOL)
+ IF (IGUESS .GE. 2) WRITE (IOUT,320)
+ IF (IREAD .EQ. 2) WRITE (IOUT,330)
+ 80 CONTINUE
+C
+C... check for correctness of data
+C
+ IF ( K .LT. 0 .OR. K .GT. 7 ) RETURN
+ IF ( N .LT. 0 ) RETURN
+ IF ( IREAD .LT. 0 .OR. IREAD .GT. 2 ) RETURN
+ IF ( IGUESS .LT. 0 .OR. IGUESS .GT. 4 ) RETURN
+ IF ( ICARE .LT. 0 .OR. ICARE .GT. 2 ) RETURN
+ IF ( NTOL .LT. 0 .OR. NTOL .GT. MSTAR ) RETURN
+ IF ( NFXPNT .LT. 0 ) RETURN
+ IF ( IPRINT .LT. (-1) .OR. IPRINT .GT. 1 ) RETURN
+ IF ( MSTAR .LT. 0 .OR. MSTAR .GT. 40 ) RETURN
+ IP = 1
+ DO 100 I = 1, MSTAR
+ IF ( DABS(ZETA(I) - ALEFT) .LT. PRECIS .OR.
+ 1 DABS(ZETA(I) - ARIGHT) .LT. PRECIS ) GO TO 100
+ 90 IF ( IP .GT. NFXPNT ) RETURN
+ IF ( ZETA(I) - PRECIS .LT. FIXPNT(IP) ) GO TO 95
+ IP = IP + 1
+ GO TO 90
+ 95 IF ( ZETA(I) + PRECIS .LT. FIXPNT(IP) ) RETURN
+ 100 CONTINUE
+C
+C... set limits on iterations and initialize counters.
+C... limit = maximum number of newton iterations per mesh.
+C... see subroutine newmsh for the roles of mshlmt , mshflg ,
+C... mshnum , and mshalt .
+C
+ MSHLMT = 3
+ MSHFLG = 0
+ MSHNUM = 1
+ MSHALT = 1
+ LIMIT = 40
+C
+C... compute the maxium possible n for the given sizes of
+C... ispace and fspace.
+C
+ NREC = 0
+ DO 110 I = 1, MSTAR
+ IB = MSTAR + 1 - I
+ IF ( ZETA(IB) .GE. ARIGHT ) NREC = I
+ 110 CONTINUE
+ NFIXI = MSTAR
+ NSIZEI = 3 + KD + MSTAR
+ NFIXF = NREC * (2*MSTAR) + 5 * MSTAR + 3
+ NSIZEF = 4 + 3 * MSTAR + (KD+5) * (KD+MSTAR) +
+ 1(2*MSTAR-NREC) * 2*MSTAR
+ NMAXF = (NDIMF - NFIXF) / NSIZEF
+ NMAXI = (NDIMI - NFIXI) / NSIZEI
+ IF ( IPRINT .LT. 1 ) WRITE(IOUT,350) NMAXF, NMAXI
+ NMAX = MIN0( NMAXF, NMAXI )
+ IF ( NMAX .LT. N ) RETURN
+ IF ( NMAX .LT. NFXPNT+1 ) RETURN
+ IF (NMAX .LT. 2*NFXPNT+2 .AND. IPRINT .LT. 1) WRITE(IOUT,360)
+C
+C... generate pointers to break up fspace and ispace .
+C
+ LXI = 1
+ LG = LXI + NMAX + 1
+ LXIOLD = LG + 2*MSTAR * (NMAX * (2*MSTAR-NREC) + NREC)
+ LW = LXIOLD + NMAX + 1
+ LV = LW + KD**2 * NMAX
+ LZ = LV + MSTAR * KD * NMAX
+ LDMZ = LZ + MSTAR * (NMAX + 1)
+ LDELZ = LDMZ + KD * NMAX
+ LDELDZ = LDELZ + MSTAR * (NMAX + 1)
+ LDQZ = LDELDZ + KD * NMAX
+ LDQDMZ = LDQZ + MSTAR * (NMAX + 1)
+ LRHS = LDQDMZ + KD * NMAX
+ LVALST = LRHS + KD * NMAX + MSTAR
+ LSLOPE = LVALST + 4 * MSTAR * NMAX
+ LACCUM = LSLOPE + NMAX
+ LSCL = LACCUM + NMAX + 1
+ LDSCL = LSCL + MSTAR * (NMAX + 1)
+ LPVTG = 1
+ LPVTW = LPVTG + MSTAR * (NMAX + 1)
+ LINTEG = LPVTW + KD * NMAX
+C
+C... if iguess .ge. 2, move xiold, z, and dmz to their proper
+C... locations in fspace.
+C
+ IF ( IGUESS .LT. 2 ) GO TO 160
+ NOLD = N
+ IF (IGUESS .EQ. 4) NOLD = ISPACE(1)
+ NZ = MSTAR * (NOLD + 1)
+ NDMZ = KD * NOLD
+ NP1 = N + 1
+ IF ( IGUESS .EQ. 4 ) NP1 = NP1 + NOLD + 1
+ DO 120 I=1,NZ
+ 120 FSPACE( LZ+I-1 ) = FSPACE( NP1+I )
+ IDMZ = NP1 + NZ
+ DO 125 I=1,NDMZ
+ 125 FSPACE( LDMZ+I-1 ) = FSPACE( IDMZ+I )
+ NP1 = NOLD + 1
+ IF ( IGUESS .EQ. 4 ) GO TO 140
+ DO 130 I=1,NP1
+ 130 FSPACE( LXIOLD+I-1 ) = FSPACE( LXI+I-1 )
+ GO TO 160
+ 140 DO 150 I=1,NP1
+ 150 FSPACE( LXIOLD+I-1 ) = FSPACE( N+1+I )
+ 160 CONTINUE
+C
+C... initialize collocation points, constants, mesh.
+C
+ CALL CONSTS ( K, RHO, COEF )
+ CALL NEWMSH (3+IREAD, FSPACE(LXI), FSPACE(LXIOLD), DUMMY,
+ 1 DUMMY, DUMMY, DUMMY, DUMMY, NFXPNT, FIXPNT)
+C
+C... determine first approximation, if the problem is nonlinear.
+C
+ IF (IGUESS .GE. 2) GO TO 230
+ NP1 = N + 1
+ DO 210 I = 1, NP1
+ 210 FSPACE( I + LXIOLD - 1 ) = FSPACE( I + LXI - 1 )
+ NOLD = N
+ IF ( NONLIN .EQ. 0 .OR. IGUESS .EQ. 1 ) GO TO 230
+C
+C... system provides first approximation of the solution.
+C... choose z(j) = 0 for j=1,...,mstar.
+C
+ DO 220 I=1, NZ
+ 220 FSPACE( LZ-1+I ) = 0.D0
+ DO 225 I=1, NDMZ
+ 225 FSPACE( LDMZ-1+I ) = 0.D0
+ 230 CONTINUE
+ IF (IGUESS .GE. 2) IGUESS = 0
+ CALL CONTRL (FSPACE(LXI),FSPACE(LXIOLD),FSPACE(LZ),FSPACE(LDMZ),
+ 1 FSPACE(LRHS),FSPACE(LDELZ),FSPACE(LDELDZ),FSPACE(LDQZ),
+ 2 FSPACE(LDQDMZ),FSPACE(LG),FSPACE(LW),FSPACE(LV),
+ 3 FSPACE(LVALST),FSPACE(LSLOPE),FSPACE(LSCL),FSPACE(LDSCL),
+ 4 FSPACE(LACCUM),ISPACE(LPVTG),ISPACE(LINTEG),ISPACE(LPVTW),
+ 5 NFXPNT,FIXPNT,IFLAG,FSUB,DFSUB,GSUB,DGSUB,GUESS )
+C
+C... prepare output
+C
+ ISPACE(1) = N
+ ISPACE(2) = K
+ ISPACE(3) = NCOMP
+ ISPACE(4) = MSTAR
+ ISPACE(5) = MMAX
+ ISPACE(6) = NZ + NDMZ + N + 2
+ K2 = K * K
+ ISPACE(7) = ISPACE(6) + K2 - 1
+ DO 240 I = 1, NCOMP
+ 240 ISPACE(7+I) = M(I)
+ DO 250 I = 1, NZ
+ 250 FSPACE( N+1+I ) = FSPACE( LZ-1+I )
+ IDMZ = N + 1 + NZ
+ DO 255 I = 1, NDMZ
+ 255 FSPACE( IDMZ+I ) = FSPACE( LDMZ-1+I )
+ IC = IDMZ + NDMZ
+ DO 258 I = 1, K2
+ 258 FSPACE( IC+I ) = COEF(I)
+ RETURN
+C----------------------------------------------------------------------
+ 260 FORMAT(/// 37H THE NUMBER OF (LINEAR) DIFF EQNS IS , I3/ 1X,
+ 1 16HTHEIR ORDERS ARE, 20I3)
+ 270 FORMAT(/// 40H THE NUMBER OF (NONLINEAR) DIFF EQNS IS , I3/ 1X,
+ 1 16HTHEIR ORDERS ARE, 20I3)
+ 280 FORMAT(27H SIDE CONDITION POINTS ZETA, 8F10.6, 4( / 27X, 8F10.6))
+ 290 FORMAT(37H NUMBER OF COLLOC PTS PER INTERVAL IS, I3)
+ 300 FORMAT(39H COMPONENTS OF Z REQUIRING TOLERANCES -,8(7X,I2,1X),
+ 1 4(/38X,8I10))
+ 310 FORMAT(33H CORRESPONDING ERROR TOLERANCES -,6X,8D10.2,
+ 1 4(/39X,8D10.2))
+ 320 FORMAT(44H INITIAL MESH(ES) AND Z,DMZ PROVIDED BY USER)
+ 330 FORMAT(27H NO ADAPTIVE MESH SELECTION)
+ 340 FORMAT(10H THERE ARE ,I5,27H FIXED POINTS IN THE MESH - ,
+ 1 10(6F10.6/))
+ 350 FORMAT(44H THE MAXIMUM NUMBER OF SUBINTERVALS IS MIN (, I4,
+ 1 23H (ALLOWED FROM FSPACE),,I4, 24H (ALLOWED FROM ISPACE) ))
+ 360 FORMAT(/53H INSUFFICIENT SPACE TO DOUBLE MESH FOR ERROR ESTIMATE)
+ END
diff --git a/lib-src/colnew/consts.f b/lib-src/colnew/consts.f
new file mode 100644
index 0000000..110df75
--- /dev/null
+++ b/lib-src/colnew/consts.f
@@ -0,0 +1,147 @@
+ SUBROUTINE CONSTS (K, RHO, COEF)
+C
+C**********************************************************************
+C
+C purpose
+C assign (once) values to various array constants.
+C
+C arrays assigned during compilation:
+C cnsts1 - weights for extrapolation error estimate
+C cnsts2 - weights for mesh selection
+C (the above weights come from the theoretical form for
+C the collocation error -- see [3])
+C
+C arrays assigned during execution:
+C wgterr - the particular values of cnsts1 used for current run
+C (depending on k, m)
+C wgtmsh - gotten from the values of cnsts2 which in turn are
+C the constants in the theoretical expression for the
+C errors. the quantities in wgtmsh are 10x the values
+C in cnsts2 so that the mesh selection algorithm
+C is aiming for errors .1x as large as the user
+C requested tolerances.
+C jtol - components of differential system to which tolerances
+C refer (viz, if ltol(i) refers to a derivative of u(j),
+C then jtol(i)=j)
+C root - reciprocals of expected rates of convergence of compo-
+C nents of z(j) for which tolerances are specified
+C rho - the k collocation points on (0,1)
+C coef -
+C acol - the runge-kutta coefficients values at collocation
+C points
+C
+C**********************************************************************
+C
+ IMPLICIT REAL*8 (A-H,O-Z)
+ DIMENSION RHO(7), COEF(K,1), CNSTS1(28), CNSTS2(28), DUMMY(1)
+C
+ COMMON /COLORD/ KDUM, NCOMP, MSTAR, KD, MMAX, M(20)
+ COMMON /COLBAS/ B(28), ACOL(28,7), ASAVE(28,4)
+ COMMON /COLEST/ TOL(40), WGTMSH(40), WGTERR(40), TOLIN(40),
+ 1 ROOT(40), JTOL(40), LTOL(40), NTOL
+C
+ DATA CNSTS1 / .25D0, .625D-1, 7.2169D-2, 1.8342D-2,
+ 1 1.9065D-2, 5.8190D-2, 5.4658D-3, 5.3370D-3, 1.8890D-2,
+ 2 2.7792D-2, 1.6095D-3, 1.4964D-3, 7.5938D-3, 5.7573D-3,
+ 3 1.8342D-2, 4.673D-3, 4.150D-4, 1.919D-3, 1.468D-3,
+ 4 6.371D-3, 4.610D-3, 1.342D-4, 1.138D-4, 4.889D-4,
+ 5 4.177D-4, 1.374D-3, 1.654D-3, 2.863D-3 /
+ DATA CNSTS2 / 1.25D-1, 2.604D-3, 8.019D-3, 2.170D-5,
+ 1 7.453D-5, 5.208D-4, 9.689D-8, 3.689D-7, 3.100D-6,
+ 2 2.451D-5, 2.691D-10, 1.120D-9, 1.076D-8, 9.405D-8,
+ 3 1.033D-6, 5.097D-13, 2.290D-12, 2.446D-11, 2.331D-10,
+ 4 2.936D-9, 3.593D-8, 7.001D-16, 3.363D-15, 3.921D-14,
+ 5 4.028D-13, 5.646D-12, 7.531D-11, 1.129D-9 /
+C
+C... assign weights for error estimate
+C
+ KOFF = K * ( K + 1 ) / 2
+ IZ = 1
+ DO 10 J = 1, NCOMP
+ MJ = M(J)
+ DO 10 L = 1, MJ
+ WGTERR(IZ) = CNSTS1(KOFF - MJ + L)
+ IZ = IZ + 1
+ 10 CONTINUE
+C
+C... assign array values for mesh selection: wgtmsh, jtol, and root
+C
+ JCOMP = 1
+ MTOT = M(1)
+ DO 40 I = 1, NTOL
+ LTOLI = LTOL(I)
+ 20 CONTINUE
+ IF ( LTOLI .LE. MTOT ) GO TO 30
+ JCOMP = JCOMP + 1
+ MTOT = MTOT + M(JCOMP)
+ GO TO 20
+ 30 CONTINUE
+ JTOL(I) = JCOMP
+ WGTMSH(I) = 1.D1 * CNSTS2(KOFF+LTOLI-MTOT) / TOLIN(I)
+ ROOT(I) = 1.D0 / DFLOAT(K+MTOT-LTOLI+1)
+ 40 CONTINUE
+C
+C... specify collocation points
+C
+ GO TO (50,60,70,80,90,100,110), K
+ 50 RHO(1) = 0.D0
+ GO TO 120
+ 60 RHO(2) = .57735026918962576451D0
+ RHO(1) = - RHO(2)
+ GO TO 120
+ 70 RHO(3) = .77459666924148337704D0
+ RHO(2) = .0D0
+ RHO(1) = - RHO(3)
+ GO TO 120
+ 80 RHO(4) = .86113631159405257523D0
+ RHO(3) = .33998104358485626480D0
+ RHO(2) = - RHO(3)
+ RHO(1) = - RHO(4)
+ GO TO 120
+ 90 RHO(5) = .90617984593866399280D0
+ RHO(4) = .53846931010568309104D0
+ RHO(3) = .0D0
+ RHO(2) = - RHO(4)
+ RHO(1) = - RHO(5)
+ GO TO 120
+ 100 RHO(6) = .93246951420315202781D0
+ RHO(5) = .66120938646626451366D0
+ RHO(4) = .23861918608319690863D0
+ RHO(3) = -RHO(4)
+ RHO(2) = -RHO(5)
+ RHO(1) = -RHO(6)
+ GO TO 120
+ 110 RHO(7) = .949107991234275852452D0
+ RHO(6) = .74153118559939443986D0
+ RHO(5) = .40584515137739716690D0
+ RHO(4) = 0.D0
+ RHO(3) = -RHO(5)
+ RHO(2) = -RHO(6)
+ RHO(1) = -RHO(7)
+ 120 CONTINUE
+C
+C... map (-1,1) to (0,1) by t = .5 * (1. + x)
+C
+ DO 130 J = 1, K
+ RHO(J) = .5D0 * (1.D0 + RHO(J))
+ 130 CONTINUE
+C
+C... now find runge-kutta coeffitients b, acol and asave
+C... the values of asave are to be used in newmsh and errchk .
+C
+ DO 140 J = 1, K
+ DO 135 I = 1, K
+ 135 COEF(I,J) = 0.D0
+ COEF(J,J) = 1.D0
+ CALL VMONDE (RHO, COEF(1,J), K)
+ 140 CONTINUE
+ CALL RKBAS ( 1.D0, COEF, K, MMAX, B, DUMMY, 0)
+ DO 150 I = 1, K
+ CALL RKBAS ( RHO(I), COEF, K, MMAX, ACOL(1,I), DUMMY, 0)
+ 150 CONTINUE
+ CALL RKBAS ( 1.D0/6.D0, COEF, K, MMAX, ASAVE(1,1), DUMMY, 0)
+ CALL RKBAS ( 1.D0/3.D0, COEF, K, MMAX, ASAVE(1,2), DUMMY, 0)
+ CALL RKBAS ( 2.D0/3.D0, COEF, K, MMAX, ASAVE(1,3), DUMMY, 0)
+ CALL RKBAS ( 5.D0/6.D0, COEF, K, MMAX, ASAVE(1,4), DUMMY, 0)
+ RETURN
+ END
diff --git a/lib-src/colnew/contrl.f b/lib-src/colnew/contrl.f
new file mode 100644
index 0000000..52a8b0a
--- /dev/null
+++ b/lib-src/colnew/contrl.f
@@ -0,0 +1,489 @@
+ SUBROUTINE CONTRL (XI, XIOLD, Z, DMZ, RHS, DELZ, DELDMZ,
+ 1 DQZ, DQDMZ, G, W, V, VALSTR, SLOPE, SCALE, DSCALE,
+ 2 ACCUM, IPVTG, INTEGS, IPVTW, NFXPNT, FIXPNT, IFLAG,
+ 3 FSUB, DFSUB, GSUB, DGSUB, GUESS )
+C
+C**********************************************************************
+C
+C purpose
+C this subroutine is the actual driver. the nonlinear iteration
+C strategy is controlled here ( see [4] ). upon convergence, errchk
+C is called to test for satisfaction of the requested tolerances.
+C
+C variables
+C
+C check - maximum tolerance value, used as part of criteria for
+C checking for nonlinear iteration convergence
+C relax - the relaxation factor for damped newton iteration
+C relmin - minimum allowable value for relax (otherwise the
+C jacobian is considered singular).
+C rlxold - previous relax
+C rstart - initial value for relax when problem is sensitive
+C ifrz - number of fixed jacobian iterations
+C lmtfrz - maximum value for ifrz before performing a reinversion
+C iter - number of iterations (counted only when jacobian
+C reinversions are performed).
+C xi - current mesh
+C xiold - previous mesh
+C ipred = 0 if relax is determined by a correction
+C = 1 if relax is determined by a prediction
+C ifreez = 0 if the jacobian is to be updated
+C = 1 if the jacobian is currently fixed (frozen)
+C iconv = 0 if no previous convergence has been obtained
+C = 1 if convergence on a previous mesh has been obtained
+C icare =-1 no convergence occurred (used for regular problems)
+C = 0 a regular problem
+C = 1 a sensitive problem
+C = 2 used for continuation (see description of ipar(10)
+C in colnew).
+C rnorm - norm of rhs (right hand side) for current iteration
+C rnold - norm of rhs for previous iteration
+C anscl - scaled norm of newton correction
+C anfix - scaled norm of newton correction at next step
+C anorm - scaled norm of a correction obtained with jacobian fixed
+C nz - number of components of z (see subroutine approx)
+C ndmz - number of components of dmz (see subroutine approx)
+C imesh - a control variable for subroutines newmsh and errchk
+C = 1 the current mesh resulted from mesh selection
+C or is the initial mesh.
+C = 2 the current mesh resulted from doubling the
+C previous mesh
+C
+C**********************************************************************
+C
+ IMPLICIT REAL*8 (A-H,O-Z)
+ DIMENSION XI(1), XIOLD(1), Z(1), DMZ(1), RHS(1)
+ DIMENSION G(1), W(1), V(1), VALSTR(1), SLOPE(1), ACCUM(1)
+ DIMENSION DELZ(1), DELDMZ(1), DQZ(1), DQDMZ(1) , FIXPNT(1)
+ DIMENSION DUMMY(1), SCALE(1), DSCALE(1)
+ DIMENSION INTEGS(1), IPVTG(1), IPVTW(1)
+C
+ COMMON /COLOUT/ PRECIS, IOUT, IPRINT
+ COMMON /COLORD/ K, NCOMP, MSTAR, KD, MMAX, M(20)
+ COMMON /COLAPR/ N, NOLD, NMAX, NZ, NDMZ
+ COMMON /COLMSH/ MSHFLG, MSHNUM, MSHLMT, MSHALT
+ COMMON /COLSID/ ZETA(40), ALEFT, ARIGHT, IZETA, IDUM
+ COMMON /COLNLN/ NONLIN, ITER, LIMIT, ICARE, IGUESS
+ COMMON /COLEST/ TOL(40), WGTMSH(40), WGTERR(40), TOLIN(40),
+ 1 ROOT(40), JTOL(40), LTOL(40), NTOL
+C
+ EXTERNAL FSUB, DFSUB, GSUB, DGSUB, GUESS
+C
+C... constants for control of nonlinear iteration
+C
+ RELMIN = 1.D-3
+ RSTART = 1.D-2
+ LMTFRZ = 4
+C
+C... compute the maximum tolerance
+C
+ CHECK = 0.D0
+ DO 10 I = 1, NTOL
+ 10 CHECK = DMAX1 ( TOLIN(I), CHECK )
+ IMESH = 1
+ ICONV = 0
+ IF ( NONLIN .EQ. 0 ) ICONV = 1
+ ICOR = 0
+ NOCONV = 0
+ MSING = 0
+C
+C... the main iteration begins here .
+C... loop 20 is executed until error tolerances are satisfied or
+C... the code fails (due to a singular matrix or storage limitations)
+C
+ 20 CONTINUE
+C
+C... initialization for a new mesh
+C
+ ITER = 0
+ IF ( NONLIN .GT. 0 ) GO TO 50
+C
+C... the linear case.
+C... set up and solve equations
+C
+ CALL LSYSLV (MSING, XI, XIOLD, DUMMY, DUMMY, Z, DMZ, G,
+ 1 W, V, RHS, DUMMY, INTEGS, IPVTG, IPVTW, RNORM, 0,
+ 2 FSUB, DFSUB, GSUB, DGSUB, GUESS )
+C
+C... check for a singular matrix
+C
+ IF ( MSING .EQ. 0 ) GO TO 400
+ 30 IF ( MSING .LT. 0 ) GO TO 40
+ IF ( IPRINT .LT. 1 ) WRITE (IOUT,495)
+ GO TO 460
+ 40 IF ( IPRINT .LT. 1 ) WRITE (IOUT,490)
+ IFLAG = 0
+ RETURN
+C
+C... iteration loop for nonlinear case
+C... define the initial relaxation parameter (= relax)
+C
+ 50 RELAX = 1.D0
+C
+C... check for previous convergence and problem sensitivity
+C
+ IF ( ICARE .EQ. 1 .OR. ICARE .EQ. (-1) ) RELAX = RSTART
+ IF ( ICONV .EQ. 0 ) GO TO 160
+C
+C... convergence on a previous mesh has been obtained. thus
+C... we have a very good initial approximation for the newton
+C... process. proceed with one full newton and then iterate
+C... with a fixed jacobian.
+C
+ IFREEZ = 0
+C
+C... evaluate right hand side and its norm and
+C... find the first newton correction
+C
+ CALL LSYSLV (MSING, XI, XIOLD, Z, DMZ, DELZ, DELDMZ, G,
+ 1 W, V, RHS, DQDMZ, INTEGS, IPVTG, IPVTW, RNOLD, 1,
+ 2 FSUB, DFSUB, GSUB, DGSUB, GUESS )
+C
+ IF ( IPRINT .LT. 0 ) WRITE(IOUT,530)
+ IF ( IPRINT .LT. 0 ) WRITE (IOUT,510) ITER, RNOLD
+ GO TO 70
+C
+C... solve for the next iterate .
+C... the value of ifreez determines whether this is a full
+C... newton step (=0) or a fixed jacobian iteration (=1).
+C
+ 60 IF ( IPRINT .LT. 0 ) WRITE (IOUT,510) ITER, RNORM
+ RNOLD = RNORM
+ CALL LSYSLV (MSING, XI, XIOLD, Z, DMZ, DELZ, DELDMZ, G,
+ 1 W, V, RHS, DUMMY, INTEGS, IPVTG, IPVTW, RNORM,
+ 2 3+IFREEZ, FSUB, DFSUB, GSUB, DGSUB, GUESS )
+C
+C... check for a singular matrix
+C
+ 70 IF ( MSING .NE. 0 ) GO TO 30
+ IF ( IFREEZ .EQ. 1 ) GO TO 80
+C
+C... a full newton step
+C
+ ITER = ITER + 1
+ IFRZ = 0
+ 80 CONTINUE
+C
+C... update z and dmz , compute new rhs and its norm
+C
+ DO 90 I = 1, NZ
+ Z(I) = Z(I) + DELZ(I)
+ 90 CONTINUE
+ DO 100 I = 1, NDMZ
+ DMZ(I) = DMZ(I) + DELDMZ(I)
+ 100 CONTINUE
+ CALL LSYSLV (MSING, XI, XIOLD, Z, DMZ, DELZ, DELDMZ, G,
+ 1 W, V, RHS, DUMMY, INTEGS, IPVTG, IPVTW, RNORM, 2,
+ 2 FSUB, DFSUB, GSUB, DGSUB, GUESS )
+C
+C... check monotonicity. if the norm of rhs gets smaller,
+C... proceed with a fixed jacobian; else proceed cautiously,
+C... as if convergence has not been obtained before (iconv=0).
+C
+ IF ( RNORM .LT. PRECIS ) GO TO 390
+ IF ( RNORM .GT. RNOLD ) GO TO 130
+ IF ( IFREEZ .EQ. 1 ) GO TO 110
+ IFREEZ = 1
+ GO TO 60
+C
+C... verify that the linear convergence with fixed jacobian
+C... is fast enough.
+C
+ 110 IFRZ = IFRZ + 1
+ IF ( IFRZ .GE. LMTFRZ ) IFREEZ = 0
+ IF ( RNOLD .LT. 4.D0*RNORM ) IFREEZ = 0
+C
+C... check convergence (iconv = 1).
+C
+ DO 120 IT = 1, NTOL
+ INZ = LTOL(IT)
+ DO 120 IZ = INZ, NZ, MSTAR
+ IF ( DABS(DELZ(IZ)) .GT.
+ 1 TOLIN(IT) * (DABS(Z(IZ)) + 1.D0)) GO TO 60
+ 120 CONTINUE
+C
+C... convergence obtained
+C
+ IF ( IPRINT .LT. 1 ) WRITE (IOUT,560) ITER
+ GO TO 400
+C
+C... convergence of fixed jacobian iteration failed.
+C
+ 130 IF ( IPRINT .LT. 0 ) WRITE (IOUT,510) ITER, RNORM
+ IF ( IPRINT .LT. 0 ) WRITE (IOUT,540)
+ ICONV = 0
+ RELAX = RSTART
+ DO 140 I = 1, NZ
+ Z(I) = Z(I) - DELZ(I)
+ 140 CONTINUE
+ DO 150 I = 1, NDMZ
+ DMZ(I) = DMZ(I) - DELDMZ(I)
+ 150 CONTINUE
+C
+C... update old mesh
+C
+ NP1 = N + 1
+ DO 155 I = 1, NP1
+ 155 XIOLD(I) = XI(I)
+ NOLD = N
+C
+ ITER = 0
+C
+C... no previous convergence has been obtained. proceed
+C... with the damped newton method.
+C... evaluate rhs and find the first newton correction.
+C
+ 160 IF(IPRINT .LT. 0) WRITE (IOUT,500)
+ CALL LSYSLV (MSING, XI, XIOLD, Z, DMZ, DELZ, DELDMZ, G,
+ 1 W, V, RHS, DQDMZ, INTEGS, IPVTG, IPVTW, RNOLD, 1,
+ 2 FSUB, DFSUB, GSUB, DGSUB, GUESS )
+C
+C... check for a singular matrix
+C
+ IF ( MSING .NE. 0 ) GO TO 30
+C
+C... bookkeeping for first mesh
+C
+ IF ( IGUESS .EQ. 1 ) IGUESS = 0
+C
+C... find initial scaling
+C
+ CALL SKALE (N, MSTAR, KD, Z, XI, SCALE, DSCALE)
+ GO TO 220
+C
+C... main iteration loop
+C
+ 170 RNOLD = RNORM
+ IF ( ITER .GE. LIMIT ) GO TO 430
+C
+C... update scaling
+C
+ CALL SKALE (N, MSTAR, KD, Z, XI, SCALE, DSCALE)
+C
+C... compute norm of newton correction with new scaling
+C
+ ANSCL = 0.D0
+ DO 180 I = 1, NZ
+ ANSCL = ANSCL + (DELZ(I) * SCALE(I))**2
+ 180 CONTINUE
+ DO 190 I = 1, NDMZ
+ ANSCL = ANSCL + (DELDMZ(I) * DSCALE(I))**2
+ 190 CONTINUE
+ ANSCL = DSQRT(ANSCL / DFLOAT(NZ+NDMZ))
+C
+C... find a newton direction
+C
+ CALL LSYSLV (MSING, XI, XIOLD, Z, DMZ, DELZ, DELDMZ, G,
+ 1 W, V, RHS, DUMMY, INTEGS, IPVTG, IPVTW, RNORM, 3,
+ 2 FSUB, DFSUB, GSUB, DGSUB, GUESS )
+C
+C... check for a singular matrix
+C
+ IF ( MSING .NE. 0 ) GO TO 30
+C
+C... predict relaxation factor for newton step.
+C
+ ANDIF = 0.D0
+ DO 200 I = 1, NZ
+ ANDIF = ANDIF + ((DQZ(I) - DELZ(I)) * SCALE(I))**2
+ 200 CONTINUE
+ DO 210 I = 1, NDMZ
+ ANDIF = ANDIF + ((DQDMZ(I) - DELDMZ(I)) * DSCALE(I))**2
+ 210 CONTINUE
+ ANDIF = DSQRT(ANDIF/DFLOAT(NZ+NDMZ) + PRECIS)
+ RELAX = RELAX * ANSCL / ANDIF
+ IF ( RELAX .GT. 1.D0 ) RELAX = 1.D0
+ 220 RLXOLD = RELAX
+ IPRED = 1
+ ITER = ITER + 1
+C
+C... determine a new z and dmz and find new rhs and its norm
+C
+ DO 230 I = 1, NZ
+ Z(I) = Z(I) + RELAX * DELZ(I)
+ 230 CONTINUE
+ DO 240 I = 1, NDMZ
+ DMZ(I) = DMZ(I) + RELAX * DELDMZ(I)
+ 240 CONTINUE
+ 250 CALL LSYSLV (MSING, XI, XIOLD, Z, DMZ, DQZ, DQDMZ, G,
+ 1 W, V, RHS, DUMMY, INTEGS, IPVTG, IPVTW, RNORM, 2,
+ 2 FSUB, DFSUB, GSUB, DGSUB, GUESS )
+C
+C... compute a fixed jacobian iterate (used to...
[truncated message content] |
|
From: Akshay S. <ak...@us...> - 2012-03-24 08:33:23
|
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 7f20064540e1c4bbb9ba535c37fb1533831cb217 (commit)
from ff263186ffc1a8443f5733cc975ba2e7c66d2206 (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 7f20064540e1c4bbb9ba535c37fb1533831cb217
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Mar 24 13:59:54 2012 +0530
o Forgot to add file "src/submat.lisp"
diff --git a/src/submat.lisp b/src/submat.lisp
new file mode 100644
index 0000000..078007b
--- /dev/null
+++ b/src/submat.lisp
@@ -0,0 +1,228 @@
+(in-package #:matlisp)
+
+;;
+(defgeneric sub-matrix~ (matrix origin dim)
+ (:documentation
+"
+ Syntax
+ ======
+ (SUB-MATRIX~ matrix origin dimensions)
+
+ Purpose
+ =======
+ Create a block sub-matrix of \"matrix\" starting at \"origin\"
+ of dimension \"dim\", sharing the store.
+
+ origin, dim are lists with two elements.
+
+ Store is shared with \"matrix\"
+
+ Settable
+ ========
+ (setf (SUB-MATRIX~ matrix origin dim) value)
+
+ is basically the same as
+
+ (copy! value (SUB-MATRIX~ matrix origin dim))
+"))
+
+(defun sub-matrix (matrix origin dim)
+ (copy (sub-matrix~ matrix origin dim)))
+
+(defun (setf sub-matrix~) (value matrix origin dim)
+ (copy! value (sub-matrix~ matrix origin dim)))
+
+(defmethod sub-matrix~ ((matrix real-matrix) (origin list) (dim list))
+ (destructuring-bind (o-i o-j) origin
+ (destructuring-bind (nr-s nc-s) dim
+ (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
+ :type (fixnum fixnum fixnum fixnum fixnum (real-matrix-store-type *))))
+ (unless (and (< -1 o-i (+ o-j nr-s) nr) (< -1 o-j (+ o-j nc-s) nc))
+ (error "Bad index and/or size.
+Cannot create a sub-matrix of size (~a ~a) starting at (~a ~a)" nr-s nc-s o-i o-j))
+ (make-instance 'sub-real-matrix
+ :nrows nr-s :ncols nc-s
+ :store st
+ :head (store-indexing o-i o-j hd rs cs)
+ :row-stride rs :col-stride cs)))))
+
+(defmethod sub-matrix~ ((matrix complex-matrix) (origin list) (dim list))
+ (destructuring-bind (o-i o-j) origin
+ (destructuring-bind (nr-s nc-s) dim
+ (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
+ :type (fixnum fixnum fixnum fixnum fixnum (complex-matrix-store-type *))))
+ (unless (and (< -1 o-i (+ o-j nr-s) nr) (< -1 o-j (+ o-j nc-s) nc))
+ (error "Bad index and/or size.
+Cannot create a sub-matrix of size (~a ~a) starting at (~a ~a)" nr-s nc-s o-i o-j))
+ (make-instance 'sub-complex-matrix
+ :nrows nr-s :ncols nc-s
+ :store st
+ :head (store-indexing o-i o-j hd rs cs)
+ :row-stride rs :col-stride cs)))))
+
+;;
+(defgeneric row~ (matrix i)
+ (:documentation
+"
+ Syntax
+ ======
+ (ROW~ matrix i)
+
+ Purpose
+ =======
+ Returns the i'th row of the matrix.
+ Store is shared with \"matrix\".
+
+ Settable
+ ========
+ (setf (ROW~ matrix i) value)
+
+ is basically the same as
+
+ (copy! value (ROW~ matrix i))
+"))
+
+(defun row (matrix i)
+ (copy (row~ matrix i)))
+
+(defun (setf row~) (value matrix i)
+ (copy! value (row~ matrix i)))
+
+(defmethod row~ ((matrix real-matrix) (i fixnum))
+ (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
+ :type (fixnum fixnum fixnum fixnum fixnum (real-matrix-store-type *))))
+ (unless (< -1 i nr)
+ (error "Index ~a is outside the valid range for the given matrix." i))
+ (make-instance 'sub-real-matrix
+ :nrows 1 :ncols nc
+ :store st
+ :head (store-indexing i 0 hd rs cs)
+ :row-stride rs :col-stride cs)))
+
+(defmethod row~ ((matrix complex-matrix) (i fixnum))
+ (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
+ :type (fixnum fixnum fixnum fixnum fixnum (complex-matrix-store-type *))))
+ (unless (< -1 i nr)
+ (error "Index ~a is outside the valid range for the given matrix." i))
+ (make-instance 'sub-complex-matrix
+ :nrows 1 :ncols nc
+ :store st
+ :head (store-indexing i 0 hd rs cs)
+ :row-stride rs :col-stride cs)))
+
+;;
+(defgeneric col~ (matrix j)
+ (:documentation
+"
+ Syntax
+ ======
+ (COL~ matrix j)
+
+ Purpose
+ =======
+ Returns the j'th column of the matrix.
+ Store is shared with \"matrix\".
+
+ Settable
+ ========
+ (setf (COL~ matrix j) value)
+
+ is basically the same as
+
+ (copy! value (COL~ matrix j))
+"))
+
+(defun col (matrix j)
+ (copy (col~ matrix j)))
+
+(defun (setf col~) (value matrix j)
+ (copy! value (col~ matrix j)))
+
+(defmethod col~ ((matrix real-matrix) (j fixnum))
+ (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
+ :type (fixnum fixnum fixnum fixnum fixnum (real-matrix-store-type *))))
+ (unless (< -1 j nc)
+ (error "Index ~a is outside the valid range for the given matrix." j))
+ (make-instance 'sub-real-matrix
+ :nrows nr :ncols 1
+ :store st
+ :head (store-indexing 0 j hd rs cs)
+ :row-stride rs :col-stride cs)))
+
+(defmethod col~ ((matrix complex-matrix) (j fixnum))
+ (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
+ :type (fixnum fixnum fixnum fixnum fixnum (complex-matrix-store-type *))))
+ (unless (< -1 j nc)
+ (error "Index ~a is outside the valid range for the given matrix." j))
+ (make-instance 'sub-complex-matrix
+ :nrows nr :ncols 1
+ :store st
+ :head (store-indexing 0 j hd rs cs)
+ :row-stride rs :col-stride cs)))
+
+;;
+(defgeneric diag~ (matrix &optional d)
+ (:documentation
+"
+ Syntax
+ ======
+ (DIAG~ matrix &optional (d 0))
+
+ Purpose
+ =======
+ Returns a row-vector representing the d'th diagonal of the matrix.
+ [a_{ij} : j - i = d]
+
+ Store is shared with \"matrix\".
+
+ Settable
+ ========
+ (setf (DIAG~ matrix d) value)
+
+ is basically the same as
+
+ (copy! value (DIAG~ matrix d))
+"))
+
+(defun diag (matrix &optional d)
+ (copy (diag~ matrix d)))
+
+(defun (setf diag~) (value matrix &optional (d 0))
+ (copy! value (diag~ matrix d)))
+
+(defmethod diag~ ((matrix real-matrix) &optional (d 0))
+ (declare (type fixnum d))
+ (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
+ :type (fixnum fixnum fixnum fixnum fixnum (real-matrix-store-type *)))
+ ((f-i f-j) (if (< d 0)
+ (values (- d) 0)
+ (values 0 d))
+ :type (fixnum fixnum)))
+ (unless (and (< -1 f-i nr) (< -1 f-j nc))
+ (error "Index ~a is outside the valid range for the given matrix." d))
+ (let ((d-s (min (- nr f-i) (- nc f-j))))
+ (declare (type fixnum d-s))
+ (make-instance 'sub-real-matrix
+ :nrows 1 :ncols d-s
+ :store st
+ :head (store-indexing f-i f-j hd rs cs)
+ :row-stride 1 :col-stride (+ rs cs)))))
+
+
+(defmethod diag~ ((matrix complex-matrix) &optional (d 0))
+ (declare (type fixnum d))
+ (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
+ :type (fixnum fixnum fixnum fixnum fixnum (complex-matrix-store-type *)))
+ ((f-i f-j) (if (< d 0)
+ (values (- d) 0)
+ (values 0 d))
+ :type (fixnum fixnum)))
+ (unless (and (< -1 f-i nr) (< -1 f-j nc))
+ (error "Index ~a is outside the valid range for the given matrix." d))
+ (let ((d-s (min (- nr f-i) (- nc f-j))))
+ (declare (type fixnum d-s))
+ (make-instance 'sub-complex-matrix
+ :nrows 1 :ncols d-s
+ :store st
+ :head (store-indexing f-i f-j hd rs cs)
+ :row-stride 1 :col-stride (+ rs cs)))))
-----------------------------------------------------------------------
Summary of changes:
src/submat.lisp | 228 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
1 files changed, 228 insertions(+), 0 deletions(-)
create mode 100644 src/submat.lisp
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-03-24 08:32:04
|
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 ff263186ffc1a8443f5733cc975ba2e7c66d2206 (commit)
via f53e544eff8af4aa8fdd302a1adc98fed1b5aa35 (commit)
from 9bfeec0a8b2e5604b2ce6b7ad6be62c3fd3f09c4 (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 ff263186ffc1a8443f5733cc975ba2e7c66d2206
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Mar 24 13:57:22 2012 +0530
o Implemented support for callbacks.
o Stated to using new protocol to append "~" to functions
which return matrices which share the store.
o Lots of tweaks to the FFI.
diff --git a/matlisp.asd b/matlisp.asd
index 2529cd7..2c8019c 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -147,8 +147,9 @@
(:file "help")
(:file "special")
(:file "reader")
- ;;(:file "trans")
- ;;(:file "realimag")
+ (:file "trans")
+ (:file "realimag")
+ (:file "submat")
(:file "reshape")
(:file "join")
(:file "svd")
diff --git a/packages.lisp b/packages.lisp
index e4fe2da..94f67e0 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -160,22 +160,27 @@
#:zip-eq
#:cut-cons-chain!
#:when-let
+ #:if-let
#:if-ret
#:get-arg
#:nconsc
#:with-gensyms
#:slot-values
- #:mlet*))
+ #:mlet*
+ #:recursive-append
+ ;;
+ #:foreign-vector #:make-foreign-vector #:foreign-vector-p
+ #:fv-ref #:fv-pointer #:fv-size #:fv-type))
(defpackage :fortran-ffi-accessors
+ (:nicknames :ffi)
#+:cmu (:use :common-lisp :c-call :cffi :utilities)
#+:sbcl (:use :common-lisp :sb-alien :sb-c :cffi :utilities)
#+:allegro (:use :common-lisp :cffi :utilities)
#+(not (or sbcl cmu allegro)) (:use :common-lisp :cffi :utilities)
(:export
;; interface functions
- #:def-fortran-routine
- #:incf-sap
+ #:def-fortran-routine
#:with-vector-data-addresses
)
(:documentation "Fortran foreign function interface"))
@@ -315,14 +320,22 @@
#:store #:store-size
;;Generic functions on standard-matrix
#:fill-matrix
- #:ctranspose! #:ctranspose #:transpose #:transpose!
#:row-or-col-vector-p #:row-vector-p #:col-vector-p
- #:row #:col #:diag #:sub-matrix
+ ;;Submatrix ops
+ #:row~ #:row
+ #:col~ #:col
+ #:diag~ #:diag
+ #:sub-matrix~ #:sub-matrix
+ ;;Transpose
+ #:transpose~ #:transpose! #:transpose
+ #:ctranspose! #:ctranspose
;;Real-double-matrix
#:real-matrix #:real-matrix-element-type #:real-matrix-store-type
;;Complex-double-matrix
#:complex-matrix #:complex-matrix-element-type #:complex-matrix-store-type #:complex-coerce #:complex-double-float
- #:mrealpart #:mimagpart
+ ;;Real and imaginary parts
+ #:mrealpart~ #:mrealpart #:real
+ #:mimagpart~ #:mimagpart #:imag
;;
"CONVERT-TO-LISP-ARRAY"
"DOT"
@@ -399,7 +412,6 @@
"POTRF!"
"POTRS!"
"RAND"
- "REAL"
"RESHAPE!"
"RESHAPE"
"SAVE-MATLISP"
diff --git a/src/axpy.lisp b/src/axpy.lisp
index 662cfd6..0891c60 100644
--- a/src/axpy.lisp
+++ b/src/axpy.lisp
@@ -134,11 +134,11 @@ don't know how to coerce COMPLEX to REAL"))
(generate-typed-axpy!-func complex-double-axpy!-typed complex-double-float complex-matrix-store-type complex-matrix blas:zaxpy)
(defmethod axpy! ((alpha cl:real) (x real-matrix) (y complex-matrix))
- (real-double-axpy!-typed (coerce alpha 'double-float) x (mrealpart y)))
+ (real-double-axpy!-typed (coerce alpha 'double-float) x (mrealpart~ y)))
(defmethod axpy! ((alpha complex) (x real-matrix) (y complex-matrix))
- (real-double-axpy!-typed (coerce (realpart alpha) 'double-float) x (mrealpart y))
- (real-double-axpy!-typed (coerce (imagpart alpha) 'double-float) x (mimagpart y)))
+ (real-double-axpy!-typed (coerce (realpart alpha) 'double-float) x (mrealpart~ y))
+ (real-double-axpy!-typed (coerce (imagpart alpha) 'double-float) x (mimagpart~ y)))
(defmethod axpy! ((alpha number) (x complex-matrix) (y complex-matrix))
(complex-double-axpy!-typed (complex-coerce alpha) x y))
diff --git a/src/complex-matrix.lisp b/src/complex-matrix.lisp
index 3ad8280..928d43f 100644
--- a/src/complex-matrix.lisp
+++ b/src/complex-matrix.lisp
@@ -69,75 +69,6 @@
(aref store (+ 1 (* 2 idx))) (imagpart coerced-value))))
;;
-(defmethod transpose ((matrix complex-matrix))
- (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
- :type (fixnum fixnum fixnum fixnum fixnum (complex-matrix-store-type *))))
- (make-instance 'sub-complex-matrix
- :nrows nc :ncols nr
- :store st
- :head hd
- :row-stride cs :col-stride rs
- :parent matrix)))
-
-;;
-(defmethod sub-matrix ((matrix complex-matrix) (origin list) (dim list))
- (destructuring-bind (o-i o-j) origin
- (destructuring-bind (nr-s nc-s) dim
- (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
- :type (fixnum fixnum fixnum fixnum fixnum (complex-matrix-store-type *))))
- (unless (and (< -1 o-i (+ o-j nr-s) nr) (< -1 o-j (+ o-j nc-s) nc))
- (error "Bad index and/or size.
-Cannot create a sub-matrix of size (~a ~a) starting at (~a ~a)" nr-s nc-s o-i o-j))
- (make-instance 'sub-complex-matrix
- :nrows nr-s :ncols nc-s
- :store st
- :head (store-indexing o-i o-j hd rs cs)
- :row-stride rs :col-stride cs)))))
-
-;;
-(defmethod row ((matrix complex-matrix) (i fixnum))
- (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
- :type (fixnum fixnum fixnum fixnum fixnum (complex-matrix-store-type *))))
- (unless (< -1 i nr)
- (error "Index ~a is outside the valid range for the given matrix." i))
- (make-instance 'sub-complex-matrix
- :nrows 1 :ncols nc
- :store st
- :head (store-indexing i 0 hd rs cs)
- :row-stride rs :col-stride cs)))
-
-;;
-(defmethod col ((matrix complex-matrix) (j fixnum))
- (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
- :type (fixnum fixnum fixnum fixnum fixnum (complex-matrix-store-type *))))
- (unless (< -1 j nc)
- (error "Index ~a is outside the valid range for the given matrix." j))
- (make-instance 'sub-complex-matrix
- :nrows nr :ncols 1
- :store st
- :head (store-indexing 0 j hd rs cs)
- :row-stride rs :col-stride cs)))
-
-;;
-(defmethod diag ((matrix complex-matrix) &optional (d 0))
- (declare (type fixnum d))
- (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
- :type (fixnum fixnum fixnum fixnum fixnum (complex-matrix-store-type *)))
- ((f-i f-j) (if (< d 0)
- (values (- d) 0)
- (values 0 d))
- :type (fixnum fixnum)))
- (unless (and (< -1 f-i nr) (< -1 f-j nc))
- (error "Index ~a is outside the valid range for the given matrix." d))
- (let ((d-s (min (- nr f-i) (- nc f-j))))
- (declare (type fixnum d-s))
- (make-instance 'sub-complex-matrix
- :nrows 1 :ncols d-s
- :store st
- :head (store-indexing f-i f-j hd rs cs)
- :row-stride 1 :col-stride (+ rs cs)))))
-
-;;
(declaim (inline allocate-complex-store))
(defun allocate-complex-store (size)
(make-array (* 2 size) :element-type 'complex-matrix-element-type
@@ -357,31 +288,3 @@ Cannot create a sub-matrix of size (~a ~a) starting at (~a ~a)" nr-s nc-s o-i o-
(make-complex-matrix-dim n m)))
(t
(error "require 1 or 2 arguments to make a matrix")))))
-
-;;
-
-(defun mrealpart (mat)
- (typecase mat
- (real-matrix mat)
- (complex-matrix (make-instance 'sub-real-matrix
- :parent mat :store (store mat)
- :nrows (nrows mat) :ncols (ncols mat)
- :row-stride (* 2 (row-stride mat)) :col-stride (* 2 (col-stride mat))
- :head (* 2 (head mat))))
- (number (cl:realpart mat))))
-
-(defun mimagpart (mat)
- (typecase mat
- (real-matrix nil)
- (complex-matrix (make-instance 'sub-real-matrix
- :parent mat :store (store mat)
- :nrows (nrows mat) :ncols (ncols mat)
- :row-stride (* 2 (row-stride mat)) :col-stride (* 2 (col-stride mat))
- :head (+ 1 (* 2 (head mat)))))
- (number (cl:imagpart mat))))
-
-(defun mconjugate! (mat)
- (typecase mat
- (real-matrix mat)
- (complex-matrix (scal! -1d0 (mimagpart mat))))
- mat)
\ No newline at end of file
diff --git a/src/copy.lisp b/src/copy.lisp
index 344999a..aa3cbda 100644
--- a/src/copy.lisp
+++ b/src/copy.lisp
@@ -219,8 +219,8 @@ don't know how to coerce a COMPLEX to a REAL"))
(complex-double-copy!-typed x y))
(defmethod copy! ((x real-matrix) (y complex-matrix))
- (real-double-copy!-typed x (mrealpart y))
- (scal! 0d0 (mimagpart y))
+ (real-double-copy!-typed x (mrealpart~ y))
+ (scal! 0d0 (mimagpart~ y))
y)
(defmethod copy! ((x number) (y complex-matrix))
diff --git a/src/dlsode.lisp b/src/dlsode.lisp
index 3883519..a284d50 100644
--- a/src/dlsode.lisp
+++ b/src/dlsode.lisp
@@ -1,15 +1,7 @@
-(in-package "MATLISP")
-#+nil
-(progn
-(asdf:oos 'asdf:load-op :cffi)
-
-(load "f77-mangling.lisp")
-(load "cffi-helpers.lisp")
-(load "ffi-cffi.lisp")
-)
+(in-package #:matlisp)
(cffi:define-foreign-library libodepack
- (:unix #.(translate-logical-pathname
+ #+nil(:unix #.(translate-logical-pathname
(merge-pathnames "matlisp:lib;libodepack"
*shared-library-pathname-extension*)))
(t (:default "libodepack")))
@@ -17,13 +9,23 @@
(cffi:use-foreign-library libodepack)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+#+nil(def-fortran-routine testde :void
+ (field (:callback :void
+ (c-neq :integer :input)
+ (c-t :double-float :input)
+ (c-y (* :double-float :size c-neq) :input)
+ (c-ydot (* :double-float :size c-neq) :output)))
+ (neq :integer :input)
+ (y (* :double-float) :input-output))
+
+
(def-fortran-routine dlsode :void
"DLSODE in ODEPACK"
(field (:callback :void
(c-neq :integer :input)
(c-t :double-float :input)
- (c-y (* :double-float) :input)
- (c-ydot (* :double-float) :output)))
+ (c-y (* :double-float :size c-neq) :input)
+ (c-ydot (* :double-float :size c-neq) :output)))
(neq :integer :input)
(y (* :double-float) :input-output)
(ts :double-float :input-output)
@@ -41,31 +43,15 @@
(jacobian (:callback :void
(c-neq :integer :input)
(c-t :double-float :input)
- (c-y (* :double-float) :input)
+ (c-y (* :double-float :size c-neq) :input)
(c-upper-bandwidth :integer :input)
(c-lower-bandwidth :integer :input)
- (c-pd (* :double-float) :output)
+ (c-pd (* :double-float :size (* c-neq c-neq)) :output)
(c-nrowpd :integer :input)))
(mf :integer :input))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun lsode-evolve (field y t-array report)
- ;; Use gensym ? Will have to use a macrolet.
- (cffi:defcallback *evolve-callback* :void ((c-neq :pointer :int)
- (c-tc :pointer :double)
- (c-y :pointer :double)
- (c-ydot :pointer :double))
- (let* ((neq (cffi:mem-aref c-neq :int))
- (y (make-array neq :element-type 'double-float :initial-element 0d0))
- (ts (cffi:mem-aref c-tc :double)))
- ;; Copy things to simple-arrays
- (loop for i from 0 below neq
- do (setf (aref y i) (cffi:mem-aref c-y :double i)))
- ;; Assume form of field
- (let ((ydot (funcall field ts y)))
- ;; Copy ydot back
- (loop for i from 0 below neq
- do (setf (cffi:mem-aref c-ydot :double i) (aref ydot i))))))
;;
(let* ((neq (length y))
(lrw (+ 22 (* 9 neq) (* neq neq) 5))
@@ -86,21 +72,22 @@
do (progn
(setq tout (aref t-array i))
(multiple-value-bind (y-out ts-out istate-out rwork-out iwork-out)
- (dlsode (cffi:callback *evolve-callback*) neq y ts tout itol rtol atol itask istate iopt rwork lrw iwork liw (cffi:null-pointer) mf)
+ (dlsode field neq y ts tout itol rtol atol itask istate iopt rwork lrw iwork liw (cffi:null-pointer) mf)
(setq ts ts-out)
(setq istate istate-out))
(funcall report ts y)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun pend-field (ts y)
- (make-array 2 :element-type 'double-float :initial-contents `(,(aref y 1) ,(- (sin (aref y 0))))))
+(defun pend-field (neq time y ydot)
+ (setf (fv-ref ydot 0) (fv-ref y 1)
+ (fv-ref ydot 1) (- (sin (fv-ref y 0)))))
(defun pend-report (ts y)
(format t "~A ~A ~A ~%" ts (aref y 0) (aref y 1)))
(defvar y (make-array 2 :element-type 'double-float :initial-contents `(,(/ pi 2) 0d0)))
-(lsode-evolve #'pend-field y #(0d0 1d0) #'pend-report)
+;; (lsode-evolve #'pend-field y #(0d0 1d0 2d0) #'pend-report)
;; Should return
;; 1.0d0 1.074911802207049d0 -0.975509986605856d0
;; 2.0d0 -0.20563950412081608d0 -1.3992359518735706d0
diff --git a/src/dot.lisp b/src/dot.lisp
index badff89..5a5d896 100644
--- a/src/dot.lisp
+++ b/src/dot.lisp
@@ -139,7 +139,7 @@
(let ((realpart (ddot nxm store-x 1 store-y 2))
(imagpart (with-vector-data-addresses ((addr-x store-x)
(addr-y store-y))
- (incf-sap :double-float addr-y)
+ (incf-sap addr-y :double-float)
(ddot nxm addr-x 1 addr-y 2))))
(declare (type complex-matrix-element-type realpart imagpart))
@@ -192,7 +192,7 @@
(let ((realpart (ddot nxm store-x 2 store-y 1))
(imagpart (with-vector-data-addresses ((addr-x store-x)
(addr-y store-y))
- (incf-sap :double-float addr-x)
+ (incf-sap addr-x :double-float)
(ddot nxm addr-x 2 addr-y 1))))
(declare (type complex-matrix-element-type realpart imagpart))
diff --git a/src/ffi-cffi-interpreter-specific.lisp b/src/ffi-cffi-interpreter-specific.lisp
index 75afa9a..eda8343 100644
--- a/src/ffi-cffi-interpreter-specific.lisp
+++ b/src/ffi-cffi-interpreter-specific.lisp
@@ -82,14 +82,16 @@ Returns
#+(or sbcl cmu ccl)
(defmacro with-vector-data-addresses (vlist &body body)
- "WITH-VECTOR-DATA-ADDRESSES (var-list &body body)
+"
+ WITH-VECTOR-DATA-ADDRESSES (var-list &body body)
- Execute the body with the variables in VAR-LIST appropriately bound.
- VAR-LIST should be a list of pairs. The first element is the address
- of the desired object; the second element is the variable whose address
- we want.
+ Execute the body with the variables in VAR-LIST appropriately bound.
+ VAR-LIST should be a list of pairs. The first element is the address
+ of the desired object; the second element is the variable whose address
+ we want.
- Garbage collection is also disabled while executing the body."
+ Garbage collection is also disabled while executing the body.
+"
;; We wrap everything inside a WITHOUT-GCING form to inhibit garbage
;; collection to avoid complications that may arise during a
;; collection while in a fortran call.
@@ -103,13 +105,7 @@ Returns
(let (,@(mapcar #'(lambda (lst)
(destructuring-bind (addr-var var &key inc-type inc) lst
`(,addr-var ,@(if inc
- `((cffi:inc-pointer (vector-data-address ,var)
- ,@(case inc-type
- (:double-float `((* ,inc 8)))
- (:single-float `((* ,inc 4)))
- (:complex-double-float `((* ,inc 16)))
- (:complex-single-float `((* ,inc 8)))
- (t `(,inc)))))
+ `((inc-sap (vector-data-address ,var) ,inc-type ,inc))
`((vector-data-address ,var))))))
vlist))
,@body))))
diff --git a/src/ffi-cffi.lisp b/src/ffi-cffi.lisp
index b1d8bcc..5146374 100644
--- a/src/ffi-cffi.lisp
+++ b/src/ffi-cffi.lisp
@@ -11,97 +11,102 @@
(in-package "FORTRAN-FFI-ACCESSORS")
-#+(or)
(defconstant +ffi-types+ '(:single-float :double-float
:complex-single-float :complex-double-float
:integer :long
:string
:callback))
-
(defconstant +ffi-styles+ '(:input :input-value :workspace
;;
:input-output :output :workspace-output))
+
;; Create objects on the heap and run some stuff.
-(defmacro with-foreign-objects-heap-ed (declarations &rest body)
- "
-Allocate \"objects\" on the heap and run the \"body\" of code.
+(defmacro with-foreign-objects-heaped (declarations &rest body)
+"
+ Allocate \"objects\" on the heap and run the \"body\" of code.
-with-foreign-objects-heap-ed (declarations) &rest body
-binding := {(var type &optional count &key (initial-contents nil))}*
+ with-foreign-objects-heap-ed (declarations) &rest body
+ binding := {(var type &optional count &key (initial-contents nil))}*
-Example:
->> (with-foreign-objects-heap-ed ((x :int :count 10 :initial-element 2))
- (+ (cffi:mem-aref x :int 2) 1))
-3
+ Example:
+ >> (with-foreign-objects-heaped ((x :int :count 10 :initial-element 2))
+ (+ (cffi:mem-aref x :int 2) 1))
+ 3
>>
- "
- (let ((ret (gensym)))
- ;; Allocate objects from the heap
- `(let* (,@(mapcar (lambda (decl) (list (car decl) `(cffi:foreign-alloc ,@(cdr decl))))
- declarations)
- ;; Store result temporarily
- (,ret (progn ,@body)))
- ;;Free C objects
- ,@(mapcar (lambda (decl) `(cffi:foreign-free ,(car decl)))
- declarations)
- ,ret)))
+"
+;; Allocate objects from the heap
+ (recursive-append
+ (when declarations
+ `(let (,@(mapcar (lambda (decl) (let ((var (car decl)))
+ (check-type var symbol)
+ `(,var (cffi:foreign-alloc ,@(cdr decl)))))
+ declarations))))
+ ;; Store result and then free foreign-objects
+ (when declarations
+ `(multiple-value-prog1))
+ `((progn
+ ,@body)
+ ;;Free C objects
+ ,@(mapcar (lambda (decl) `(cffi:foreign-free ,(car decl)))
+ declarations))))
;; Create objects on the stack and run the "body" of code.
-(defmacro with-foreign-objects-stack-ed (declarations &rest body)
- "
-Allocate \"objects\" on the stack and run the \"body\" of code.
-
-with-foreign-objects-stack-ed (declarations) &rest body
-binding := {(var type &optional count &key (initial-contents nil))}*
-
-Example:
->> (with-foreign-objects-stack-ed ((x :int :count 10 :initial-element 2))
- (+ (cffi:mem-aref x :int 2) 1))
-3
->>
- "
- (if (null declarations)
- `(progn ,@body)
- (let ((wfo-decl nil)
- (wfo-body nil)
- (wfo-before nil))
- (loop for decl in declarations
- do (destructuring-bind (var type &key (count 1) initial-element initial-contents) decl
- ;;Make sure the var and type are symbols;;
- (check-type var symbol)
- (check-type type symbol)
- (when (and initial-element initial-contents)
- (error "Cannot apply both :initial-element and :initial-contents at the same time."))
- ;;
- (if (eq count 1)
- (progn
- ;; Count defaults to one in with-foreign-objects
- (nconsc wfo-decl `((,var ,type)))
- (if (or initial-element initial-contents)
- (nconsc wfo-body `((setf (cffi:mem-aref ,var ,type 0) ,@(cond
- (initial-element `(,initial-element))
- (initial-contents `((car ,initial-contents)))))))))
- ;;
- (let ((decl-count (gensym))
- (decl-init (gensym))
- (loop-var (gensym)))
- ;;
- (nconsc wfo-before `((,decl-count ,count)))
- (nconsc wfo-before `((,decl-init ,(or initial-element initial-contents))))
- ;;
- (nconsc wfo-decl `((,var ,type ,decl-count)))
- (if (or initial-element initial-contents)
- (nconsc wfo-body `((loop for ,loop-var from 0 below ,decl-count
- do (setf (cffi:mem-aref ,var ,type ,loop-var) ,@(cond
- (initial-element `(,decl-init))
-
- (initial-contents `((elt ,decl-init ,loop-var)))))))))))))
- `(let (,@wfo-before)
- (cffi:with-foreign-objects (,@wfo-decl)
- ,@wfo-body
- ,@body)))))
+(defmacro with-foreign-objects-stacked (declarations &rest body)
+"
+ Allocate \"objects\" on the stack and run the \"body\" of code.
+
+ with-foreign-objects-stacked (declarations) &rest body
+ binding := {(var type &optional count &key (initial-contents nil))}*
+
+ Example:
+ >> (with-foreign-objects-stacked ((x :int :count 10 :initial-element 2))
+ (+ (cffi:mem-aref x :int 2) 1))
+ 3
+ >>
+"
+ (let ((wfo-decl nil)
+ (wfo-body nil)
+ (wfo-before nil))
+ (dolist (decl declarations)
+ (destructuring-bind (var type &key (count 1) initial-element initial-contents) decl
+ ;;Make sure the var and type are symbols;;
+ (check-type var symbol)
+ (check-type type symbol)
+ (when (and initial-element initial-contents)
+ (error "Cannot apply both :initial-element and :initial-contents at the same time."))
+ ;;
+ (if (eq count 1)
+ (progn
+ ;; Count defaults to one in with-foreign-objects
+ (nconsc wfo-decl `((,var ,type)))
+ (if (or initial-element initial-contents)
+ (nconsc wfo-body `((setf (cffi:mem-aref ,var ,type 0) ,@(cond
+ (initial-element `(,initial-element))
+ (initial-contents `((elt ,initial-contents 0)))))))))
+ ;;
+ (let ((decl-count (gensym))
+ (decl-init (gensym))
+ (loop-var (gensym)))
+ ;;
+ (nconsc wfo-before `((,decl-count ,count)))
+ (nconsc wfo-before `((,decl-init ,(or initial-element initial-contents))))
+ ;;
+ (nconsc wfo-decl `((,var ,type ,decl-count)))
+ (if (or initial-element initial-contents)
+ (nconsc wfo-body `((dotimes (,loop-var ,decl-count)
+ (setf (cffi:mem-aref ,var ,type ,loop-var) ,@(cond
+ (initial-element `(,decl-init))
+ (initial-contents `((elt ,decl-init ,loop-var)))))))))))))
+ (recursive-append
+ (when wfo-before
+ `(let (,@wfo-before)))
+ (if wfo-decl
+ `(cffi:with-foreign-objects (,@wfo-decl))
+ `(progn))
+ `(,@wfo-body
+ ,@body))))
;; Get the equivalent CFFI type.
;; If the type is an array, get the type of the array element type.
@@ -201,8 +206,7 @@ Example:
(:string
;; String lengths are appended to the function arguments,
;; passed by value.
- (pushnew `(,(scat "LEN-" name) ,@(->cffi-type :integer))
- aux-pars)
+ (nconsc aux-pars `((,(scat "LEN-" name) ,@(->cffi-type :integer))))
`(,name ,@(->cffi-type :string)))
(t
`(,name ,@(get-read-in-type type style))))))
@@ -214,14 +218,14 @@ Example:
;; Call defcfun to define the foreign function.
;; Also creates a nice lisp helper function.
(defmacro def-fortran-routine (func-name return-type &rest body)
- (multiple-value-bind (name fortran-name) (if (listp func-name)
- (values (cadr func-name) (car func-name))
- (values func-name (make-fortran-name func-name)))
+ (multiple-value-bind (fortran-name name) (if (listp func-name)
+ (values (car func-name) (cadr func-name))
+ (values (make-fortran-name func-name) func-name))
(let* ((lisp-name (make-fortran-ffi-name `,name))
(hack-return-type `,return-type)
(hack-body `(,@body))
(hidden-var-name nil))
-
+ ;;
(multiple-value-bind (doc pars)
(parse-doc-&-parameters `(,@body))
(when (member hack-return-type '(:complex-single-float :complex-double-float))
@@ -236,7 +240,7 @@ Example:
(,hidden-var-name ,hack-return-type :output)
,@pars))
(setq hack-return-type :void)))
-
+
`(eval-when (load eval compile)
(progn
;; Removing 'inlines' It seems that CMUCL has a problem with
@@ -257,6 +261,7 @@ Example:
(return-vars nil)
(array-vars nil)
(ref-vars nil)
+ (callback-code nil)
;;
(defun-args nil)
(defun-keyword-args nil)
@@ -265,133 +270,230 @@ Example:
;;
(ffi-args nil)
(aux-ffi-args nil))
- (loop for decl in pars
- do (destructuring-bind (var type &optional style) decl
- (let ((ffi-var nil)
- (aux-var nil))
- (cond
- ;; Callbacks are tricky because the data inside
- ;; pointer arrays will need to be copied without
- ;; implicit knowledge of the size of the array.
- ;; This is usually taken care of by special data
- ;; structure - ala GSL - or by passing additional
- ;; arguments to the callback to apprise it of the
- ;; bounds on the arrays.
- ;; TODO: Add support for declaring array dimensions
- ;; in the callback declaration.
- ((callback-type-p type)
- (setq ffi-var var))
- ;; Can't really enforce "style" when given an array.
- ;; Complex numbers do not latch onto this case, they
- ;; are passed by value.
- ((array-p type)
- (setq ffi-var (scat "ADDR-" var))
- (nconsc array-vars `((,ffi-var ,var)))
- ;;
- (when-let (arg (get-arg :inc type))
- (nconsc defun-keyword-args
- `((,arg 0)))
- (nconc (car (last array-vars)) `(:inc-type ,(cadr type) :inc ,arg))))
- ;; Strings
- ((string-p type)
- (setq ffi-var var)
- (setq aux-var (scat "LEN-" var))
- (nconsc aux-args `((,aux-var (length (the string ,var))))))
- ;; Pass-by-value variables
- ((eq style :input-value)
- (setq ffi-var var))
- ;; Pass-by-reference variables
- (t
- (cond
- ;; Makes more sense to copy complex numbers into
- ;; arrays, rather than twiddling around with lisp
- ;; memory internals.
- ((member type '(:complex-single-float :complex-double-float))
- (setq ffi-var (scat "ADDR-REAL-CAST-" var))
- (nconsc ref-vars
- `((,ffi-var ,(second (->cffi-type type)) :count 2 :initial-contents (list (realpart ,var) (imagpart ,var))))))
- (t
- (setq ffi-var (scat "REF-" var))
- (nconsc ref-vars
- `((,ffi-var ,@(->cffi-type type) :initial-element ,var)))))))
- ;; Output variables
- (when (and (output-p style) (not (eq type :string)))
- (nconsc return-vars
- `((,ffi-var ,var ,type))))
- ;; Arguments for the lisp wrapper
- (when (not (eq var hidden-var-name))
- (nconsc defun-args
- `(,var)))
- ;; Arguments for the FFI function
- (nconsc ffi-args
- `(,ffi-var))
- ;; Auxillary arguments for FFI
- (when (not (null aux-var))
- (nconsc aux-ffi-args
- `(,aux-var))))))
- ;;Return the function definition
+ (dolist (decl pars)
+ (destructuring-bind (var type &optional style) decl
+ (let ((ffi-var nil)
+ (aux-var nil))
+ (cond
+ ;; Callbacks are tricky.
+ ((callback-type-p type)
+ (let* ((callback-name (gensym (symbol-name var)))
+ (c-callback-code (def-fortran-callback var callback-name (second type) (cddr type))))
+ (nconsc callback-code c-callback-code)
+ (setq ffi-var `(cffi:callback ,callback-name))))
+ ;; Can't really enforce "style" when given an array.
+ ;; Complex numbers do not latch onto this case, they
+ ;; are passed by value.
+ ((array-p type)
+ (setq ffi-var (scat "ADDR-" var))
+ (nconsc array-vars `((,ffi-var ,var)))
+ ;;
+ (when-let (arg (get-arg :inc type))
+ (nconsc defun-keyword-args
+ `((,arg 0)))
+ (nconc (car (last array-vars)) `(:inc-type ,(cadr type) :inc ,arg))))
+ ;; Strings
+ ((string-p type)
+ (setq ffi-var var)
+ (setq aux-var (scat "LEN-" var))
+ (nconsc aux-args `((,aux-var (length (the string ,var))))))
+ ;; Pass-by-value variables
+ ((eq style :input-value)
+ (setq ffi-var var))
+ ;; Pass-by-reference variables
+ (t
+ (cond
+ ;; Makes more sense to copy complex numbers into
+ ;; arrays, rather than twiddling around with lisp
+ ;; memory internals.
+ ((member type '(:complex-single-float :complex-double-float))
+ (setq ffi-var (scat "ADDR-REAL-CAST-" var))
+ (nconsc ref-vars
+ `((,ffi-var ,(second (->cffi-type type)) :count 2 :initial-contents (list (realpart ,var) (imagpart ,var))))))
+ (t
+ (setq ffi-var (scat "REF-" var))
+ (nconsc ref-vars
+ `((,ffi-var ,@(->cffi-type type) :initial-element ,var)))))))
+ ;; Output variables
+ (when (and (output-p style) (not (eq type :string)))
+ (nconsc return-vars
+ `((,ffi-var ,var ,type))))
+ ;; Arguments for the lisp wrapper
+ (unless (eq var hidden-var-name)
+ (nconsc defun-args
+ `(,var)))
+ ;; Arguments for the FFI function
+ (nconsc ffi-args
+ `(,ffi-var))
+ ;; Auxillary arguments for FFI
+ (unless (null aux-var)
+ (nconsc aux-ffi-args
+ `(,aux-var))))))
+ ;;Complex returns through hidden variable.
+ (unless (null hidden-var-name)
+ (nconsc aux-args `((,hidden-var-name ,(ecase (second (first pars))
+ (:complex-single-float #c(0e0 0e0))
+ (:complex-double-float #c(0d0 0d0)))))))
+ ;;Keyword argument list
(unless (null defun-keyword-args)
- (setq defun-keyword-args (append '(&key) defun-keyword-args)))
+ (setq defun-keyword-args (cons '&key defun-keyword-args)))
+ ;;Return the function definition
+ (let ((retvar (gensym)))
+ `(
+ ,(recursive-append
+ `(defun ,name ,(append defun-args defun-keyword-args)
+ ,@doc)
+ ;;
+ (unless (null aux-args)
+ `(let (,@aux-args)))
+ ;;Don't use with-foreign.. if ref-vars is nil
+ (unless (null ref-vars)
+ `(with-foreign-objects-stacked (,@ref-vars)))
+ ;;Don't use with-vector-dat.. if array-vars is nil
+ (unless (null array-vars)
+ `(with-vector-data-addresses (,@array-vars)))
+ ;;Declare callbacks
+ callback-code
+ ;;Call the foreign-function
+ `(let ((,retvar (,ffi-fn ,@ffi-args ,@aux-ffi-args)))
+ ;;Ignore return if type is :void
+ ,@(when (eq return-type :void)
+ `((declare (ignore ,retvar))))
+ ;; Copy values in reference pointers back to local
+ ;; variables. Lisp has local scope; its safe to
+ ;; modify variables in parameter lists.
+ ,@(mapcar #'(lambda (decl)
+ (destructuring-bind (ffi-var var type) decl
+ (if (member type '(:complex-single-float :complex-double-float))
+ `(setq ,var (complex (cffi:mem-aref ,ffi-var ,(second (->cffi-type type)) 0)
+ (cffi:mem-aref ,ffi-var ,(second (->cffi-type type)) 1)))
+ `(setq ,var (cffi:mem-aref ,ffi-var ,@(->cffi-type type))))))
+ (remove-if-not #'(lambda (x)
+ (member (first x) ref-vars :key #'car))
+ return-vars))
+ (values
+ ,@(unless (eq return-type :void)
+ `(,retvar))
+ ,@(mapcar #'second return-vars)))))))))
+
+
+(defun def-fortran-callback (func callback-name return-type parm)
+ (let* ((hack-return-type `,return-type)
+ (hack-parm `(,@parm))
+ (hidden-var-name nil))
+ ;;
+ (when (member hack-return-type '(:complex-single-float :complex-double-float))
+ (setq hidden-var-name (gensym "HIDDEN-COMPLEX-RETURN-"))
+ (setq hack-parm `((,hidden-var-name ,hack-return-type :output)
+ ,@parm))
+ (setq hack-return-type :void))
+ ;;
+ (let* ((new-pars nil)
+ (aux-pars nil)
+ (func-pars nil)
+ (array-vars nil)
+ (return-vars nil)
+ (ref-vars nil))
+ (dolist (decl hack-parm)
+ (destructuring-bind (var type &optional (style :input)) decl
+ (let ((ffi-var nil)
+ (func-var nil))
+ (cond
+ ;; Callbacks are tricky.
+ ((callback-type-p type)
+ (setq ffi-var var)
+ (setq func-var var))
+ ;;
+ ((array-p type)
+ (setq ffi-var (scat "ADDR-" var))
+ (setq func-var var)
+ (nconsc array-vars `((,func-var (make-foreign-vector :pointer ,ffi-var :type ,(second (->cffi-type type))
+ :size ,(if-let (size (get-arg :size type))
+ size
+ 1))))))
+ ;;
+ ((string-p type)
+ (setq ffi-var var)
+ (setq func-var var)
+ (nconsc aux-pars
+ `((,(scat "LEN-" var) ,@(->cffi-type :integer)))))
+ ;;
+ ((eq style :input-value)
+ (setq ffi-var var)
+ (setq func-var var))
+ ;; Pass-by-reference variables
+ (t
+ (cond
+ ((member type '(:complex-single-float :complex-double-float))
+ (setq ffi-var (scat "ADDR-REAL-CAST-" var))
+ (setq func-var var)
+ (nconsc ref-vars
+ `((,func-var (complex (cffi:mem-aref ,ffi-var ,(second (->cffi-type type)) 0)
+ (cffi:mem-aref ,ffi-var ,(second (->cffi-type type)) 1))))))
+ (t
+ (setq ffi-var (scat "REF-" var))
+ (setq func-var var)
+ (nconsc ref-vars
+ `((,func-var (cffi:mem-aref ,ffi-var ,@(->cffi-type type)))))))))
+ ;;
+ (nconsc new-pars `((,ffi-var ,@(get-read-in-type type style))))
+ (nconsc func-pars `(,func-var))
+ (when (and (output-p style) (not (eq type :string)))
+ (nconsc return-vars
+ `((,func-var ,ffi-var ,type)))))))
(let ((retvar (gensym)))
`(
- (defun ,name ,(append defun-args defun-keyword-args)
- ,@doc
- (let (,@(if (not (null hidden-var-name))
- `((,hidden-var-name ,@(if (eq (second (first pars))
- :complex-single-float)
- `(#C(0e0 0e0))
- `(#C(0d0 0d0)))))))
- (with-foreign-objects-stack-ed (,@ref-vars)
- (with-vector-data-addresses (,@array-vars)
- (let* (,@aux-args
- ;;Style warnings are annoying.
- ,@(if (not (eq return-type :void))
- `((,retvar (,ffi-fn ,@ffi-args ,@aux-ffi-args))))
- )
- ,@(if (eq return-type :void)
- `((,ffi-fn ,@ffi-args ,@aux-ffi-args)))
- ;; Copy values in reference pointers back to local
- ;; variables. Lisp has local scope; its safe to
- ;; modify variables in parameter lists.
- ,@(mapcar #'(lambda (decl)
- (destructuring-bind (ffi-var var type) decl
- (if (member type '(:complex-single-float :complex-double-float))
- `(setq ,var (complex (cffi:mem-aref ,ffi-var ,(second (->cffi-type type)) 0)
- (cffi:mem-aref ,ffi-var ,(second (->cffi-type type)) 1)))
- `(setq ,var (cffi:mem-aref ,ffi-var ,@(->cffi-type type))))))
- (remove-if-not #'(lambda (x)
- (member (first x) ref-vars :key #'car))
- return-vars))
- (values
- ,@(if (not (eq return-type :void))
- `(,retvar))
- ,@(mapcar #'second return-vars))))))))))))
+ ,(recursive-append
+ `(cffi:defcallback ,callback-name ,@(get-return-type hack-return-type)
+ (,@new-pars ,@aux-pars))
+ ;;
+ (when ref-vars
+ `(let (,@ref-vars)))
+ ;;
+ (when array-vars
+ `(let (,@array-vars)))
+ ;;
+ `(multiple-value-bind (,retvar ,@(mapcar #'car return-vars)) (funcall ,func ,@func-pars)
+ ,@(when (eq hack-return-type :void)
+ `((declare (ignore ,retvar))))
+ ,@(mapcar #'(lambda (decl)
+ (destructuring-bind (func-var ffi-var type) decl
+ (if (member type '(:complex-single-float :complex-double-float))
+ `(setf (cffi:mem-aref ,ffi-var ,(second (->cffi-type type)) 0) (realpart ,func-var)
+ (cffi:mem-aref ,ffi-var ,(second (->cffi-type type)) 1) (imagpart ,func-var))
+ `(setf (cffi:mem-aref ,ffi-var ,@(->cffi-type type)) ,func-var))))
+ (remove-if-not #'(lambda (x)
+ (member (first x) ref-vars :key #'car))
+ return-vars))
+ ,(if (eq hack-return-type :void)
+ nil
+ retvar))))))))
;; Increment the pointer.
-(defmacro incf-sap (type sap &optional (n 1))
- "Increment the pointer address by one \"slot\"
- depending on the type:
+(defun inc-sap (sap type &optional (n 1))
+"
+ Increment the pointer address by one \"slot\"
+ depending on the type:
:double-float 8 bytes
:single-float 4 bytes
:complex-double-float 8x2 bytes
:complex-single-float 4x2 bytes
- "
- (check-type type symbol)
- `(setf ,sap
- (cffi:inc-pointer ,sap
- ,@(ecase type
- (:double-float `((* ,n 8)))
- (:single-float `((* ,n 4)))
- (:complex-double-float `((* ,n 16)))
- (:complex-single-float `((* ,n 8)))))))
+ "
+ (cffi:inc-pointer sap
+ (ecase type
+ (:double-float (* n 8))
+ (:single-float (* n 4))
+ (:complex-double-float (* n 16))
+ (:complex-single-float (* n 8)))))
+
+(define-modify-macro incf-sap (type &optional (n 1)) inc-sap)
;; Supporting multidimensional arrays is a pain.
;; Only support types that we currently use.
(deftype matlisp-specialized-array ()
- `(or (simple-array (complex double-float) (*))
- (simple-array (complex single-float) (*))
- (simple-array double-float (*))
+ `(or (simple-array double-float (*))
+ ;;
(simple-array single-float (*))
;;
(simple-array (signed-byte 32) *)
diff --git a/src/gemm.lisp b/src/gemm.lisp
index e4d227c..5ca6f21 100644
--- a/src/gemm.lisp
+++ b/src/gemm.lisp
@@ -123,15 +123,15 @@
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))
+ (when (eq job-a :t) (transpose! a))
+ (when (eq job-b :t) (transpose! 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))
+ (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))
@@ -140,8 +140,8 @@
(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))
+ (row-a (transpose! (row~ a 0)) :type ,matrix-type)
+ (row-c (transpose! (row~ c 0)) :type ,matrix-type))
(dotimes (i nr-c)
(when (> i 0)
(setf (head row-a) (+ (head row-a) rs-a))
@@ -153,8 +153,8 @@
((< 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))
+ (when (eq job-a :t) (transpose! a))
+ (when (eq job-b :t) (transpose! b))
)))
c))
;;;;
@@ -246,9 +246,17 @@
;
(defmethod gemm! ((alpha number) (a real-matrix) (b real-matrix)
+ (beta cl:real) (c complex-matrix)
+ &optional (job :nn))
+ (let ((r-c (mrealpart~ c)))
+ (declare (type real-matrix c))
+ (gemm! alpha a b 0d0 r-c job))
+ c)
+
+(defmethod gemm! ((alpha number) (a real-matrix) (b real-matrix)
(beta complex) (c complex-matrix)
&optional (job :nn))
- (let ((r-c (mrealpart c))
+ (let ((r-c (mrealpart~ c))
(c-be (complex-coerce beta)))
(declare (type real-matrix c)
(type complex-double-float c-al))
@@ -266,10 +274,10 @@
(defmethod gemm! ((alpha cl:real) (a real-matrix) (b complex-matrix)
(beta cl:real) (c complex-matrix)
&optional (job :nn))
- (let ((r-b (mrealpart b))
- (i-b (mimagpart b))
- (r-c (mrealpart c))
- (i-c (mimagpart c))
+ (let ((r-b (mrealpart~ b))
+ (i-b (mimagpart~ b))
+ (r-c (mrealpart~ c))
+ (i-c (mimagpart~ 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)
@@ -280,10 +288,10 @@
(defmethod gemm! ((alpha complex) (a real-matrix) (b complex-matrix)
(beta cl:real) (c complex-matrix)
&optional (job :nn))
- (let ((r-b (mrealpart b))
- (i-b (mimagpart b))
- (r-c (mrealpart c))
- (i-c (mimagpart c))
+ (let ((r-b (mrealpart~ b))
+ (i-b (mimagpart~ b))
+ (r-c (mrealpart~ c))
+ (i-c (mimagpart~ c))
(r-al (coerce (realpart alpha) 'double-float))
(i-al (coerce (imagpart alpha) 'double-float))
(r-be (coerce beta 'double-float)))
@@ -306,10 +314,10 @@
(defmethod gemm! ((alpha cl:real) (a complex-matrix) (b real-matrix)
(beta cl:real) (c complex-matrix)
&optional (job :nn))
- (let ((r-a (mrealpart a))
- (i-a (mimagpart a))
- (r-c (mrealpart c))
- (i-c (mimagpart c))
+ (let ((r-a (mrealpart~ a))
+ (i-a (mimagpart~ a))
+ (r-c (mrealpart~ c))
+ (i-c (mimagpart~ 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)
@@ -320,10 +328,10 @@
(defmethod gemm! ((alpha complex) (a complex-matrix) (b real-matrix)
(beta cl:real) (c complex-matrix)
&optional (job :nn))
- (let ((r-a (mrealpart a))
- (i-a (mimagpart a))
- (r-c (mrealpart c))
- (i-c (mimagpart c))
+ (let ((r-a (mrealpart~ a))
+ (i-a (mimagpart~ a))
+ (r-c (mrealpart~ c))
+ (i-c (mimagpart~ c))
(r-al (coerce (realpart alpha) 'double-float))
(i-al (coerce (imagpart alpha) 'double-float))
(r-be (coerce beta 'double-float)))
diff --git a/src/gemv.lisp b/src/gemv.lisp
index dbe8ce8..4ce561b 100644
--- a/src/gemv.lisp
+++ b/src/gemv.lisp
@@ -115,7 +115,7 @@
;
(defmethod gemv! ((alpha cl:real) (A real-matrix) (x real-matrix)
(beta complex) (y complex-matrix) &optional (job :n))
- (let ((r-y (mrealpart y)))
+ (let ((r-y (mrealpart~ y)))
(declare (type real-matrix r-y))
;; y <- \beta * y
(scal! (complex-coerce beta) y)
@@ -133,12 +133,12 @@
(beta cl:real) (y complex-matrix) &optional (job :n))
(let ((r-be (coerce beta 'double-float))
(r-al (coerce alpha 'double-float))
- (r-y (mrealpart y)))
+ (r-y (mrealpart~ y)))
(declare (type double-float r-be r-al)
(type real-matrix r-y))
;; y <- \beta * y
(scal! r-be y)
- ;; (mrealpart y) <- (mrealpart y) + \alpha * A o x
+ ;; (mrealpart~ y) <- (mrealpart~ y) + \alpha * A o x
(real-double-gemv!-typed r-al A x 1d0 r-y job))
y)
@@ -147,13 +147,13 @@
(let ((r-al (coerce (realpart alpha) 'double-float))
(i-al (coerce (imagpart alpha) 'double-float))
(r-be (coerce beta 'double-float))
- (r-y (mrealpart y))
- (i-y (mimagpart y)))
+ (r-y (mrealpart~ y))
+ (i-y (mimagpart~ y)))
(declare (type double-float r-al i-al r-be)
(type real-matrix r-y i-y))
- ;; (mrealpart y) <- \beta * (mrealpart y) + (realpart \alpha) . A o x
+ ;; (mrealpart~ y) <- \beta * (mrealpart~ y) + (realpart \alpha) . A o x
(real-double-gemv!-typed r-al A x r-be r-y job)
- ;; (mimagpart y) <- \beta * (mimagpart y) + (imagpart \alpha) . A o x
+ ;; (mimagpart~ y) <- \beta * (mimagpart~ y) + (imagpart \alpha) . A o x
(real-double-gemv!-typed i-al A x r-be i-y job))
y)
@@ -167,26 +167,26 @@
(defmethod gemv! ((alpha cl:real) (A real-matrix) (x complex-matrix)
(beta cl:real) (y complex-matrix) &optional (job :n))
- (let ((r-x (mrealpart x))
- (i-x (mimagpart x))
- (r-y (mrealpart y))
- (i-y (mimagpart y))
+ (let ((r-x (mrealpart~ x))
+ (i-x (mimagpart~ x))
+ (r-y (mrealpart~ y))
+ (i-y (mimagpart~ y))
(r-al (coerce (realpart alpha) 'double-float))
(r-be (coerce beta 'double-float)))
(declare (type double-float r-al r-be)
(type real-matrix r-x i-x r-y i-y))
- ;; (mrealpart y) <- \beta * (mrealpart y) + \alpha . A o (mrealpart x)
+ ;; (mrealpart~ y) <- \beta * (mrealpart~ y) + \alpha . A o (mrealpart~ x)
(real-double-gemv!-typed r-al A r-x r-be r-y job)
- ;; (mimagpart y) <- \beta * (mimagpart y) + \alpha . A o (mrealpart x)
+ ;; (mimagpart~ y) <- \beta * (mimagpart~ y) + \alpha . A o (mrealpart~ x)
(real-double-gemv!-typed r-al A i-x r-be i-y job))
y)
(defmethod gemv! ((alpha complex) (A real-matrix) (x complex-matrix)
(beta cl:real) (y complex-matrix) &optional (job :n))
- (let ((r-x (mrealpart x))
- (i-x (mimagpart x))
- (r-y (mrealpart y))
- (i-y (mimagpart y))
+ (let ((r-x (mrealpart~ x))
+ (i-x (mimagpart~ x))
+ (r-y (mrealpart~ y))
+ (i-y (mimagpart~ y))
(r-al (coerce (realpart alpha) 'double-float))
(i-al (coerce (imagpart alpha) 'double-float))
(r-be (coerce beta 'double-float)))
@@ -209,26 +209,26 @@
(defmethod gemv! ((alpha cl:real) (A complex-matrix) (x real-matrix)
(beta cl:real) (y complex-matrix) &optional (job :n))
- (let ((r-A (mrealpart A))
- (i-A (mimagpart A))
- (r-y (mrealpart y))
- (i-y (mimagpart y))
+ (let ((r-A (mrealpart~ A))
+ (i-A (mimagpart~ A))
+ (r-y (mrealpart~ y))
+ (i-y (mimagpart~ y))
(r-al (coerce (realpart alpha) 'double-float))
(r-be (coerce beta 'double-float)))
(declare (type double-float r-al r-be)
(type real-matrix r-A i-A r-y i-y))
- ;; (mrealpart y) <- \beta * (mrealpart y) + \alpha . A o (mrealpart x)
+ ;; (mrealpart~ y) <- \beta * (mrealpart~ y) + \alpha . A o (mrealpart~ x)
(real-double-gemv!-typed r-al r-A x r-be r-y job)
- ;; (mimagpart y) <- \beta * (mimagpart y) + \alpha . A o (mrealpart x)
+ ;; (mimagpart~ y) <- \beta * (mimagpart~ y) + \alpha . A o (mrealpart~ x)
(real-double-gemv!-typed r-al i-A x r-be i-y job))
y)
(defmethod gemv! ((alpha complex) (A complex-matrix) (x real-matrix)
(beta cl:real) (y complex-matrix) &optional (job :n))
- (let ((r-A (mrealpart A))
- (i-A (mimagpart A))
- (r-y (mrealpart y))
- (i-y (mimagpart y))
+ (let ((r-A (mrealpart~ A))
+ (i-A (mimagpart~ A))
+ (r-y (mrealpart~ y))
+ (i-y (mimagpart~ y))
(r-al (coerce (realpart alpha) 'double-float))
(i-al (coerce (imagpart alpha) 'double-float))
(r-be (coerce beta 'double-float)))
diff --git a/src/norm.lisp b/src/norm.lisp
index 7087dbe..8298da4 100644
--- a/src/norm.lisp
+++ b/src/norm.lisp
@@ -158,7 +158,7 @@
(declare (type fixnum j))
(setq nrm (max nrm
(with-vector-data-addresses ((addr-store store))
- (incf-sap :double-float addr-store (* j n))
+ (incf-sap addr-store :double-float (* j n))
(dasum n addr-store 1)))))
nrm))
((2 :2) (multiple-value-bind (up sigma vp status)
@@ -173,7 +173,7 @@
(declare (type fixnum i))
(setq nrm (max nrm
(with-vector-data-addresses ((addr-store store))
- (incf-sap :double-float addr-store i)
+ (incf-sap addr-store :double-float i)
(dasum m addr-store n)))))
nrm))
((:f :fro :frob :frobenius)
@@ -181,7 +181,7 @@
(dotimes (j m)
(declare (type fixnum j))
(incf nrm (with-vector-data-addresses ((addr-store store))
- (incf-sap :double-float addr-store (* j n))
+ (incf-sap addr-store :double-float (* j n))
(ddot m addr-store 1 addr-store 1))))
(sqrt nrm)))
(t (error "don't know how to take a ~a-norm of a matrix" p))
@@ -228,7 +228,7 @@
(declare (type fixnum j))
(setq nrm (max nrm
(with-vector-data-addresses ((addr-store store))
- (incf-sap :complex-double-float addr-store (* j n))
+ (incf-sap addr-store :complex-double-float (* j n))
(dzasum n addr-store 1)))))
nrm))
((2 :2) (multiple-value-bind (up sigma vp status)
@@ -243,7 +243,7 @@
(declare (type fixnum i))
(setq nrm (max nrm
(with-vector-data-addresses ((addr-store store))
- (incf-sap :complex-double-float addr-store i)
+ (incf-sap addr-store :complex-double-float i)
(dzasum m addr-store n)))))
nrm))
((:f :fro :frob :frobenius)
@@ -251,7 +251,7 @@
(dotimes (j m)
(declare (type fixnum j))
(incf nrm (with-vector-data-addresses ((addr-store store))
- (incf-sap :double-float addr-store (* j n))
+ (incf-sap addr-store :double-float (* j n))
(realpart (zdotc m addr-store 1 addr-store 1)))))
(sqrt nrm)))
(t (error "don't know how to take a ~a-norm of a matrix" p))
diff --git a/src/realimag.lisp b/src/realimag.lisp
index 2b35319..7f59e78 100644
--- a/src/realimag.lisp
+++ b/src/realimag.lisp
@@ -66,12 +66,111 @@
(in-package "MATLISP")
-#+nil (export '(real
- imag))
+(defun mrealpart~ (mat)
+"
+ Syntax
+ ======
+ (MREALPART~ matrix)
+
+ Purpose
+ =======
+ Returns a new SUB-REAL-MATRIX which is the real part of \"matrix\".
+
+ Store is shared with \"matrix\".
+
+ If \"matrix\" is a scalar, returns its real part.
+
+ See IMAG, REALPART, IMAGPART
+"
+
+ (typecase mat
+ (real-matrix mat)
+ (complex-matrix (make-instance 'sub-real-matrix
+ :parent mat :store (store mat)
+ :nrows (nrows mat) :ncols (ncols mat)
+ :row-stride (* 2 (row-stride mat)) :col-stride (* 2 (col-stride mat))
+ :head (* 2 (head mat))))
+ (number (cl:realpart mat))))
+
+(defun mrealpart (mat)
+"
+ Syntax
+ ======
+ (MREALPART matrix)
+
+ Purpose
+ =======
+ Returns a copy of the real part of \"matrix\".
+
+ If \"matrix\" is a scalar, returns its real part.
+
+ See IMAG, REALPART, IMAGPART
+"
+ (typecase mat
+ (real-matrix (copy mat))
+ (complex-matrix (copy (make-instance 'sub-real-matrix
+ :parent mat :store (store mat)
+ :nrows (nrows mat) :ncols (ncols mat)
+ :row-stride (* 2 (row-stride mat)) :col-stride (* 2 (col-stride mat))
+ :head (* 2 (head mat)))))
+ (number (cl:realpart mat))))
+
+(defun mimagpart~ (mat)
+"
+ Syntax
+ ======
+ (MIMAGPART~ matrix)
+
+ Purpose
+ =======
+ Returns a new SUB-REAL-MATRIX which is the imaginary part of \"matrix\".
-(defgeneric real (matrix)
- (:documentation
- "
+ Store is shared with \"matrix\".
+
+ If \"matrix\" is a real-matrix, returns nil.
+
+ If \"matrix\" is a scalar, returns its imaginary part.
+
+ See IMAG, REALPART, IMAGPART
+"
+ (typecase mat
+ (real-matrix nil)
+ (complex-matrix (make-instance 'sub-real-matrix
+ :parent mat :store (store mat)
+ :nrows (nrows mat) :ncols (ncols mat)
+ :row-stride (* 2 (row-stride mat)) :col-stride (* 2 (col-stride mat))
+ :head (+ 1 (* 2 (head mat)))))
+ (number (cl:imagpart mat))))
+
+
+(defun mimagpart (mat)
+"
+ Syntax
+ ======
+ (MIMAGPART~ matrix)
+
+ Purpose
+ =======
+ Returns a copy of the imaginary part of \"matrix\".
+
+ If \"matrix\" is a scalar, returns its imaginary part.
+
+ See IMAG, REALPART, IMAGPART
+"
+
+ (typecase mat
+ (real-matrix (make-real-matrix-dim (nrows mat) (ncols mat)))
+ (complex-matrix (copy (make-instance 'sub-real-matrix
+ :parent mat :store (store mat)
+ :nrows (nrows mat) :ncols (ncols mat)
+ :row-stride (* 2 (row-stride mat)) :col-stride (* 2 (col-stride mat))
+ :head (+ 1 (* 2 (head mat))))))
+ (number (cl:imagpart mat))))
+
+
+(declaim (inline real))
+(defun real (matrix)
+"
Syntax
======
(REAL matrix)
@@ -82,11 +181,12 @@
If MATRIX is a scalar, returns its real part.
See IMAG, REALPART, IMAGPART
-"))
+"
+ (mrealpart matrix))
+
-(defgeneric imag (matrix)
- (:documentation
- "
+(defun imag (matrix)
+"
Syntax
======
(IMAG matrix)
@@ -97,71 +197,5 @@
If MATRIX is a scalar, returns its imaginary part.
See REAL, REALPART, IMAGPART
-"))
-
-(defmethod real ((x number))
- (realpart x))
-
-(defmethod real ((mat real-matrix))
- (copy mat))
-
-(defmethod real ((mat complex-matrix))
- (let* ((n (nrows mat))
- (m (ncols mat))
- (nxm (number-of-elements mat))
- (store (store mat))
- (new-store (allocate-real-store nxm)))
- (declare (type fixnum n m nxm)
- (type (complex-matrix-store-type *) store)
- (type (real-matrix-store-type *) new-store))
-
- (dcopy nxm store 2 new-store 1)
-
- (make-instance 'real-matrix :nrows n :ncols m :store new-store)))
-
-(defmethod real ((mat standard-matrix))
- (error "don't know how to take the real part of a STANDARD-MATRIX,
-its element types are unknown"))
-
-(defmethod imag ((x number))
- (imagpart x))
-
-(defmethod imag ((mat real-matrix))
- (let ((n (nrows mat))
- (m (ncols mat)))
- (declare (type fixnum n m))
- (make-real-matrix-dim n m)))
-
-;;#+(or :cmu :sbcl)
-(defmethod imag ((mat complex-matrix))
- (let* ((n (nrows mat))
- (m (ncols mat))
- (nxm (number-of-elements mat))
- (store (store mat))
- (new-store (allocate-real-store nxm)))
- (declare (type fixnum n m nxm)
- (type (complex-matrix-store-type *) store)
- (type (real-matrix-store-type *) new-store))
-
- (with-vector-data-addresses ((addr-store store)
- (addr-new-store new-store))
- (incf-sap :double-float addr-store)
- (dcopy nxm addr-store 2 addr-new-store 1))
-
- (make-instance 'real-matrix :nrows n :ncols m :store new-store)))
-
-
-;;#+:allegro
-#+nil
-(defmethod imag ((mat complex-matrix))
- (let* ((n (nrows mat))
- (m (ncols mat))
- (nxm (number-of-elements mat))
- (imag (make-real-matrix-dim n m)))
- (declare (type fixnum n m nxm))
-
- (dotimes (i nxm)
- (declare (type fixnum i))
- (setf (matrix-ref imag i) (imagpart (matrix-ref mat i))))
-
- imag))
+"
+ (mimagpart matrix))
\ No newline at end of file
diff --git a/src/standard-matrix.lisp b/src/standard-matrix.lisp
index c1ef52e..4e0deab 100644
--- a/src/standard-matrix.lisp
+++ b/src/standard-matrix.lisp
@@ -292,175 +292,4 @@ matrix and a number"))
(defmethod make-load-form ((matrix standard-matrix) &optional env)
"MAKE-LOAD-FORM allows us to determine a load time value for
matrices, for example #.(make-matrix ...)"
- (make-load-form-saving-slots matrix :environment env))
-
-;;
-#+nil(defmethod print-object ((matrix standard-matrix) stream)
- (dotimes (i (nrows matrix))
- (dotimes (j (ncols matrix))
- (format stream "~A " (matrix-ref-2d matrix i j)))
- (format stream "~%")))
-
-;;
-(defun transpose! (matrix)
-"
- Syntax
- ======
- (transpose! matrix)
-
- Purpose
- =======
- Exchange row and column strides so that effectively
- the matrix is destructively transposed in place
- (without much effort).
-"
- (cond
- ((typep matrix 'standard-matrix)
- (progn
- (rotatef (nrows matrix) (ncols matrix))
- (rotatef (row-stride matrix) (col-stride matrix))
- matrix))
- ((typep matrix 'number) matrix)
- (t (error "Don't know how to take the transpose of ~A." matrix))))
-
-(defmacro with-transpose! (matlst &rest body)
- `(progn
- ,@(mapcar #'(lambda (mat) `(transpose! ,mat)) matlst)
- ,@body
- ,@(mapcar #'(lambda (mat) `(transpose! ,mat)) matlst)))
-
-;;
-(defgeneric transpose (matrix)
- (:documentation
-"
- Syntax
- ======
- (transpose matrix)
-
- Purpose
- =======
- Create a new matrix object which represents the transpose of the
- the given matrix.
-
- Store is shared with \"matrix\".
-
- Settable
- ========
- (setf (transpose matrix) value)
-
- is basically the same as
-
- (copy! value (transpose matrix))
-"))
-
-(defun (setf transpose) (value matrix)
- (copy! value (transpose matrix)))
-
-(defmethod transpose ((matrix number))
- matrix)
-
-;;
-(defgeneric sub-matrix (matrix origin dim)
- (:documentation
-"
- Syntax
- ======
- (sub-matrix matrix origin dimensions)
-
- Purpose
- =======
- Create a block sub-matrix of \"matrix\" starting at \"origin\"
- of dimension \"dim\", sharing the store.
-
- origin, dim are lists with two elements.
-
- Store is shared with \"matrix\"
-
- Settable
- ========
- (setf (sub-matrix matrix origin dim) value)
-
- is basically the same as
-
- (copy! value (sub-matrix matrix origin dim))
-"))
-
-(defun (setf sub-matrix) (value matrix origin dim)
- (copy! value (sub-matrix matrix origin dim)))
-
-;;
-(defgeneric row (matrix i)
- (:documentation
-"
- Syntax
- ======
- (row matrix i)
-
- Purpose
- =======
- Returns the i'th row of the matrix.
- Store is shared with \"matrix\".
-
- Settable
- ========
- (setf (row matrix i) value)
-
- is basically the same as
-
- (copy! value (row matrix i))
-"))
-
-(defun (setf row) (value matrix i)
- (copy! value (row matrix i)))
-
-;;
-(defgeneric col (matrix j)
- (:documentation
-"
- Syntax
- ======
- (col matrix j)
-
- Purpose
- =======
- Returns the j'th column of the matrix.
- Store is shared with \"matrix\".
-
- Settable
- ========
- (setf (col matrix j) value)
-
- is basically the same as
-
- (copy! value (col matrix j))
-"))
-
-(defun (setf col) (value matrix j)
- (copy! value (col matrix j)))
-
-;;
-(defgeneric diag (matrix &optional d)
- (:documentation
-"
- Syntax
- ======
- (diag matrix &optional (d 0))
-
- Purpose
- =======
- Returns a row-vector representing the d'th diagonal of the matrix.
- [a_{ij} : j - i = d]
-
- Store is shared with \"matrix\".
-
- Settable
- ========
- (setf (diag matrix d) value)
-
- is basically the same as
-
- (copy! value (diag matrix d))
-"))
-
-(defun (setf diag) (value matrix &optional (d 0))
- (copy! value (diag matrix d)))
\ No newline at end of file
+ (make-load-form-saving-slots matrix :environment env))
\ No newline at end of file
diff --git a/src/standard-matrix.lisp b/src/tensor.lisp
similarity index 75%
copy from src/standard-matrix.lisp
copy to src/tensor.lisp
index c1ef52e..5d3819f 100644
--- a/src/standard-matrix.lisp
+++ b/src/tensor.lisp
@@ -1,5 +1,5 @@
;; Definitions of STANDARD-MATRIX
-(in-package :matlisp)
+;;(in-package :matlisp)
;;
(declaim (inline allocate-integer4-store))
@@ -7,6 +7,11 @@
(eval-when (load eval compile)
(deftype integer4-matrix-element-type ()
'(signed-byte 32))
+
+ (deftype index-type ()
+ 'fixnum)
+ (deftype index-array-type (size)
+ '(simple-array index-type (,size)))
)
(defun allocate-integer4-store (size &optional (initial-element 0))
@@ -17,106 +22,50 @@ integer storage. Default INITIAL-ELEMENT = 0."
:initial-element initial-element))
;;
-(declaim (inline store-indexing))
-(defun store-indexing (row col head row-stride col-stride)
- (declare (type (and fixnum (integer 0)) row col head row-stride col-stride))
- (the fixnum (+ head (the fixnum (* row row-stride)) (the fixnum (* col col-stride)))))
-
-(defun blas-copyable-p (matrix)
- (declare (optimize (safety 0) (speed 3))
- (type (or real-matrix complex-matrix) matrix))
- (mlet* ((nr (nrows matrix) :type fixnum)
- (nc (ncols matrix) :type fixnum)
- (rs (row-stride matrix) :type fixnum)
- (cs (col-stride matrix) :type fixnum)
- (ne (number-of-elements matrix) :type fixnum))
- (cond
- ((or (= nc 1) (= cs (* nr rs))) (values t rs ne))
- ((or (= nr 1) (= rs (* nc cs))) (values t cs ne))
- (t (values nil -1 -1)))))
-
-(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 (fortran-nop op)))
- ((= rs 1) (values :col-major cs (fortran-op op)))
- ;;Lets not confound lisp's type declaration.
- (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")))
-
-(defun fortran-snop (sop)
- (cond
- ((string= sop "N") "T")
- ((string= sop "T") "N")
- (t (error "Unrecognised fortran-op."))))
-
-;;
-(defclass standard-matrix ()
- ((number-of-rows
- :initarg :nrows
- :initform 0
- :accessor nrows
- :type fixnum
- :documentation "Number of rows in the matrix")
- (number-of-cols
- :initarg :ncols
- :initform 0
- :accessor ncols
- :type fixnum
- :documentation "Number of columns in the matrix")
+(defclass standard-tensor ()
+ ((rank
+ :accessor rank
+ :type index-type
+ :documentation "Rank of the matrix: number of arguments for the tensor")
+ (dimensions
+ :accessor dimensions
+ :initarg :dimensions
+ :type (index-array-type *)
+ :documentation "Dimensions of the vector spaces in which the tensor's arguments reside.")
(number-of-elements
- :initform 0
:accessor number-of-elements
:type fixnum
- :documentation "Total number of elements in the matrix (nrows * ncols)")
+ :documentation "Total number of elements in the tensor.")
;;
(head
:initarg :head
:initform 0
:accessor head
- :type fixnum
+ :type index-type
:documentation "Head for the store's accessor.")
- (row-stride
- :initarg :row-stride
- :accessor row-stride
- :type fixnum
- :documentation "Row stride for the store's accessor.")
- (col-stride
- :initarg :col-stride
- :accessor col-stride
- :type fixnum
- :documentation "Column stride for the store's accessor.")
+ (strides
+ :initarg :strides
+ :accessor strides
+ :type (index-array-type *)
+ :documentation "Strides for accesing elements of the tensor.")
(store-size
:accessor stor...
[truncated message content] |
|
From: Akshay S. <ak...@us...> - 2012-03-20 18:35: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 9bfeec0a8b2e5604b2ce6b7ad6be62c3fd3f09c4 (commit)
from fd41f88aefad9d87a8c9183f946ac14c3b564de8 (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 9bfeec0a8b2e5604b2ce6b7ad6be62c3fd3f09c4
Author: Akshay Srinivasan <aks...@gm...>
Date: Wed Mar 21 00:02:07 2012 +0530
-> Added classes for handling sub-matrices
diff --git a/matlisp.asd b/matlisp.asd
index 7898782..4a84895 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -145,7 +145,6 @@
"matlisp-lapack-wrappers")
:components ((:file "compat")
(:file "help")
- (:file "diag")
(:file "special")
(:file "reader")
(:file "trans")
diff --git a/packages.lisp b/packages.lisp
index 7b53ddc..e4fe2da 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -295,41 +295,44 @@
(defpackage :matlisp
(:use :common-lisp :fortran-ffi-accessors :blas :lapack :dfftpack :quadpack :matlisp-lib :utilities)
- (:shadow "REAL")
- (:export
- "*PRINT-MATRIX*"
- "AXPY!"
- "AXPY"
- "BLAS-COPYABLE-P"
- "COL-VECTOR-P"
- "COMPLEX-COERCE"
- "COMPLEX-MATRIX"
- "COMPLEX-MATRIX-ARRAY-TYPE"
- "COMPLEX-MATRIX-ELEMENT-TYPE"
- "COMPLEX-MATRIX-STORE-TYPE"
- "COPY!"
- "COPY"
- "CONVERT-TO-LISP-ARRAY"
- "CTRANSPOSE"
- "DIAG"
+ (:shadow #:real)
+ (:export #:*print-matrix*
+ ;;Level 1 BLAS
+ #:axpy! #:axpy
+ #:copy! #:copy
+ #:scal! #:scal
+ ;;Level 2 BLAS
+ #:gemv! #:gemv
+ ;;Level 3 BLAS
+ #:gemm! #:gemm
+ ;;Fortran stuff
+ #:blas-copyable-p #:blas-matrix-compatible-p
+ #:fortran-op #:fortran-nop #:fortran-snop
+ ;;Standard-matrix
+ #:standard-matrix
+ #:nrows #:ncols #:number-of-elements
+ #:head #:row-stride #:col-stride
+ #:store #:store-size
+ ;;Generic functions on standard-matrix
+ #:fill-matrix
+ #:ctranspose! #:ctranspose #:transpose #:transpose!
+ #:row-or-col-vector-p #:row-vector-p #:col-vector-p
+ #:row #:col #:diag #:sub-matrix
+ ;;Real-double-matrix
+ #:real-matrix #:real-matrix-element-type #:real-matrix-store-type
+ ;;Complex-double-matrix
+ #:complex-matrix #:complex-matrix-element-type #:complex-matrix-store-type #:complex-coerce #:complex-double-float
+ #:mrealpart #:mimagpart
+ ;;
+ "CONVERT-TO-LISP-ARRAY"
"DOT"
"EIG"
"EYE"
"FFT"
"FFT"
- "FILL-MATRIX"
- "FLOAT-MATRIX"
- "FLOAT-MATRIX-ARRAY-TYPE"
- "FLOAT-MATRIX-ELEMENT-TYPE"
- "FORTRAN-COMPLEX-MATRIX-INDEXING"
- "FORTRAN-MATRIX-INDEXING"
"GEEV"
"GELSY!"
"GELSY"
- #:gemv!
- #:gemv
- "GEMM!"
- "GEMM"
"GESV!"
"GESV"
"GETRF!"
@@ -337,7 +340,6 @@
"GETRS!"
"HELP"
"IFFT"
- "IMAG"
"JOIN"
"LOAD-BLAS-&-LAPACK-BINARIES"
"LOAD-BLAS-&-LAPACK-LIBRARIES"
@@ -375,8 +377,6 @@
"MASINH"
"MATAN"
"MATANH"
- "MATLISP-HERALD"
- "MATLISP-VERSION"
"MATRIX-REF"
"MCOS"
"MCOSH"
@@ -391,11 +391,6 @@
"MTANH"
"NCOLS"
"NORM"
- "NROWS"
- "NUMBER-OF-COLS"
- "NUMBER-OF-ELEMENTS"
- "NUMBER-OF-ELEMS"
- "NUMBER-OF-ROWS"
"ONES"
"PRINT-ELEMENT"
"QR"
@@ -405,28 +400,18 @@
"POTRS!"
"RAND"
"REAL"
- "REAL-MATRIX"
- "REAL-MATRIX-ELEMENT-TYPE"
- "REAL-MATRIX-STORE-TYPE"
"RESHAPE!"
"RESHAPE"
- "ROW-OR-COL-VECTOR-P"
- "ROW-VECTOR-P"
"SAVE-MATLISP"
- "SCAL!"
- "SCAL"
"SEQ"
"SET-M*!-SWAP-SIZE"
"SIZE"
"SQUARE-MATRIX-P"
- "STANDARD-MATRIX"
+ "STORE-INDEXING"
"SUM"
"SVD"
"SWAP!"
"TR"
- "TRANSPOSE"
- "TRANSPOSE!"
- "VEC"
"UNLOAD-BLAS-&-LAPACK-LIBRARIES"
"ZEROS"
;; From Quadpack
diff --git a/src/axpy.lisp b/src/axpy.lisp
index 69a7005..662cfd6 100644
--- a/src/axpy.lisp
+++ b/src/axpy.lisp
@@ -134,11 +134,11 @@ don't know how to coerce COMPLEX to REAL"))
(generate-typed-axpy!-func complex-double-axpy!-typed complex-double-float complex-matrix-store-type complex-matrix blas:zaxpy)
(defmethod axpy! ((alpha cl:real) (x real-matrix) (y complex-matrix))
- (real-double-axpy!-typed (coerce alpha 'double-float) x (realpart! y)))
+ (real-double-axpy!-typed (coerce alpha 'double-float) x (mrealpart y)))
(defmethod axpy! ((alpha complex) (x real-matrix) (y complex-matrix))
- (real-double-axpy!-typed (coerce (realpart alpha) 'double-float) x (realpart! y))
- (real-double-axpy!-typed (coerce (imagpart alpha) 'double-float) x (imagpart! y)))
+ (real-double-axpy!-typed (coerce (realpart alpha) 'double-float) x (mrealpart y))
+ (real-double-axpy!-typed (coerce (imagpart alpha) 'double-float) x (mimagpart y)))
(defmethod axpy! ((alpha number) (x complex-matrix) (y complex-matrix))
(complex-double-axpy!-typed (complex-coerce alpha) x y))
diff --git a/src/blas.lisp b/src/blas.lisp
index e7f76d9..1e34345 100644
--- a/src/blas.lisp
+++ b/src/blas.lisp
@@ -56,23 +56,9 @@
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-#+nil
-(defpackage "BLAS"
-#+:cmu (:use "COMMON-LISP" "ALIEN" "C-CALL" "FORTRAN-FFI-ACCESSORS")
-#+:sbcl (:use "COMMON-LISP" "SB-ALIEN" "SB-C" "FORTRAN-FFI-ACCESSORS")
-#+:allegro (:use "COMMON-LISP" "FOREIGN-FUNCTIONS" "FORTRAN-FFI-ACCESSORS")
- (:export
-"IDAMAX" "DASUM" "DDOT" "DNRM2"
-"DROT" "DSCAL" "DSWAP" "DCOPY" "DAXPY"
-"DCABS1" "DZASUM" "DZNRM2" "IZAMAX"
-"ZDSCAL" "ZSCAL" "ZSWAP" "ZCOPY" "ZAXPY" "ZDOTC" "ZDOTU"
-"DGEMV" "DSYMV" "DTRMV" "DTRSV" "DGER" "DSYR" "DSYR2"
-"ZGEMV" "ZHEMV" "ZTRMV" "ZTRSV" "ZGERC" "ZGERU" "ZHER2"
-"DGEMM" "DSYRK" "DSYR2K" "DTRMM" "DTRSM"
-"ZGEMM" "ZTRMM" "ZTRSM" "ZHERK" "ZHER2K" ))
-
(in-package "BLAS")
+;;
(def-fortran-routine daxpy :void
"
Syntax
diff --git a/src/complex-matrix.lisp b/src/complex-matrix.lisp
index 704f823..3ad8280 100644
--- a/src/complex-matrix.lisp
+++ b/src/complex-matrix.lisp
@@ -43,18 +43,18 @@
:type (complex-matrix-store-type *)))
(:documentation "A class of matrices with complex elements."))
+(defclass sub-complex-matrix (complex-matrix)
+ ((parent-matrix
+ :initarg :parent
+ :accessor parent
+ :type complex-matrix))
+ (:documentation "A class of matrices with complex elements."))
+
;;
(defmethod initialize-instance ((matrix complex-matrix) &rest initargs)
- (setf (store-size matrix) (length (get-arg :store initargs)))
+ (setf (store-size matrix) (/ (length (get-arg :store initargs)) 2))
(call-next-method))
-(defmethod initialize-instance :after ((matrix complex-matrix) &rest initargs)
- (declare (ignore initargs))
- (let ((ss (store-size matrix)))
- (declare (type fixnum ss))
- (unless (>= ss (* 2 (number-of-elements matrix)))
- (error "Store is not large enough to hold the matrix."))))
-
;;
(defmethod matrix-ref-1d ((matrix complex-matrix) (idx fixnum))
(let ((store (store matrix)))
@@ -69,6 +69,75 @@
(aref store (+ 1 (* 2 idx))) (imagpart coerced-value))))
;;
+(defmethod transpose ((matrix complex-matrix))
+ (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
+ :type (fixnum fixnum fixnum fixnum fixnum (complex-matrix-store-type *))))
+ (make-instance 'sub-complex-matrix
+ :nrows nc :ncols nr
+ :store st
+ :head hd
+ :row-stride cs :col-stride rs
+ :parent matrix)))
+
+;;
+(defmethod sub-matrix ((matrix complex-matrix) (origin list) (dim list))
+ (destructuring-bind (o-i o-j) origin
+ (destructuring-bind (nr-s nc-s) dim
+ (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
+ :type (fixnum fixnum fixnum fixnum fixnum (complex-matrix-store-type *))))
+ (unless (and (< -1 o-i (+ o-j nr-s) nr) (< -1 o-j (+ o-j nc-s) nc))
+ (error "Bad index and/or size.
+Cannot create a sub-matrix of size (~a ~a) starting at (~a ~a)" nr-s nc-s o-i o-j))
+ (make-instance 'sub-complex-matrix
+ :nrows nr-s :ncols nc-s
+ :store st
+ :head (store-indexing o-i o-j hd rs cs)
+ :row-stride rs :col-stride cs)))))
+
+;;
+(defmethod row ((matrix complex-matrix) (i fixnum))
+ (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
+ :type (fixnum fixnum fixnum fixnum fixnum (complex-matrix-store-type *))))
+ (unless (< -1 i nr)
+ (error "Index ~a is outside the valid range for the given matrix." i))
+ (make-instance 'sub-complex-matrix
+ :nrows 1 :ncols nc
+ :store st
+ :head (store-indexing i 0 hd rs cs)
+ :row-stride rs :col-stride cs)))
+
+;;
+(defmethod col ((matrix complex-matrix) (j fixnum))
+ (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
+ :type (fixnum fixnum fixnum fixnum fixnum (complex-matrix-store-type *))))
+ (unless (< -1 j nc)
+ (error "Index ~a is outside the valid range for the given matrix." j))
+ (make-instance 'sub-complex-matrix
+ :nrows nr :ncols 1
+ :store st
+ :head (store-indexing 0 j hd rs cs)
+ :row-stride rs :col-stride cs)))
+
+;;
+(defmethod diag ((matrix complex-matrix) &optional (d 0))
+ (declare (type fixnum d))
+ (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
+ :type (fixnum fixnum fixnum fixnum fixnum (complex-matrix-store-type *)))
+ ((f-i f-j) (if (< d 0)
+ (values (- d) 0)
+ (values 0 d))
+ :type (fixnum fixnum)))
+ (unless (and (< -1 f-i nr) (< -1 f-j nc))
+ (error "Index ~a is outside the valid range for the given matrix." d))
+ (let ((d-s (min (- nr f-i) (- nc f-j))))
+ (declare (type fixnum d-s))
+ (make-instance 'sub-complex-matrix
+ :nrows 1 :ncols d-s
+ :store st
+ :head (store-indexing f-i f-j hd rs cs)
+ :row-stride 1 :col-stride (+ rs cs)))))
+
+;;
(declaim (inline allocate-complex-store))
(defun allocate-complex-store (size)
(make-array (* 2 size) :element-type 'complex-matrix-element-type
@@ -291,32 +360,28 @@
;;
-(defun realpart! (mat)
- (cond
- ((typep mat 'real-matrix) mat)
- ((typep mat 'complex-matrix) (make-instance 'real-matrix :store (store mat)
- :nrows (nrows mat) :ncols (ncols mat)
- :row-stride (* 2 (row-stride mat)) :col-stride (* 2 (col-stride mat))
- :head (* 2 (head mat))))))
-
-(defun imagpart! (mat)
- (cond
- ((typep mat 'real-matrix) nil)
- ((typep mat 'complex-matrix) (make-instance 'real-matrix :store (store mat)
- :nrows (nrows mat) :ncols (ncols mat)
- :row-stride (* 2 (row-stride mat)) :col-stride (* 2 (col-stride mat))
- :head (+ 1 (* 2 (head mat)))))))
-
-
-(defun conjugate! (mat)
- (cond
- ((typep mat 'real-matrix) nil)
- ((typep mat 'complex-matrix) (progn
- (transpose! (scal! -1d0 (imagpart! mat)))
- mat))))
-
-(defmacro with-conjugate! (matlst &rest body)
- `(progn
- ,@(mapcar #'(lambda (mat) `(conjugate! ,mat)) matlst)
- ,@body
- ,@(mapcar #'(lambda (mat) `(conjugate! ,mat)) matlst)))
\ No newline at end of file
+(defun mrealpart (mat)
+ (typecase mat
+ (real-matrix mat)
+ (complex-matrix (make-instance 'sub-real-matrix
+ :parent mat :store (store mat)
+ :nrows (nrows mat) :ncols (ncols mat)
+ :row-stride (* 2 (row-stride mat)) :col-stride (* 2 (col-stride mat))
+ :head (* 2 (head mat))))
+ (number (cl:realpart mat))))
+
+(defun mimagpart (mat)
+ (typecase mat
+ (real-matrix nil)
+ (complex-matrix (make-instance 'sub-real-matrix
+ :parent mat :store (store mat)
+ :nrows (nrows mat) :ncols (ncols mat)
+ :row-stride (* 2 (row-stride mat)) :col-stride (* 2 (col-stride mat))
+ :head (+ 1 (* 2 (head mat)))))
+ (number (cl:imagpart mat))))
+
+(defun mconjugate! (mat)
+ (typecase mat
+ (real-matrix mat)
+ (complex-matrix (scal! -1d0 (mimagpart mat))))
+ mat)
\ No newline at end of file
diff --git a/src/copy.lisp b/src/copy.lisp
index 8ce687d..74b1ca0 100644
--- a/src/copy.lisp
+++ b/src/copy.lisp
@@ -219,8 +219,8 @@ don't know how to coerce a COMPLEX to a REAL"))
(complex-double-copy!-typed x y))
(defmethod copy! ((x real-matrix) (y complex-matrix))
- (real-double-copy!-typed x (realpart! y))
- (scal! 0d0 (imagpart! y))
+ (real-double-copy!-typed x (mrealpart y))
+ (scal! 0d0 (mimagpart y))
y)
(defmethod copy! ((x number) (y complex-matrix))
diff --git a/src/diag.lisp b/src/diag.lisp
deleted file mode 100644
index 23ee370..0000000
--- a/src/diag.lisp
+++ /dev/null
@@ -1,235 +0,0 @@
-;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: :matlisp; Base: 10 -*-
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Copyright (c) 2000 The Regents of the University of California.
-;;; All rights reserved.
-;;;
-;;; Permission is hereby granted, without written agreement and without
-;;; license or royalty fees, to use, copy, modify, and distribute this
-;;; software and its documentation for any purpose, provided that the
-;;; above copyright notice and the following two paragraphs appear in all
-;;; copies of this software.
-;;;
-;;; IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY
-;;; FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
-;;; ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF
-;;; THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF
-;;; SUCH DAMAGE.
-;;;
-;;; THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
-;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
-;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE
-;;; PROVIDED HEREUNDER IS ON AN "AS IS" BASIS, AND THE UNIVERSITY OF
-;;; CALIFORNIA HAS NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES,
-;;; ENHANCEMENTS, OR MODIFICATIONS.
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Originally written by Raymond Toy.
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; $Id: diag.lisp,v 1.8 2011/01/25 18:36:56 rtoy Exp $
-;;;
-;;; $Log: diag.lisp,v $
-;;; Revision 1.8 2011/01/25 18:36:56 rtoy
-;;; Merge changes from automake-snapshot-2011-01-25-1327 to get the new
-;;; automake build infrastructure.
-;;;
-;;; Revision 1.7.2.1 2011/01/25 18:16:53 rtoy
-;;; Use cl:real instead of real.
-;;;
-;;; Revision 1.7 2004/05/24 16:34:22 rtoy
-;;; More SBCL support from Robert Sedgewick. The previous SBCL support
-;;; was incomplete.
-;;;
-;;; Revision 1.6 2002/07/29 00:29:36 rtoy
-;;; Don't use *1x1-real-array*
-;;;
-;;; Revision 1.5 2001/10/29 16:21:02 rtoy
-;;; (setf diag) was broken on CMUCL. Use the Allegro version.
-;;; From M. Koerber.
-;;;
-;;; Revision 1.4 2000/07/11 18:02:03 simsek
-;;; o Added credits
-;;;
-;;; Revision 1.3 2000/07/11 02:11:56 simsek
-;;; o Added support for Allegro CL
-;;;
-;;; Revision 1.2 2000/05/08 17:19:18 rtoy
-;;; Changes to the STANDARD-MATRIX class:
-;;; o The slots N, M, and NXM have changed names.
-;;; o The accessors of these slots have changed:
-;;; NROWS, NCOLS, NUMBER-OF-ELEMENTS
-;;; The old names aren't available anymore.
-;;; o The initargs of these slots have changed:
-;;; :nrows, :ncols, :nels
-;;;
-;;; Revision 1.1 2000/04/14 00:11:12 simsek
-;;; o This file is adapted from obsolete files 'matrix-float.lisp'
-;;; 'matrix-complex.lisp' and 'matrix-extra.lisp'
-;;; o Initial revision.
-;;;
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(in-package "MATLISP")
-
-(defgeneric diag (matrix)
- (:documentation
- "
- Syntax
- ======
- (DIAG x)
-
- Purpose
- =======
- Given the matrix X, returns the diagonal elements of X as a
- column vector if X is a matrix. If X is a vector
- returns a new matrix whose diagonal is X.
-
- Settable
- ========
- (SETF (DIAG x) y) works as follows.
-
- If Y is a scalar then the diagonal elements of X are assigned to Y.
- If Y is a vector then the diagonal elements of X are assigned to
- the elements of Y.
- If Y is a matrix then the diagonal elements of X are assigned to
- the diagonal elements of Y.
-
- The dimensions of X,Y need not match. In this case, the maximum
- assignable elements are considered.
-
- Returns X.
-"))
-
-(defmethod diag ((mat number))
- mat)
-
-(defmethod diag ((mat real-matrix))
- (if (row-or-col-vector-p mat)
- (let* ((nxm (number-of-elements mat))
- (result (make-real-matrix-dim nxm nxm)))
- (declare (type fixnum nxm))
- (dcopy nxm (store mat) 1 (store result) (1+ nxm))
- result)
- (let* ((n (nrows mat))
- (m (ncols mat))
- (p (min m n))
- (result (make-real-matrix-dim p 1)))
- (declare (type fixnum n m p))
- (dcopy p (store mat) (1+ n) (store result) 1)
- result)))
-
-(let ((diag-element (make-array 1 :element-type 'real-matrix-element-type)))
- (defmethod (setf diag) ((new-diag #+(or cmu sbcl) double-float #-(or cmu sbcl) float) (mat real-matrix))
- (let* ((n (nrows mat))
- (m (ncols mat))
- (p (min m n)))
- (declare (type fixnum n m p))
-
- (setf (aref diag-element 0) new-diag)
- (dcopy p diag-element 0 (store mat) (1+ n))
- mat)))
-
-(defmethod (setf diag) ((new-diag cl:real) (mat real-matrix))
- (setf (diag mat) (coerce new-diag 'real-matrix-element-type)))
-
-(defmethod (setf diag) ((new-diag complex) (mat real-matrix))
- (error "cannot set the diagonal of ~a to ~a, don't know how to
-coerce COMPLEX to REAL"
- mat
- new-diag))
-
-(defmethod (setf diag) ((new-diag real-matrix) (mat real-matrix))
- (let* ((n (nrows mat))
- (m (ncols mat))
- (n-new (nrows new-diag))
- (m-new (ncols new-diag))
- (nxm-new (number-of-elements new-diag)))
- (declare (type fixnum n m n-new m-new nxm-new))
-
- (if (row-or-col-vector-p new-diag)
- (dcopy (min n m nxm-new) (store new-diag) 1 (store mat) (1+ n))
- (dcopy (min n m n-new m-new) (store new-diag) (1+ n-new) (store mat) (1+ n)))
-
- mat))
-
-(defmethod (setf diag) ((new-diag complex-matrix) (mat real-matrix))
- (error "cannot assign the COMPLEX matrix ~a to the diagonal of the REAL matrix ~a,
-don't know how to coerce COMPLEX to REAL"
- new-diag
- mat))
-
-(defmethod diag ((mat complex-matrix))
- (if (row-or-col-vector-p mat)
- (let* ((nxm (number-of-elements mat))
- (result (make-complex-matrix-dim nxm nxm)))
- (declare (type fixnum nxm))
- (zcopy nxm (store mat) 1 (store result) (1+ nxm))
- result)
- (let* ((n (nrows mat))
- (m (ncols mat))
- (p (min m n))
- (result (make-complex-matrix-dim p 1)))
-
- (declare (type fixnum n m p))
- (zcopy p (store mat) (1+ n) (store result) 1)
- result)))
-
-
-(defmethod (setf diag) ((new-diag complex-matrix) (mat complex-matrix))
- (let* ((n (nrows mat))
- (m (ncols mat))
- (n-new (nrows new-diag))
- (m-new (ncols new-diag))
- (nxm-new (number-of-elements new-diag)))
- (declare (type fixnum n m n-new m-new nxm-new))
- (if (row-or-col-vector-p new-diag)
- (zcopy (min n m nxm-new) (store new-diag) 1 (store mat) (1+ n))
- (zcopy (min n m n-new m-new) (store new-diag) (1+ n-new) (store mat) (1+ n)))
- mat))
-
-
-(defmethod (setf diag) ((new-diag real-matrix) (mat complex-matrix))
- (let* ((n (nrows mat))
- (m (ncols mat))
- (n-new (nrows new-diag))
- (m-new (ncols new-diag))
- (nxm-new (number-of-elements new-diag)))
- (declare (type fixnum n m n-new m-new nxm-new))
-
- (if (row-or-col-vector-p new-diag)
- (dotimes (i (min n m nxm-new))
- (declare (type fixnum i))
- (setf (matrix-ref mat (+ i (* n i)))
- (matrix-ref new-diag i)))
- (dotimes (i (min n m n-new m-new))
- (declare (type fixnum i))
- (setf (matrix-ref mat (+ i (* n i)))
- (matrix-ref new-diag (+ i (* n-new i))))))
-
- mat))
-
-(defmethod (setf diag) ((new-diag #+:cmu kernel::complex-double-float
- #+:sbcl sb-kernel::complex-double-float
- #-(or cmu sbcl) complex) (mat complex-matrix))
- (let* ((n (nrows mat))
- (m (ncols mat))
- (p (min n m)))
- (declare (type fixnum n m p))
-
- #-(or cmu sbcl) (setf new-diag (complex-coerce new-diag))
-
- (zcopy p new-diag 0 (store mat) (1+ n))
- mat))
-
-(defmethod (setf diag) ((new-diag number) (mat complex-matrix))
- (setf (diag mat) (complex-coerce new-diag)))
-
-
-
-
-
diff --git a/src/gemm.lisp b/src/gemm.lisp
index 419be54..e4d227c 100644
--- a/src/gemm.lisp
+++ b/src/gemm.lisp
@@ -248,7 +248,7 @@
(defmethod gemm! ((alpha number) (a real-matrix) (b real-matrix)
(beta complex) (c complex-matrix)
&optional (job :nn))
- (let ((r-c (realpart! c))
+ (let ((r-c (mrealpart c))
(c-be (complex-coerce beta)))
(declare (type real-matrix c)
(type complex-double-float c-al))
@@ -266,10 +266,10 @@
(defmethod gemm! ((alpha cl:real) (a real-matrix) (b complex-matrix)
(beta cl:real) (c complex-matrix)
&optional (job :nn))
- (let ((r-b (realpart! b))
- (i-b (imagpart! b))
- (r-c (realpart! c))
- (i-c (imagpart! c))
+ (let ((r-b (mrealpart b))
+ (i-b (mimagpart b))
+ (r-c (mrealpart c))
+ (i-c (mimagpart 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)
@@ -280,10 +280,10 @@
(defmethod gemm! ((alpha complex) (a real-matrix) (b complex-matrix)
(beta cl:real) (c complex-matrix)
&optional (job :nn))
- (let ((r-b (realpart! b))
- (i-b (imagpart! b))
- (r-c (realpart! c))
- (i-c (imagpart! c))
+ (let ((r-b (mrealpart b))
+ (i-b (mimagpart b))
+ (r-c (mrealpart c))
+ (i-c (mimagpart c))
(r-al (coerce (realpart alpha) 'double-float))
(i-al (coerce (imagpart alpha) 'double-float))
(r-be (coerce beta 'double-float)))
@@ -306,10 +306,10 @@
(defmethod gemm! ((alpha cl:real) (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))
+ (let ((r-a (mrealpart a))
+ (i-a (mimagpart a))
+ (r-c (mrealpart c))
+ (i-c (mimagpart 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)
@@ -320,10 +320,10 @@
(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))
+ (let ((r-a (mrealpart a))
+ (i-a (mimagpart a))
+ (r-c (mrealpart c))
+ (i-c (mimagpart c))
(r-al (coerce (realpart alpha) 'double-float))
(i-al (coerce (imagpart alpha) 'double-float))
(r-be (coerce beta 'double-float)))
diff --git a/src/gemv.lisp b/src/gemv.lisp
index 88da9df..dbe8ce8 100644
--- a/src/gemv.lisp
+++ b/src/gemv.lisp
@@ -115,7 +115,7 @@
;
(defmethod gemv! ((alpha cl:real) (A real-matrix) (x real-matrix)
(beta complex) (y complex-matrix) &optional (job :n))
- (let ((r-y (realpart! y)))
+ (let ((r-y (mrealpart y)))
(declare (type real-matrix r-y))
;; y <- \beta * y
(scal! (complex-coerce beta) y)
@@ -133,12 +133,12 @@
(beta cl:real) (y complex-matrix) &optional (job :n))
(let ((r-be (coerce beta 'double-float))
(r-al (coerce alpha 'double-float))
- (r-y (realpart! y)))
+ (r-y (mrealpart y)))
(declare (type double-float r-be r-al)
(type real-matrix r-y))
;; y <- \beta * y
(scal! r-be y)
- ;; (realpart! y) <- (realpart! y) + \alpha * A o x
+ ;; (mrealpart y) <- (mrealpart y) + \alpha * A o x
(real-double-gemv!-typed r-al A x 1d0 r-y job))
y)
@@ -147,13 +147,13 @@
(let ((r-al (coerce (realpart alpha) 'double-float))
(i-al (coerce (imagpart alpha) 'double-float))
(r-be (coerce beta 'double-float))
- (r-y (realpart! y))
- (i-y (imagpart! y)))
+ (r-y (mrealpart y))
+ (i-y (mimagpart y)))
(declare (type double-float r-al i-al r-be)
(type real-matrix r-y i-y))
- ;; (realpart! y) <- \beta * (realpart! y) + (realpart \alpha) . A o x
+ ;; (mrealpart y) <- \beta * (mrealpart y) + (realpart \alpha) . A o x
(real-double-gemv!-typed r-al A x r-be r-y job)
- ;; (imagpart! y) <- \beta * (imagpart! y) + (imagpart \alpha) . A o x
+ ;; (mimagpart y) <- \beta * (mimagpart y) + (imagpart \alpha) . A o x
(real-double-gemv!-typed i-al A x r-be i-y job))
y)
@@ -167,26 +167,26 @@
(defmethod gemv! ((alpha cl:real) (A real-matrix) (x complex-matrix)
(beta cl:real) (y complex-matrix) &optional (job :n))
- (let ((r-x (realpart! x))
- (i-x (imagpart! x))
- (r-y (realpart! y))
- (i-y (imagpart! y))
+ (let ((r-x (mrealpart x))
+ (i-x (mimagpart x))
+ (r-y (mrealpart y))
+ (i-y (mimagpart y))
(r-al (coerce (realpart alpha) 'double-float))
(r-be (coerce beta 'double-float)))
(declare (type double-float r-al r-be)
(type real-matrix r-x i-x r-y i-y))
- ;; (realpart! y) <- \beta * (realpart! y) + \alpha . A o (realpart! x)
+ ;; (mrealpart y) <- \beta * (mrealpart y) + \alpha . A o (mrealpart x)
(real-double-gemv!-typed r-al A r-x r-be r-y job)
- ;; (imagpart! y) <- \beta * (imagpart! y) + \alpha . A o (realpart! x)
+ ;; (mimagpart y) <- \beta * (mimagpart y) + \alpha . A o (mrealpart x)
(real-double-gemv!-typed r-al A i-x r-be i-y job))
y)
(defmethod gemv! ((alpha complex) (A real-matrix) (x complex-matrix)
(beta cl:real) (y complex-matrix) &optional (job :n))
- (let ((r-x (realpart! x))
- (i-x (imagpart! x))
- (r-y (realpart! y))
- (i-y (imagpart! y))
+ (let ((r-x (mrealpart x))
+ (i-x (mimagpart x))
+ (r-y (mrealpart y))
+ (i-y (mimagpart y))
(r-al (coerce (realpart alpha) 'double-float))
(i-al (coerce (imagpart alpha) 'double-float))
(r-be (coerce beta 'double-float)))
@@ -209,26 +209,26 @@
(defmethod gemv! ((alpha cl:real) (A complex-matrix) (x real-matrix)
(beta cl:real) (y complex-matrix) &optional (job :n))
- (let ((r-A (realpart! A))
- (i-A (imagpart! A))
- (r-y (realpart! y))
- (i-y (imagpart! y))
+ (let ((r-A (mrealpart A))
+ (i-A (mimagpart A))
+ (r-y (mrealpart y))
+ (i-y (mimagpart y))
(r-al (coerce (realpart alpha) 'double-float))
(r-be (coerce beta 'double-float)))
(declare (type double-float r-al r-be)
(type real-matrix r-A i-A r-y i-y))
- ;; (realpart! y) <- \beta * (realpart! y) + \alpha . A o (realpart! x)
+ ;; (mrealpart y) <- \beta * (mrealpart y) + \alpha . A o (mrealpart x)
(real-double-gemv!-typed r-al r-A x r-be r-y job)
- ;; (imagpart! y) <- \beta * (imagpart! y) + \alpha . A o (realpart! x)
+ ;; (mimagpart y) <- \beta * (mimagpart y) + \alpha . A o (mrealpart x)
(real-double-gemv!-typed r-al i-A x r-be i-y job))
y)
(defmethod gemv! ((alpha complex) (A complex-matrix) (x real-matrix)
(beta cl:real) (y complex-matrix) &optional (job :n))
- (let ((r-A (realpart! A))
- (i-A (imagpart! A))
- (r-y (realpart! y))
- (i-y (imagpart! y))
+ (let ((r-A (mrealpart A))
+ (i-A (mimagpart A))
+ (r-y (mrealpart y))
+ (i-y (mimagpart y))
(r-al (coerce (realpart alpha) 'double-float))
(i-al (coerce (imagpart alpha) 'double-float))
(r-be (coerce beta 'double-float)))
diff --git a/src/real-matrix.lisp b/src/real-matrix.lisp
index 7cb08a7..b6b90a2 100644
--- a/src/real-matrix.lisp
+++ b/src/real-matrix.lisp
@@ -18,18 +18,18 @@
:type (real-matrix-store-type *)))
(:documentation "A class of matrices with real elements."))
+(defclass sub-real-matrix (real-matrix)
+ ((parent-matrix
+ :initarg :parent
+ :accessor parent
+ :type real-matrix))
+ (:documentation "A class of matrices with real elements."))
+
;;
(defmethod initialize-instance ((matrix real-matrix) &rest initargs)
(setf (store-size matrix) (length (get-arg :store initargs)))
(call-next-method))
-(defmethod initialize-instance :after ((matrix real-matrix) &rest initargs)
- (declare (ignore initargs))
- (let ((ss (store-size matrix)))
- (declare (type fixnum ss))
- (unless (>= ss (number-of-elements matrix))
- (error "Store is not large enough to hold the matrix."))))
-
;;
(defmethod matrix-ref-1d ((matrix real-matrix) (idx fixnum))
(let ((store (store matrix)))
@@ -56,6 +56,75 @@
don't know how to coerce COMPLEX to REAL"))
;;
+(defmethod transpose ((matrix real-matrix))
+ (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
+ :type (fixnum fixnum fixnum fixnum fixnum (real-matrix-store-type *))))
+ (make-instance 'sub-real-matrix
+ :nrows nc :ncols nr
+ :store st
+ :head hd
+ :row-stride cs :col-stride rs
+ :parent matrix)))
+
+;;
+(defmethod sub-matrix ((matrix real-matrix) (origin list) (dim list))
+ (destructuring-bind (o-i o-j) origin
+ (destructuring-bind (nr-s nc-s) dim
+ (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
+ :type (fixnum fixnum fixnum fixnum fixnum (real-matrix-store-type *))))
+ (unless (and (< -1 o-i (+ o-j nr-s) nr) (< -1 o-j (+ o-j nc-s) nc))
+ (error "Bad index and/or size.
+Cannot create a sub-matrix of size (~a ~a) starting at (~a ~a)" nr-s nc-s o-i o-j))
+ (make-instance 'sub-real-matrix
+ :nrows nr-s :ncols nc-s
+ :store st
+ :head (store-indexing o-i o-j hd rs cs)
+ :row-stride rs :col-stride cs)))))
+
+;;
+(defmethod row ((matrix real-matrix) (i fixnum))
+ (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
+ :type (fixnum fixnum fixnum fixnum fixnum (real-matrix-store-type *))))
+ (unless (< -1 i nr)
+ (error "Index ~a is outside the valid range for the given matrix." i))
+ (make-instance 'sub-real-matrix
+ :nrows 1 :ncols nc
+ :store st
+ :head (store-indexing i 0 hd rs cs)
+ :row-stride rs :col-stride cs)))
+
+;;
+(defmethod col ((matrix real-matrix) (j fixnum))
+ (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
+ :type (fixnum fixnum fixnum fixnum fixnum (real-matrix-store-type *))))
+ (unless (< -1 j nc)
+ (error "Index ~a is outside the valid range for the given matrix." j))
+ (make-instance 'sub-real-matrix
+ :nrows nr :ncols 1
+ :store st
+ :head (store-indexing 0 j hd rs cs)
+ :row-stride rs :col-stride cs)))
+
+;;
+(defmethod diag ((matrix real-matrix) &optional (d 0))
+ (declare (type fixnum d))
+ (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
+ :type (fixnum fixnum fixnum fixnum fixnum (real-matrix-store-type *)))
+ ((f-i f-j) (if (< d 0)
+ (values (- d) 0)
+ (values 0 d))
+ :type (fixnum fixnum)))
+ (unless (and (< -1 f-i nr) (< -1 f-j nc))
+ (error "Index ~a is outside the valid range for the given matrix." d))
+ (let ((d-s (min (- nr f-i) (- nc f-j))))
+ (declare (type fixnum d-s))
+ (make-instance 'sub-real-matrix
+ :nrows 1 :ncols d-s
+ :store st
+ :head (store-indexing f-i f-j hd rs cs)
+ :row-stride 1 :col-stride (+ rs cs)))))
+
+;;
(defun make-real-matrix-dim (n m &key (fill 0.0d0) (order :row-major))
"
Syntax
@@ -252,4 +321,4 @@ don't know how to coerce COMPLEX to REAL"))
"cannot make a ~A x ~A matrix" n m)
(make-real-matrix-dim n m)))
(t
- (error "require 1 or 2 arguments to make a matrix")))))
\ No newline at end of file
+ (error "require 1 or 2 arguments to make a matrix")))))
diff --git a/src/special.lisp b/src/special.lisp
index e00193f..f53ca0c 100644
--- a/src/special.lisp
+++ b/src/special.lisp
@@ -88,8 +88,7 @@
(error "the number of rows (~d) and columns (~d) must be positive integers" n m))
(let ((result (make-real-matrix-dim n m)))
- (setf (aref *1x1-real-array* 0) 1.0d0)
- (dcopy (min n m) *1x1-real-array* 0 (store result) (1+ n))
+ (setf (diag result) 1d0)
result))
(defun zeros (n &optional (m n))
@@ -160,5 +159,4 @@
(make-instance 'real-matrix
:nrows n :ncols m
- :row-stride m :col-stride 1 :store store))))
-
+ :store store))))
\ No newline at end of file
diff --git a/src/standard-matrix.lisp b/src/standard-matrix.lisp
index 4c918b8..c1ef52e 100644
--- a/src/standard-matrix.lisp
+++ b/src/standard-matrix.lisp
@@ -22,6 +22,44 @@ integer storage. Default INITIAL-ELEMENT = 0."
(declare (type (and fixnum (integer 0)) row col head row-stride col-stride))
(the fixnum (+ head (the fixnum (* row row-stride)) (the fixnum (* col col-stride)))))
+(defun blas-copyable-p (matrix)
+ (declare (optimize (safety 0) (speed 3))
+ (type (or real-matrix complex-matrix) matrix))
+ (mlet* ((nr (nrows matrix) :type fixnum)
+ (nc (ncols matrix) :type fixnum)
+ (rs (row-stride matrix) :type fixnum)
+ (cs (col-stride matrix) :type fixnum)
+ (ne (number-of-elements matrix) :type fixnum))
+ (cond
+ ((or (= nc 1) (= cs (* nr rs))) (values t rs ne))
+ ((or (= nr 1) (= rs (* nc cs))) (values t cs ne))
+ (t (values nil -1 -1)))))
+
+(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 (fortran-nop op)))
+ ((= rs 1) (values :col-major cs (fortran-op op)))
+ ;;Lets not confound lisp's type declaration.
+ (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")))
+
+(defun fortran-snop (sop)
+ (cond
+ ((string= sop "N") "T")
+ ((string= sop "T") "N")
+ (t (error "Unrecognised fortran-op."))))
+
;;
(defclass standard-matrix ()
((number-of-rows
@@ -76,30 +114,29 @@ that way."))
;;
(defmethod initialize-instance :after ((matrix standard-matrix) &rest initargs)
(declare (ignore initargs))
- (let* ((n (nrows matrix))
- (m (ncols matrix))
- (h (head matrix))
- (ss (store-size matrix))
- (nxm (* n m)))
- (declare (type fixnum n m h nxm))
- ;;Row-ordered by default.
- (unless (and (slot-boundp matrix 'row-stride) (slot-boundp matrix 'col-stride))
- (setf (row-stride matrix) m)
- (setf (col-stride matrix) 1))
- (let ((rs (row-stride matrix))
- (cs (row-stride matrix)))
- (declare (type fixnum rs cs))
- ;;Error checking is good if we use foreign-pointers as store types.
- (cond
- ((<= n 0) (error "Number of rows must be > 0. Initialized with ~A." n))
- ((<= m 0) (error "Number of columns must be > 0. Initialized with ~A." m))
- ;;
- ((< h 0) (error "Head of the store must be >= 0. Initialized with ~A." h))
- ((< rs 0) (error "Row-stride of the store must be >= 0. Initialized with ~A." rs))
- ((< cs 0) (error "Column-stride of the store must be >= 0. Initialized with ~A." cs))
- ((<= ss 0) (error "Store-size must be > 0. Initialized with ~A." ss))))
+ (mlet*
+ (((nr nc hd ss) (slot-values matrix '(number-of-rows number-of-cols head store-size))
+ :type (fixnum fixnum fixnum fixnum)))
+ ;;Row-ordered by default.
+ (unless (and (slot-boundp matrix 'row-stride) (slot-boundp matrix 'col-stride))
+ (setf (row-stride matrix) nc)
+ (setf (col-stride matrix) 1))
+ (let* ((rs (row-stride matrix))
+ (cs (col-stride matrix))
+ (l-idx (store-indexing (- nr 1) (- nc 1) hd rs cs)))
+ (declare (type fixnum rs cs))
+ ;;Error checking is good if we use foreign-pointers as store types.
+ (cond
+ ((<= nr 0) (error "Number of rows must be > 0. Initialized with ~A." nr))
+ ((<= nc 0) (error "Number of columns must be > 0. Initialized with ~A." nc))
+ ;;
+ ((< hd 0) (error "Head of the store must be >= 0. Initialized with ~A." hd))
+ ((< rs 0) (error "Row-stride of the store must be >= 0. Initialized with ~A." rs))
+ ((< cs 0) (error "Column-stride of the store must be >= 0. Initialized with ~A." cs))
+ ((<= ss l-idx) (error "Store is not large enough to hold the matrix.
+Initialized with ~A, but the largest possible index is ~A." ss l-idx))))
;;
- (setf (number-of-elements matrix) nxm)))
+ (setf (number-of-elements matrix) (* nr nc))))
;;
(defmacro matrix-ref (matrix row &optional col)
@@ -265,16 +302,17 @@ matrix and a number"))
(format stream "~%")))
;;
-(defun transpose-i! (matrix)
+(defun transpose! (matrix)
"
Syntax
======
- (transpose-i! matrix)
+ (transpose! matrix)
Purpose
=======
Exchange row and column strides so that effectively
- the matrix is transposed in place (without much effort).
+ the matrix is destructively transposed in place
+ (without much effort).
"
(cond
((typep matrix 'standard-matrix)
@@ -285,126 +323,144 @@ matrix and a number"))
((typep matrix 'number) matrix)
(t (error "Don't know how to take the transpose of ~A." matrix))))
+(defmacro with-transpose! (matlst &rest body)
+ `(progn
+ ,@(mapcar #'(lambda (mat) `(transpose! ,mat)) matlst)
+ ,@body
+ ,@(mapcar #'(lambda (mat) `(transpose! ,mat)) matlst)))
+
;;
-(defun transpose! (matrix)
+(defgeneric transpose (matrix)
+ (:documentation
"
Syntax
======
- (transpose! matrix)
+ (transpose matrix)
Purpose
=======
Create a new matrix object which represents the transpose of the
- the given matrix, but shares the store with matrix.
-"
- (cond
- ((typep matrix 'standard-matrix)
- (mlet* (((hd nr nc rs cs) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride)) :type (fixnum fixnum fixnum fixnum)))
- (make-instance (class-of matrix)
- :nrows nc :ncols nr
- :store (store matrix)
- :head hd
- :row-stride cs :col-stride rs)))
- ((typep matrix 'number) matrix)
- (t (error "Don't know how to take the transpose of ~A." matrix))))
+ the given matrix.
-;;
-(defmacro with-transpose! (matlst &rest body)
- `(progn
- ,@(mapcar #'(lambda (mat) `(transpose-i! ,mat)) matlst)
- ,@body
- ,@(mapcar #'(lambda (mat) `(transpose-i! ,mat)) matlst)))
+ Store is shared with \"matrix\".
-;;
-(defun sub! (matrix i j nrows ncols)
- (declare (type standard-matrix matrix)
- (type fixnum i j nrows ncols))
- (let ((hd (head matrix))
- (nr (nrows matrix))
- (nc (ncols matrix))
- (rs (row-stride matrix))
- (cs (col-stride matrix)))
- (declare (type fixnum hd nr nc rs cs))
- (unless (and (< -1 i (+ i nrows) nr) (< -1 j (+ j ncols) nc))
- (error "Bad index and/or size.
-Cannot create a sub-matrix of size (~a ~a) starting at (~a ~a)" nrows ncols i j))
- (make-instance (class-of matrix)
- :nrows nrows :ncols ncols
- :store (store matrix)
- :head (store-indexing i j hd rs cs)
- :row-stride rs :col-stride cs)))
-
-(defun (setf sub!) (mat-b mat-a i j nrows ncols)
- (copy! mat-b (sub! mat-a i j nrows ncols)))
+ Settable
+ ========
+ (setf (transpose matrix) value)
-;;
-(defun row! (matrix i)
- (declare (type standard-matrix matrix)
- (type fixnum i))
- (mlet* (((hd nr nc rs cs) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride)) :type (fixnum fixnum fixnum fixnum)))
- (unless (< -1 i nr)
- (error "Index ~a is outside the valid range for the given matrix." i))
- (make-instance (class-of matrix)
- :nrows 1 :ncols nc
- :store (store matrix)
- :head (store-indexing i 0 hd rs cs)
- :row-stride rs :col-stride cs)))
-
-(defun (setf row!) (mat-b mat-a i)
- (copy! mat-b (row! mat-a i)))
+ is basically the same as
+
+ (copy! value (transpose matrix))
+"))
+
+(defun (setf transpose) (value matrix)
+ (copy! value (transpose matrix)))
+
+(defmethod transpose ((matrix number))
+ matrix)
;;
-(defun col! (matrix j)
- (declare (type standard-matrix matrix)
- (type fixnum j))
- (mlet* (((hd nr nc rs cs) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride)) :type (fixnum fixnum fixnum fixnum)))
- (unless (< -1 j nc)
- (error "Index ~a is outside the valid range for the given matrix." j))
- (make-instance (class-of matrix)
- :nrows nr :ncols 1
- :store (store matrix)
- :head (store-indexing 0 j hd rs cs)
- :row-stride rs :col-stride cs)))
-
-(defun (setf col!) (mat-b mat-a j)
- (copy! mat-b (col! mat-a j)))
+(defgeneric sub-matrix (matrix origin dim)
+ (:documentation
+"
+ Syntax
+ ======
+ (sub-matrix matrix origin dimensions)
+
+ Purpose
+ =======
+ Create a block sub-matrix of \"matrix\" starting at \"origin\"
+ of dimension \"dim\", sharing the store.
+
+ origin, dim are lists with two elements.
+
+ Store is shared with \"matrix\"
+
+ Settable
+ ========
+ (setf (sub-matrix matrix origin dim) value)
+
+ is basically the same as
+
+ (copy! value (sub-matrix matrix origin dim))
+"))
+
+(defun (setf sub-matrix) (value matrix origin dim)
+ (copy! value (sub-matrix matrix origin dim)))
;;
-(defun blas-copyable-p (matrix)
- (declare (optimize (safety 0) (speed 3))
- (type (or real-matrix complex-matrix) matrix))
- (mlet* ((nr (nrows matrix) :type fixnum)
- (nc (ncols matrix) :type fixnum)
- (rs (row-stride matrix) :type fixnum)
- (cs (col-stride matrix) :type fixnum)
- (ne (number-of-elements matrix) :type fixnum))
- (cond
- ((or (= nc 1) (= cs (* nr rs))) (values t rs ne))
- ((or (= nr 1) (= rs (* nc cs))) (values t cs ne))
- (t (values nil -1 -1)))))
+(defgeneric row (matrix i)
+ (:documentation
+"
+ Syntax
+ ======
+ (row matrix i)
+
+ Purpose
+ =======
+ Returns the i'th row of the matrix.
+ Store is shared with \"matrix\".
+
+ Settable
+ ========
+ (setf (row matrix i) value)
+
+ is basically the same as
+
+ (copy! value (row matrix i))
+"))
+
+(defun (setf row) (value matrix i)
+ (copy! value (row matrix i)))
;;
-(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 (fortran-nop op)))
- ((= rs 1) (values :col-major cs (fortran-op op)))
- ;;Lets not confound lisp's type declaration.
- (t (values nil -1 "?")))))
+(defgeneric col (matrix j)
+ (:documentation
+"
+ Syntax
+ ======
+ (col matrix j)
+
+ Purpose
+ =======
+ Returns the j'th column of the matrix.
+ Store is shared with \"matrix\".
+
+ Settable
+ ========
+ (setf (col matrix j) value)
+
+ is basically the same as
+
+ (copy! value (col matrix j))
+"))
+
+(defun (setf col) (value matrix j)
+ (copy! value (col matrix j)))
+
;;
-(declaim (inline fortran-op))
-(defun fortran-op (op)
- (ecase op (:n "N") (:t "T")))
+(defgeneric diag (matrix &optional d)
+ (:documentation
+"
+ Syntax
+ ======
+ (diag matrix &optional (d 0))
-(declaim (inline fortran-nop))
-(defun fortran-nop (op)
- (ecase op (:t "N") (:n "T")))
+ Purpose
+ =======
+ Returns a row-vector representing the d'th diagonal of the matrix.
+ [a_{ij} : j - i = d]
-(defun fortran-snop (sop)
- (cond
- ((string= sop "N") "T")
- ((string= sop "T") "N")
- (t (error "Unrecognised fortran-op."))))
\ No newline at end of file
+ Store is shared with \"matrix\".
+
+ Settable
+ ========
+ (setf (diag matrix d) value)
+
+ is basically the same as
+
+ (copy! value (diag matrix d))
+"))
+
+(defun (setf diag) (value matrix &optional (d 0))
+ (copy! value (diag matrix d)))
\ No newline at end of file
diff --git a/src/trace.lisp b/src/trace.lisp
index 7bdeb3f..8490613 100644
--- a/src/trace.lisp
+++ b/src/trace.lisp
@@ -48,14 +48,12 @@
(in-package "MATLISP")
-#+nil (export '(tr))
-
-(defgeneric tr (a)
+(defgeneric mtrace (a)
(:documentation
"
Syntax
======
- (TR a)
+ (MTRACE a)
Purpose
=======
@@ -65,11 +63,11 @@
Notes
=====
- (TR a) is the same as (SUM (DIAG a))
+ (MTRACE a) is the same as (SUM (DIAG a))
"))
-(defmethod tr ((x number))
+(defmethod mtrace ((x number))
x)
-(defmethod tr ((a standard-matrix))
- (sum (diag a)))
+(defmethod mtrace ((a standard-matrix))
+ (sum (diag a 0)))
\ No newline at end of file
-----------------------------------------------------------------------
Summary of changes:
matlisp.asd | 1 -
packages.lisp | 77 +++++-------
src/axpy.lisp | 6 +-
src/blas.lisp | 16 +---
src/complex-matrix.lisp | 139 +++++++++++++++------
src/copy.lisp | 4 +-
src/diag.lisp | 235 ----------------------------------
src/gemm.lisp | 34 +++---
src/gemv.lisp | 54 ++++----
src/real-matrix.lisp | 85 +++++++++++--
src/special.lisp | 6 +-
src/standard-matrix.lisp | 314 +++++++++++++++++++++++++++-------------------
src/trace.lisp | 14 +--
13 files changed, 453 insertions(+), 532 deletions(-)
delete mode 100644 src/diag.lisp
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-03-20 06:47:12
|
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 fd41f88aefad9d87a8c9183f946ac14c3b564de8 (commit)
via eee93ce6980e4a07c4f7d3ccb4604666691c529d (commit)
from 83c3111d290cc5994b05dcc32e2ee51cb1529f1a (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 fd41f88aefad9d87a8c9183f946ac14c3b564de8
Author: Akshay Srinivasan <aks...@gm...>
Date: Tue Mar 20 12:11:57 2012 +0530
-> Changed standard-matrix class defaults.
diff --git a/src/standard-matrix.lisp b/src/standard-matrix.lisp
index 1d168e9..4c918b8 100644
--- a/src/standard-matrix.lisp
+++ b/src/standard-matrix.lisp
@@ -3,6 +3,12 @@
;;
(declaim (inline allocate-integer4-store))
+
+(eval-when (load eval compile)
+ (deftype integer4-matrix-element-type ()
+ '(signed-byte 32))
+ )
+
(defun allocate-integer4-store (size &optional (initial-element 0))
"(ALLOCATE-INTEGER-STORE SIZE [INITIAL-ELEMENT]). Allocates
integer storage. Default INITIAL-ELEMENT = 0."
@@ -73,25 +79,26 @@ that way."))
(let* ((n (nrows matrix))
(m (ncols matrix))
(h (head matrix))
- (rs (row-stride matrix))
- (cs (col-stride matrix))
(ss (store-size matrix))
(nxm (* n m)))
- (declare (type fixnum n m h rs cs nxm))
- ;;Error checking is good if we use foreign-pointers as store types.
- (cond
- ((<= n 0) (error "Number of rows must be > 0. Initialized with ~A." n))
- ((<= m 0) (error "Number of columns must be > 0. Initialized with ~A." m))
- ;;
- ((< h 0) (error "Head of the store must be >= 0. Initialized with ~A." h))
- ((< rs 0) (error "Row-stride of the store must be > 0. Initialized with ~A." rs))
- ((< cs 0) (error "Column-stride of the store must be > 0. Initialized with ~A." cs))
- ((<= ss 0) (error "Store-size must be > 0. Initialized with ~A." ss)))
+ (declare (type fixnum n m h nxm))
;;Row-ordered by default.
- (when (or (= rs 0) (= cs 0))
+ (unless (and (slot-boundp matrix 'row-stride) (slot-boundp matrix 'col-stride))
(setf (row-stride matrix) m)
(setf (col-stride matrix) 1))
-
+ (let ((rs (row-stride matrix))
+ (cs (row-stride matrix)))
+ (declare (type fixnum rs cs))
+ ;;Error checking is good if we use foreign-pointers as store types.
+ (cond
+ ((<= n 0) (error "Number of rows must be > 0. Initialized with ~A." n))
+ ((<= m 0) (error "Number of columns must be > 0. Initialized with ~A." m))
+ ;;
+ ((< h 0) (error "Head of the store must be >= 0. Initialized with ~A." h))
+ ((< rs 0) (error "Row-stride of the store must be >= 0. Initialized with ~A." rs))
+ ((< cs 0) (error "Column-stride of the store must be >= 0. Initialized with ~A." cs))
+ ((<= ss 0) (error "Store-size must be > 0. Initialized with ~A." ss))))
+ ;;
(setf (number-of-elements matrix) nxm)))
;;
commit eee93ce6980e4a07c4f7d3ccb4604666691c529d
Author: Akshay Srinivasan <aks...@gm...>
Date: Tue Mar 20 11:40:32 2012 +0530
-> Modified def-fortran-routine to handle things like:
(def-fortran-routine ("daxpy_" daxpy) ..)
This will help when adding foreign interfaces to C functions.
diff --git a/src/ffi-cffi.lisp b/src/ffi-cffi.lisp
index dc72abd..b1d8bcc 100644
--- a/src/ffi-cffi.lisp
+++ b/src/ffi-cffi.lisp
@@ -213,40 +213,40 @@ Example:
;; Call defcfun to define the foreign function.
;; Also creates a nice lisp helper function.
-(defmacro def-fortran-routine (name return-type &rest body)
- (let ((fortran-name (make-fortran-name `,name))
- (lisp-name (make-fortran-ffi-name `,name))
- (hack-return-type `,return-type)
- (hack-body `(,@body))
- (hidden-var-name nil))
-
- (multiple-value-bind (doc pars)
- (parse-doc-&-parameters `(,@body))
- (when (member hack-return-type '(:complex-single-float :complex-double-float))
- ;; The return type is complex. Since this is a "structure",
- ;; Fortran inserts a "hidden" first parameter before all
- ;; others. This is used to store the resulting complex
- ;; number. Then there is no "return" value, so set the return
- ;; type to :void.
- ;;
- (setq hidden-var-name (gensym "HIDDEN-COMPLEX-RETURN-"))
- (setq hack-body `(,@doc
- (,hidden-var-name ,hack-return-type :output)
- ,@pars))
- (setq hack-return-type :void)))
-
- `(eval-when (load eval compile)
- (progn
-
- ;; Removing 'inlines' It seems that CMUCL has a problem with
- ;; inlines of FFI's when a lisp image is saved. Until the
- ;; matter is clarified we leave out 'inline's
-
- ;(declaim (inline ,lisp-name)) ;sbcl 0.8.5 has problems with
- ;inlining
- (cffi:defcfun (,fortran-name ,lisp-name) ,@(get-return-type hack-return-type)
- ,@(parse-fortran-parameters hack-body))
- ,@(def-fortran-interface name hack-return-type hack-body hidden-var-name)))))
+(defmacro def-fortran-routine (func-name return-type &rest body)
+ (multiple-value-bind (name fortran-name) (if (listp func-name)
+ (values (cadr func-name) (car func-name))
+ (values func-name (make-fortran-name func-name)))
+ (let* ((lisp-name (make-fortran-ffi-name `,name))
+ (hack-return-type `,return-type)
+ (hack-body `(,@body))
+ (hidden-var-name nil))
+
+ (multiple-value-bind (doc pars)
+ (parse-doc-&-parameters `(,@body))
+ (when (member hack-return-type '(:complex-single-float :complex-double-float))
+ ;; The return type is complex. Since this is a "structure",
+ ;; Fortran inserts a "hidden" first parameter before all
+ ;; others. This is used to store the resulting complex
+ ;; number. Then there is no "return" value, so set the return
+ ;; type to :void.
+ ;;
+ (setq hidden-var-name (gensym "HIDDEN-COMPLEX-RETURN-"))
+ (setq hack-body `(,@doc
+ (,hidden-var-name ,hack-return-type :output)
+ ,@pars))
+ (setq hack-return-type :void)))
+
+ `(eval-when (load eval compile)
+ (progn
+ ;; Removing 'inlines' It seems that CMUCL has a problem with
+ ;; inlines of FFI's when a lisp image is saved. Until the
+ ;; matter is clarified we leave out 'inline's
+
+ ;; (declaim (inline ,lisp-name)) ;sbcl 0.8.5 has problems with
+ (cffi:defcfun (,fortran-name ,lisp-name) ,@(get-return-type hack-return-type)
+ ,@(parse-fortran-parameters hack-body))
+ ,@(def-fortran-interface name hack-return-type hack-body hidden-var-name))))))
;; Create a form specifying a simple Lisp function that calls the
;; underlying Fortran routine of the same name.
-----------------------------------------------------------------------
Summary of changes:
src/ffi-cffi.lisp | 66 +++++++++++++++++++++++-----------------------
src/standard-matrix.lisp | 35 ++++++++++++++----------
2 files changed, 54 insertions(+), 47 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-03-19 03:44:36
|
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 83c3111d290cc5994b05dcc32e2ee51cb1529f1a (commit)
via 7018af71d307ae84ad75a29a79d61db33d981430 (commit)
via 55a0678924a585263937fdff69c5d522f1589d7a (commit)
via ced92c7a0cbf00be10fd0dff010a4768130da9c1 (commit)
via 74e3f184bf5e3b0974d145a823b4f86e33e00a1a (commit)
via 45962c22d9931aa0961dca11931b50d884e3ec01 (commit)
from 514db2b95e68cd882d51d9a6d603fc24b6f0b2bb (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 83c3111d290cc5994b05dcc32e2ee51cb1529f1a
Merge: 7018af7 55a0678
Author: Akshay Srinivasan <aks...@gm...>
Date: Mon Mar 19 09:11:27 2012 +0530
Merge branch 'master' into matlisp-cffi
commit 7018af71d307ae84ad75a29a79d61db33d981430
Author: Akshay Srinivasan <aks...@gm...>
Date: Mon Mar 19 09:09:41 2012 +0530
-> Fixed rand(), more tweaks to gem{m,v}.lisp
diff --git a/src/gemm.lisp b/src/gemm.lisp
index 97dbb6c..419be54 100644
--- a/src/gemm.lisp
+++ b/src/gemm.lisp
@@ -246,10 +246,14 @@
;
(defmethod gemm! ((alpha number) (a real-matrix) (b real-matrix)
- (beta number) (c complex-matrix)
+ (beta complex) (c complex-matrix)
&optional (job :nn))
- (scal! (complex-coerce beta) c)
- (gemm! alpha a b 1d0 (realpart! c) job)
+ (let ((r-c (realpart! c))
+ (c-be (complex-coerce beta)))
+ (declare (type real-matrix c)
+ (type complex-double-float c-al))
+ (scal! c-be c)
+ (gemm! alpha a b 1d0 r-c job))
c)
;
diff --git a/src/gemv.lisp b/src/gemv.lisp
index 4ec41be..88da9df 100644
--- a/src/gemv.lisp
+++ b/src/gemv.lisp
@@ -113,9 +113,18 @@
(complex-coerce beta) y job))
;
-(defmethod gemv! ((alpha number) (A real-matrix) (x real-matrix)
+(defmethod gemv! ((alpha cl:real) (A real-matrix) (x real-matrix)
+ (beta complex) (y complex-matrix) &optional (job :n))
+ (let ((r-y (realpart! y)))
+ (declare (type real-matrix r-y))
+ ;; y <- \beta * y
+ (scal! (complex-coerce beta) y)
+ ;; y <- y + \alpha * A o x
+ (real-double-gemv!-typed (coerce alpha 'double-float) A x 1d0 r-y job)))
+
+(defmethod gemv! ((alpha complex) (A real-matrix) (x real-matrix)
(beta complex) (y complex-matrix) &optional (job :n))
- ;; y <- \beta * y
+ ;; y <- \beta * y
(scal! (complex-coerce beta) y)
;; y <- y + \alpha * A o x
(gemv! alpha A x 1d0 y job))
@@ -145,7 +154,7 @@
;; (realpart! y) <- \beta * (realpart! y) + (realpart \alpha) . A o x
(real-double-gemv!-typed r-al A x r-be r-y job)
;; (imagpart! y) <- \beta * (imagpart! y) + (imagpart \alpha) . A o x
- (real-double-gemv!-typed i-al A x r-be i-y job))
+ (real-double-gemv!-typed i-al A x r-be i-y job))
y)
;
diff --git a/src/special.lisp b/src/special.lisp
index 20138bc..e00193f 100644
--- a/src/special.lisp
+++ b/src/special.lisp
@@ -147,7 +147,7 @@
(unless (typep state 'random-state)
(error "STATE must be a RANDOM-STATE, not a ~A" (type-of state)))
- (locally (declare (type fixnum n m))
+ (locally (declare (type fixnum n m))
(let* ((size (* n m))
(store (allocate-real-store size))
(unity #.(coerce 1 'real-matrix-element-type)))
@@ -158,5 +158,7 @@
(declare (fixnum k))
(setf (aref store k) (random unity state)))
- (make-instance 'real-matrix :nrows n :ncols m :store store))))
+ (make-instance 'real-matrix
+ :nrows n :ncols m
+ :row-stride m :col-stride 1 :store store))))
-----------------------------------------------------------------------
Summary of changes:
configure | 76 +++++++++++++++++++++++
configure.ac | 147 ++++++++++++++++++++++----------------------
lib-src/compat/Makefile.am | 4 +-
lib/lazy-loader.lisp.in | 4 +-
src/gemm.lisp | 10 ++-
src/gemv.lisp | 15 ++++-
src/special.lisp | 6 +-
7 files changed, 177 insertions(+), 85 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-03-18 14:30:23
|
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 514db2b95e68cd882d51d9a6d603fc24b6f0b2bb (commit)
from 41f86e07e1ab87c390f9e570bd51ce57ac2d4d6f (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 514db2b95e68cd882d51d9a6d603fc24b6f0b2bb
Author: Akshay Srinivasan <aks...@gm...>
Date: Sun Mar 18 19:57:04 2012 +0530
More trivial fixes for gemm.lisp
diff --git a/src/gemm.lisp b/src/gemm.lisp
index 99c183c..97dbb6c 100644
--- a/src/gemm.lisp
+++ b/src/gemm.lisp
@@ -249,7 +249,7 @@
(beta number) (c complex-matrix)
&optional (job :nn))
(scal! (complex-coerce beta) c)
- (gemm! alpha a b 1d0 (realpart! c))
+ (gemm! alpha a b 1d0 (realpart! c) job)
c)
;
@@ -257,7 +257,7 @@
(beta complex) (c complex-matrix)
&optional (job :nn))
(scal! (complex-coerce beta) c)
- (gemm! alpha a b 1d0 c))
+ (gemm! alpha a b 1d0 c job))
(defmethod gemm! ((alpha cl:real) (a real-matrix) (b complex-matrix)
(beta cl:real) (c complex-matrix)
@@ -297,7 +297,7 @@
(beta complex) (c complex-matrix)
&optional (job :nn))
(scal! (complex-coerce beta) c)
- (gemm! alpha a b 1d0 c))
+ (gemm! alpha a b 1d0 c job))
(defmethod gemm! ((alpha cl:real) (a complex-matrix) (b real-matrix)
(beta cl:real) (c complex-matrix)
@@ -310,8 +310,8 @@
(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)))
+ (real-double-gemm!-typed r-al r-a b r-be r-c job)
+ (real-double-gemm!-typed r-al i-a b r-be i-c job)))
(defmethod gemm! ((alpha complex) (a complex-matrix) (b real-matrix)
(beta cl:real) (c complex-matrix)
-----------------------------------------------------------------------
Summary of changes:
src/gemm.lisp | 10 +++++-----
1 files changed, 5 insertions(+), 5 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-03-18 14:23:33
|
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 41f86e07e1ab87c390f9e570bd51ce57ac2d4d6f (commit)
from f748feb7a04396a6ddd3c61407d11d02aca3034f (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 41f86e07e1ab87c390f9e570bd51ce57ac2d4d6f
Author: Akshay Srinivasan <aks...@gm...>
Date: Sun Mar 18 19:50:03 2012 +0530
-> Fix for trivial bug in the new gemm! method.
diff --git a/src/gemm.lisp b/src/gemm.lisp
index b8609f9..99c183c 100644
--- a/src/gemm.lisp
+++ b/src/gemm.lisp
@@ -249,7 +249,8 @@
(beta number) (c complex-matrix)
&optional (job :nn))
(scal! (complex-coerce beta) c)
- (gemm! alpha a b 1d0 (realpart! c)))
+ (gemm! alpha a b 1d0 (realpart! c))
+ c)
;
(defmethod gemm! ((alpha number) (a real-matrix) (b complex-matrix)
-----------------------------------------------------------------------
Summary of changes:
src/gemm.lisp | 3 ++-
1 files changed, 2 insertions(+), 1 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-03-18 14:20:26
|
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 f748feb7a04396a6ddd3c61407d11d02aca3034f (commit)
from 61733620324195c7c1a45a770e29637a74329ebd (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 f748feb7a04396a6ddd3c61407d11d02aca3034f
Author: Akshay Srinivasan <aks...@gm...>
Date: Sun Mar 18 19:46:49 2012 +0530
-> Added method another method into gemm!
diff --git a/src/gemm.lisp b/src/gemm.lisp
index ae4d935..b8609f9 100644
--- a/src/gemm.lisp
+++ b/src/gemm.lisp
@@ -245,6 +245,13 @@
(complex-coerce beta) c job))
;
+(defmethod gemm! ((alpha number) (a real-matrix) (b real-matrix)
+ (beta number) (c complex-matrix)
+ &optional (job :nn))
+ (scal! (complex-coerce beta) c)
+ (gemm! alpha a b 1d0 (realpart! c)))
+
+;
(defmethod gemm! ((alpha number) (a real-matrix) (b complex-matrix)
(beta complex) (c complex-matrix)
&optional (job :nn))
-----------------------------------------------------------------------
Summary of changes:
src/gemm.lisp | 7 +++++++
1 files changed, 7 insertions(+), 0 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <aks...@gm...> - 2012-03-17 11:11:47
|
> -----------------------------------------------------------------------
>
> 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(-)
>
There are major changes in this commit. Level-2 and Level-3 operations
are now possible with gemm! and gemv!, which can handle sliced matrices
(quite well in fact :)
What do you think ?
Here's a little snippet of code:
-------------------------------------------------------
;;Create a 4x4 matrix with random entries
(defvar d (make-complex-matrix 4 4))
(dotimes (i 4)
(dotimes (j 4)
(setf (matrix-ref-2d d i j)
(complex-coerce (complex (cl:random 10) (cl:random 10))))))
;;Submatrix of d starting at (1, 1) or size (2, 2)
(defvar e (sub! d 1 1 2 2))
;;
(defvar a (make-real-matrix '((1 2) (3 4))))
(defvar c (make-real-matrix 2 2))
;;Can't use dgemm here, because of the way (imagpart! e) is arranged
(gemm! 1d0 (imagpart! e) a 0d0 c)
------------------------------------------------------
Akshay
|
|
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
|
