Menu
▾
▴
[Matlisp-commit] [matlisp-git]matlisp branch tensor updated. 2012-02-23-154-gb9bf26a
|
From: Akshay S. <ak...@us...> - 2012-08-03 03:51:57
|
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 b9bf26aaa85df12dec80c1c5b822d8821ed6e9df (commit)
via fbb318b4ac5ed7192722ad350298173c4d391a6b (commit)
via 5649455cf8b1d1c0f073d52bda626d393dab67c3 (commit)
via a640a37462d29cefa33c54e9e08c89ded77f29d3 (commit)
via 05cac9e6e247823c2fc6f058da9b3904983e1edb (commit)
via a4355472b2268ce43bafae38350d0e76f186c953 (commit)
via a922933e28c83cbbc1bf9a2dc7ae3341b76fb2cc (commit)
from 8ccded8d5db3d1918b7af875f4dbddd16dc75f28 (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 b9bf26aaa85df12dec80c1c5b822d8821ed6e9df
Author: Akshay Srinivasan <aks...@gm...>
Date: Fri Aug 3 09:16:59 2012 +0530
o Added idxv back.
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index 784d858..a1898e7 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -30,6 +30,9 @@
(make-array (length contents) :element-type 'index-type
:initial-contents contents))
+(definline idxv (&rest contents)
+ (apply #'make-index-store contents))
+
;;
(defclass standard-tensor ()
((rank
commit fbb318b4ac5ed7192722ad350298173c4d391a6b
Author: Akshay Srinivasan <aks...@gm...>
Date: Fri Aug 3 09:14:24 2012 +0530
o Added test conditions in make-tensor-maker to create a matrix instance
when rank = 2, and a vector when rank = 1. "change-class" inside the initilize
instance of standard-tensor, in the earlier scheme was too slow.
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index 2fbe3f8..784d858 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -77,7 +77,6 @@
:documentation "The actual storage for the tensor."))
(:documentation "Basic tensor class."))
-;;
(defclass standard-matrix (standard-tensor)
((rank
:accessor rank
@@ -86,6 +85,7 @@
:documentation "For a matrix, rank = 2."))
(:documentation "Basic matrix class."))
+;;
(defmethod initialize-instance :after ((matrix standard-matrix) &rest initargs)
(declare (ignore initargs))
(mlet*
@@ -293,8 +293,9 @@
(let-typed ((stds (allocate-index-store rank) :type index-store-vector))
(setf (strides tensor) stds)
(very-quickly
- (loop :for i :downfrom (1- rank) :to 0
- :for st = 1 :then (the index-type (* st (aref dims i)))
+ (loop
+ :for i :downfrom (1- rank) :to 0
+ :and st = 1 :then (the index-type (* st (aref dims i)))
:do (setf (aref stds i) st)))))
;;
(mlet* ((stds (strides tensor) :type index-store-vector)
@@ -313,16 +314,7 @@
(cond
((<= ns 0) (error 'tensor-invalid-dimension-value :argument i :dimension ns :tensor tensor))
((< st 0) (error 'tensor-invalid-stride-value :argument i :stride st :tensor tensor))))))
- (setf (number-of-elements tensor) (reduce #'* dims))
- (cond
- ((= rank 2)
- (let ((cocl (getf (get-tensor-counterclass (class-name (class-of tensor))) :matrix)))
- (assert cocl nil 'tensor-cannot-find-counter-class :tensor-class (class-name (class-of tensor)))
- (change-class tensor cocl)))
- ((= rank 1)
- (let ((cocl (getf (get-tensor-counterclass (class-name (class-of tensor))) :vector)))
- (assert cocl nil 'tensor-cannot-find-counter-class :tensor-class (class-name (class-of tensor)))
- (change-class tensor cocl))))))
+ (setf (number-of-elements tensor) (reduce #'* dims))))
;;
(defgeneric tensor-store-ref (tensor store-idx)
@@ -426,7 +418,7 @@
;;
(defun tensor-type-p (tensor subscripts)
-"
+ "
Syntax
======
(tensor-type-p tensor subscripts)
@@ -447,7 +439,7 @@
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))
:type (index-type index-store-vector)))
@@ -470,13 +462,13 @@
nil)))))))
(parse-sub subscripts 0)))))
-(definline vector-p (tensor)
- (declare (type standard-tensor tensor))
- (tensor-type-p tensor '(*)))
+(definline matrix-p (ten)
+ (declare (type standard-tensor ten))
+ (= (slot-value ten 'rank) 2))
-(definline matrix-p (tensor)
- (declare (type standard-tensor tensor))
- (tensor-type-p tensor '(* *)))
+(definline vector-p (ten)
+ (declare (type standard-tensor ten))
+ (= (slot-value ten 'rank) 1))
(defun square-p (tensor)
(let* ((rank (rank tensor))
@@ -560,20 +552,12 @@
(t
(error 'parser-error :message "Error parsing subscript-list.")))))))
(multiple-value-bind (nhd ndim nstd) (sub-tread 0 subscripts hd nil nil)
- (let ((nrnk (length ndim)))
- (declare (type index-type nrnk))
- (cond
- ((null ndim) (tensor-store-ref tensor nhd))
- ((= nrnk 1) (let ((cocl (getf (get-tensor-counterclass (class-name (class-of tensor))) :vector)))
- (assert cocl nil 'tensor-cannot-find-counter-class :tensor-class (class-name (class-of tensor)))
- (make-instance cocl
- :parent-tensor tensor :store (store tensor) :head nhd
- :dimensions (make-index-store ndim) :strides (make-index-store nstd))))
- ((= nrnk 2) (let ((cocl (getf (get-tensor-counterclass (class-name (class-of tensor))) :matrix)))
- (assert cocl nil 'tensor-cannot-find-counter-class :tensor-class (class-name (class-of tensor)))
- (make-instance cocl
- :parent-tensor tensor :store (store tensor) :head nhd
- :dimensions (make-index-store ndim) :strides (make-index-store nstd))))
- (t (make-instance (class-name (class-of tensor))
- :parent-tensor tensor :store (store tensor) :head nhd
- :dimensions (make-index-store ndim) :strides (make-index-store nstd)))))))))
+ (if (null ndim) (tensor-store-ref tensor nhd)
+ (make-instance
+ (let ((nrnk (length ndim)))
+ (if (> nrnk 2) (class-name (class-of tensor))
+ (let ((cocl (get-tensor-counterclass (class-name (class-of tensor)))))
+ (assert cocl nil 'tensor-cannot-find-counter-class :tensor-class (class-name (class-of tensor)))
+ (ecase nrnk (2 (getf cocl :matrix)) (1 (getf cocl :vector))))))
+ :parent-tensor tensor :store (store tensor) :head nhd
+ :dimensions (make-index-store ndim) :strides (make-index-store nstd)))))))
diff --git a/src/level-1/realimag.lisp b/src/level-1/realimag.lisp
index 266bb95..ec51f8a 100644
--- a/src/level-1/realimag.lisp
+++ b/src/level-1/realimag.lisp
@@ -43,7 +43,7 @@
"
(etypecase tensor
(real-tensor tensor)
- (complex-tensor (make-instance 'real-tensor
+ (complex-tensor (make-instance (ecase (rank tensor) (2 'real-matrix) (1 'real-vector) (t 'real-tensor))
:parent-tensor tensor :store (store tensor)
:dimensions (dimensions tensor)
:strides (map 'index-store-vector #'(lambda (x) (* 2 x)) (strides tensor))
@@ -65,7 +65,7 @@
"
(etypecase tensor
(real-tensor tensor)
- (complex-tensor (make-instance 'real-tensor
+ (complex-tensor (make-instance (ecase (rank tensor) (2 'real-matrix) (1 'real-vector) (t 'real-tensor))
:parent-tensor tensor :store (store tensor)
:dimensions (dimensions tensor)
:strides (map 'index-store-vector #'(lambda (x) (* 2 x)) (strides tensor))
diff --git a/src/level-1/tensor-maker.lisp b/src/level-1/tensor-maker.lisp
index 51fa64b..3933496 100644
--- a/src/level-1/tensor-maker.lisp
+++ b/src/level-1/tensor-maker.lisp
@@ -1,15 +1,19 @@
(in-package #:matlisp)
(defmacro make-tensor-maker (func-name (tensor-class))
- (let ((opt (get-tensor-class-optimization tensor-class)))
+ (let ((opt (get-tensor-class-optimization tensor-class))
+ (cocl (get-tensor-counterclass tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
+ (assert cocl nil 'tensor-cannot-find-counter-class :tensor-class tensor-class)
`(defun ,func-name (&rest args)
(labels ((make-dims (dims)
(declare (type cons dims))
(let* ((vdim (make-index-store dims))
(ss (reduce #'* vdim))
- (store (,(getf opt :store-allocator) ss)))
- (make-instance ',tensor-class :store store :dimensions vdim)))
+ (store (,(getf opt :store-allocator) ss))
+ (rnk (length vdim)))
+ (make-instance (case rnk (2 ',(getf cocl :matrix)) (1 ',(getf cocl :vector)) (t ',tensor-class))
+ :store store :dimensions vdim)))
(make-from-array (arr)
(declare (type (array * *) arr))
(let* ((ret (make-dims (array-dimensions arr)))
commit 5649455cf8b1d1c0f073d52bda626d393dab67c3
Author: Akshay Srinivasan <aks...@gm...>
Date: Thu Aug 2 20:06:20 2012 +0530
o Replaced reference to row-stride in blas-helpers.lisp
diff --git a/src/base/blas-helpers.lisp b/src/base/blas-helpers.lisp
index 94d5e21..00f8bc6 100644
--- a/src/base/blas-helpers.lisp
+++ b/src/base/blas-helpers.lisp
@@ -38,8 +38,8 @@
(defun blas-matrix-compatible-p (matrix op)
(declare (type standard-matrix matrix))
- (let ((rs (row-stride matrix))
- (cs (col-stride matrix)))
+ (let ((rs (aref (strides matrix) 0))
+ (cs (aref (strides matrix) 1)))
(declare (type index-type rs cs))
(cond
((= cs 1) (values :row-major rs (fortran-nop op)))
commit a640a37462d29cefa33c54e9e08c89ded77f29d3
Author: Akshay Srinivasan <aks...@gm...>
Date: Thu Aug 2 00:16:03 2012 +0530
o Saving changes. Inline functions.
diff --git a/packages.lisp b/packages.lisp
index 1bded66..2d65f54 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -75,6 +75,8 @@
#:format-to-string #:string+
#:linear-array-type
#:list-dimensions
+ #:lvec-foldl #:lvec-foldr #:lvec-max #:lvec-min #:lvec-eq
+ #:lvec->list #:lvec->list!
;;Macros
#:when-let #:if-let #:if-ret #:with-gensyms #:let-rec
#:mlet* #:make-array-allocator #:let-typed
diff --git a/src/base/generic-copy.lisp b/src/base/generic-copy.lisp
index 4445153..d560d93 100644
--- a/src/base/generic-copy.lisp
+++ b/src/base/generic-copy.lisp
@@ -48,7 +48,7 @@
(let ((lst (make-list (array-rank to))))
(mod-dotimes (idx (make-index-store (array-dimensions to)))
do (progn
- (idx->list! idx lst)
+ (lvec->list! idx lst)
(setf (apply #'aref to lst) (apply #'aref from lst)))))
to)
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index d7e9d02..2fbe3f8 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -17,18 +17,18 @@
=======
Allocates index storage.")
-(defun make-index-store (&rest contents)
-"
+(definline make-index-store (contents)
+ "
Syntax
======
(MAKE-INDEX-STORE &rest 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)))
+ Allocates index storage with initial elements from the list CONTENTS.
+ "
+ (make-array (length contents) :element-type 'index-type
+ :initial-contents contents))
;;
(defclass standard-tensor ()
@@ -273,14 +273,14 @@
;;
(defmethod initialize-instance :before ((tensor standard-tensor) &rest initargs)
- (let ((dims (getf initargs :dimensions)))
- (assert (getf initargs :dimensions) nil 'invalid-arguments :argnum :dimensions
- :message "Dimensions are necessary for creating the tensor object.")
- (when (consp dims)
- (setf (getf initargs :dimensions) (apply #'make-index-store dims)))))
+ (assert (getf initargs :dimensions) nil 'invalid-arguments :argnum :dimensions
+ :message "Dimensions are necessary for creating the tensor object."))
(defmethod initialize-instance :after ((tensor standard-tensor) &rest initargs)
(declare (ignore initargs))
+ (let ((dims (dimensions tensor)))
+ (when (consp dims)
+ (setf (slot-value tensor 'dimensions) (make-index-store dims))))
(mlet*
(((dims hd ss) (slot-values tensor '(dimensions head store-size))
:type (index-store-vector index-type index-type))
@@ -290,13 +290,12 @@
;;Row-ordered by default.
(unless (and (slot-boundp tensor 'strides)
(= (length (strides tensor)) rank))
- (mlet* ((stds (allocate-index-store rank)
- :type index-store-vector))
- (setf (strides tensor) stds)
- (do ((i (1- rank) (1- i))
- (st 1 (* st (aref dims i))))
- ((< i 0))
- (setf (aref stds i) st))))
+ (let-typed ((stds (allocate-index-store rank) :type index-store-vector))
+ (setf (strides tensor) stds)
+ (very-quickly
+ (loop :for i :downfrom (1- rank) :to 0
+ :for st = 1 :then (the index-type (* st (aref dims i)))
+ :do (setf (aref stds i) st)))))
;;
(mlet* ((stds (strides tensor) :type index-store-vector)
(L-idx (store-indexing-vec (map `index-store-vector #'1- dims) hd stds dims) :type index-type))
@@ -569,12 +568,12 @@
(assert cocl nil 'tensor-cannot-find-counter-class :tensor-class (class-name (class-of tensor)))
(make-instance cocl
:parent-tensor tensor :store (store tensor) :head nhd
- :dimensions (apply #'make-index-store ndim) :strides (apply #'make-index-store nstd))))
+ :dimensions (make-index-store ndim) :strides (make-index-store nstd))))
((= nrnk 2) (let ((cocl (getf (get-tensor-counterclass (class-name (class-of tensor))) :matrix)))
(assert cocl nil 'tensor-cannot-find-counter-class :tensor-class (class-name (class-of tensor)))
(make-instance cocl
:parent-tensor tensor :store (store tensor) :head nhd
- :dimensions (apply #'make-index-store ndim) :strides (apply #'make-index-store nstd))))
+ :dimensions (make-index-store ndim) :strides (make-index-store nstd))))
(t (make-instance (class-name (class-of tensor))
:parent-tensor tensor :store (store tensor) :head nhd
- :dimensions (apply #'make-index-store ndim) :strides (apply #'make-index-store nstd)))))))))
+ :dimensions (make-index-store ndim) :strides (make-index-store nstd)))))))))
diff --git a/src/classes/real-tensor.lisp b/src/classes/real-tensor.lisp
index f2c13a8..e7b8602 100644
--- a/src/classes/real-tensor.lisp
+++ b/src/classes/real-tensor.lisp
@@ -41,10 +41,10 @@ Allocates real storage. Default initial-element = 0d0.")
;;
(defmethod initialize-instance ((tensor real-tensor) &rest initargs)
(if (getf initargs :store)
- (setf (store-size tensor) (length (getf initargs :store)))
+ (setf (slot-value tensor 'store-size) (length (getf initargs :store)))
(let ((size (reduce #'* (getf initargs :dimensions))))
- (setf (store tensor) (allocate-real-store size)
- (store-size tensor) size)))
+ (setf (slot-value tensor 'store) (allocate-real-store size)
+ (slot-value tensor 'store-size) size)))
(call-next-method))
;;
diff --git a/src/ffi/foreign-vector.lisp b/src/ffi/foreign-vector.lisp
index ed036c3..f70c459 100644
--- a/src/ffi/foreign-vector.lisp
+++ b/src/ffi/foreign-vector.lisp
@@ -112,10 +112,3 @@
,@body))
`(with-fortran-matrix ,(car array-list)
,@body)))
-
-(defmacro make-array-allocator (allocator-name type init &optional (doc ""))
- `(definline ,allocator-name (size &optional (initial-element ,init))
- ,@(unless (string= doc "")
- `(,doc))
- (make-array size
- :element-type ,type :initial-element initial-element)))
diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp
index ce870da..3e13987 100644
--- a/src/level-1/axpy.lisp
+++ b/src/level-1/axpy.lisp
@@ -133,7 +133,7 @@
is stored in Y and Y is returned.
")
(:method :before ((alpha number) (x standard-tensor) (y standard-tensor))
- (assert (idx= (dimensions x) (dimensions y)) nil
+ (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
'tensor-dimension-mismatch))
(:method ((alpha number) (x complex-tensor) (y real-tensor))
(error 'coercion-error :from 'complex-tensor :to 'real-tensor)))
@@ -185,17 +185,17 @@
X,Y must have the same dimensions.
")
(:method :before ((alpha number) (x standard-tensor) (y standard-tensor))
- (unless (idx= (dimensions x) (dimensions y))
+ (unless (lvec-eq (dimensions x) (dimensions y) #'=)
(error 'tensor-dimension-mismatch))))
(defmethod axpy ((alpha number) (x real-tensor) (y real-tensor))
(let ((ret (if (complexp alpha)
- (copy! y (apply #'make-complex-tensor (idx->list (dimensions y))))
+ (copy! y (apply #'make-complex-tensor (lvec->list (dimensions y))))
(copy y))))
(axpy! alpha x ret)))
(defmethod axpy ((alpha number) (x complex-tensor) (y real-tensor))
- (let ((ret (copy! y (apply #'make-complex-tensor (idx->list (dimensions y))))))
+ (let ((ret (copy! y (apply #'make-complex-tensor (lvec->list (dimensions y))))))
(axpy! alpha y ret)))
(defmethod axpy ((alpha number) (x real-tensor) (y complex-tensor))
@@ -212,7 +212,7 @@
(defmethod axpy ((alpha number) (x (eql nil)) (y real-tensor))
(let ((ret (if (complexp alpha)
- (copy! y (apply #'make-complex-tensor (idx->list (dimensions y))))
+ (copy! y (apply #'make-complex-tensor (lvec->list (dimensions y))))
(copy y))))
(axpy! alpha nil ret)))
diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp
index 24e087f..1afffce 100644
--- a/src/level-1/copy.lisp
+++ b/src/level-1/copy.lisp
@@ -113,7 +113,7 @@
the type of Y. For example,
a COMPLEX-MATRIX cannot be copied to a
REAL-MATRIX but the converse is possible."
- (assert (idx= (dimensions x) (dimensions y)) nil
+ (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
'tensor-dimension-mismatch))
(defmethod copy! ((x standard-tensor) (y standard-tensor))
@@ -164,14 +164,14 @@
"
(declare (type standard-tensor tensor))
(let* ((dims (dimensions tensor))
- (ret (make-array (idx->list dims)
+ (ret (make-array (lvec->list dims)
:element-type (if-ret (getf (get-tensor-class-optimization (class-name (class-of tensor))) :element-type)
(error 'tensor-cannot-find-optimization :tensor-class (class-name (class-of tensor)))))))
(declare (type index-store-vector dims))
(let ((lst (make-list (rank tensor))))
(very-quickly
(mod-dotimes (idx dims)
- do (setf (apply #'aref ret (idx->list! idx lst)) (tensor-ref tensor idx))))
+ do (setf (apply #'aref ret (lvec->list! idx lst)) (tensor-ref tensor idx))))
ret)))
(defmethod copy! :before ((x standard-tensor) (y array))
@@ -183,7 +183,7 @@
(assert (and
(= (rank x) (array-rank y))
(reduce #'(lambda (x y) (and x y))
- (mapcar #'= (idx->list (dimensions x)) (array-dimensions y))))
+ (mapcar #'= (lvec->list (dimensions x)) (array-dimensions y))))
nil 'dimension-mismatch))
(defmethod copy! ((x real-tensor) (y array))
@@ -193,7 +193,7 @@
(mod-dotimes (idx (dimensions x))
with (linear-sums
(of-x (strides x) (head x)))
- do (setf (apply #'aref y (idx->list! idx lst))
+ do (setf (apply #'aref y (lvec->list! idx lst))
(aref sto-x of-x)))))
y)
@@ -204,7 +204,7 @@
(mod-dotimes (idx (dimensions x))
with (linear-sums
(of-x (strides x) (head x)))
- do (setf (apply #'aref y (idx->list! idx lst))
+ do (setf (apply #'aref y (lvec->list! idx lst))
(complex (aref sto-x (* 2 of-x)) (aref sto-x (1+ (* 2 of-x))))))))
y)
@@ -216,8 +216,8 @@
:given (array-element-type x) :expected (element-type y))
(assert (and
(= (array-rank x) (rank y))
- (reduce #'(lambda (x y) (and x y))
- (mapcar #'= (array-dimensions x) (idx->list (dimensions y)))))
+ (reduce #'(lambda (x y) (= x y))
+ (mapcar #'= (array-dimensions x) (lvec->list (dimensions y)))))
nil 'dimension-mismatch))
(defmethod copy! ((x array) (y real-tensor))
@@ -227,7 +227,7 @@
(mod-dotimes (idx (dimensions y))
with (linear-sums
(of-y (strides y) (head y)))
- do (setf (aref sto-y of-y) (apply #'aref x (idx->list! idx lst))))))
+ do (setf (aref sto-y of-y) (apply #'aref x (lvec->list! idx lst))))))
y)
(defmethod copy! ((x array) (y complex-tensor))
@@ -237,7 +237,7 @@
(mod-dotimes (idx (dimensions y))
with (linear-sums
(of-y (strides y) (head y)))
- do (let-typed ((ele (apply #'aref x (idx->list! idx lst)) :type complex-type))
+ do (let-typed ((ele (apply #'aref x (lvec->list! idx lst)) :type complex-type))
(setf (aref sto-y (* 2 of-y)) (realpart ele)
(aref sto-y (1+ (* 2 of-y))) (imagpart ele))))))
y)
@@ -246,12 +246,12 @@
;;Generic function defined in src;base;generic-copy.lisp
(defmethod copy ((tensor real-tensor))
- (let* ((ret (apply #'make-real-tensor (idx->list (dimensions tensor)))))
+ (let* ((ret (apply #'make-real-tensor (lvec->list (dimensions tensor)))))
(declare (type real-tensor ret))
(copy! tensor ret)))
(defmethod copy ((tensor complex-tensor))
- (let* ((ret (apply #'make-complex-tensor (idx->list (dimensions tensor)))))
+ (let* ((ret (apply #'make-complex-tensor (lvec->list (dimensions tensor)))))
(declare (type complex-tensor ret))
(copy! tensor ret)))
diff --git a/src/level-1/dot.lisp b/src/level-1/dot.lisp
index 15bf751..8b777ee 100644
--- a/src/level-1/dot.lisp
+++ b/src/level-1/dot.lisp
@@ -131,7 +131,7 @@
")
(:method :before ((x standard-vector) (y standard-vector) &optional (conjugate-p t))
(declare (ignore conjugate-p))
- (unless (idx= (dimensions x) (dimensions y))
+ (unless (lvec-eq (dimensions x) (dimensions y) #'=)
(error 'tensor-dimension-mismatch))))
(defmethod dot ((x number) (y number) &optional (conjugate-p t))
diff --git a/src/level-1/scal.lisp b/src/level-1/scal.lisp
index 5bdb664..15dfde7 100644
--- a/src/level-1/scal.lisp
+++ b/src/level-1/scal.lisp
@@ -108,7 +108,7 @@
(scal! alpha result)))
(defmethod scal ((alpha complex) (x real-tensor))
- (let* ((result (apply #'make-complex-tensor (idx->list (dimensions x)))))
+ (let* ((result (apply #'make-complex-tensor (lvec->list (dimensions x)))))
(declare (type complex-tensor result))
(copy! x result)
(scal! alpha result)))
diff --git a/src/level-1/swap.lisp b/src/level-1/swap.lisp
index 3d5fa31..081f8c3 100644
--- a/src/level-1/swap.lisp
+++ b/src/level-1/swap.lisp
@@ -62,7 +62,7 @@
;;Generic function in src;base;generic-swap.lisp
(defmethod swap! :before ((x standard-tensor) (y standard-tensor))
- (assert (idx= (dimensions x) (dimensions y)) nil
+ (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
'tensor-dimension-mismatch))
(defmethod swap! ((x complex-tensor) (y real-tensor))
diff --git a/src/level-1/tensor-maker.lisp b/src/level-1/tensor-maker.lisp
index e06b632..51fa64b 100644
--- a/src/level-1/tensor-maker.lisp
+++ b/src/level-1/tensor-maker.lisp
@@ -13,14 +13,15 @@
(make-from-array (arr)
(declare (type (array * *) arr))
(let* ((ret (make-dims (array-dimensions arr)))
- (st-r (store ret)))
+ (st-r (store ret))
+ (lst (make-list (rank ret))))
(declare (type ,tensor-class ret)
(type ,(linear-array-type (getf opt :store-type)) st-r))
(very-quickly
(mod-dotimes (idx (dimensions ret))
with (linear-sums
(of-r (strides ret) (head ret)))
- do ,(funcall (getf opt :value-writer) `(,(getf opt :coercer) (apply #'aref arr (idx->list idx))) 'st-r 'of-r)))
+ do ,(funcall (getf opt :value-writer) `(,(getf opt :coercer) (apply #'aref arr (lvec->list! idx lst))) 'st-r 'of-r)))
ret))
(make-from-list (lst)
(let* ((ret (make-dims (list-dimensions lst)))
@@ -50,3 +51,4 @@
;;Had to move it here in the wait for copy!
(definline sub-tensor (tensor subscripts)
(copy (sub-tensor~ tensor subscripts)))
+
diff --git a/src/utilities/lvec.lisp b/src/utilities/lvec.lisp
index 4620d9a..a46edf0 100644
--- a/src/utilities/lvec.lisp
+++ b/src/utilities/lvec.lisp
@@ -1,42 +1,42 @@
(in-package #:matlisp-utilities)
-(defun-compiler-macro lvec-foldl (func vec)
+(definline lvec-foldl (func vec)
(declare (type vector))
(loop
:for i :of-type fixnum :from 0 :below (length vec)
:for ret = (aref vec 0) :then (funcall func (aref vec i) ret)
:finally (return ret)))
-(defun-compiler-macro lvec-foldr (func vec)
+(definline lvec-foldr (func vec)
(declare (type vector))
(loop
:for i :of-type fixnum :downfrom (1- (length vec)) :to 0
:for ret = (aref vec (1- (length vec))) :then (funcall func (aref vec i) ret)
:finally (return ret)))
-(defun-compiler-macro lvec-max (vec)
+(definline lvec-max (vec)
(declare (type vector vec))
(loop :for ele :across vec
:for idx :of-type fixnum = 0 :then (+ idx 1)
:with max :of-type fixnum = (aref vec 0)
- :with max-idx :of-type index-type = 0
+ :with max-idx :of-type fixnum = 0
:do (when (> ele max)
(setf max ele
max-idx idx))
:finally (return (values max max-idx))))
-(defun-compiler-macro lvec-min (vec)
+(definline lvec-min (vec)
(declare (type vector vec))
(loop :for ele :across vec
:for idx :of-type fixnum = 0 :then (+ idx 1)
:with min :of-type fixnum = (aref vec 0)
- :with min-idx :of-type index-type = 0
+ :with min-idx :of-type fixnum = 0
:do (when (< ele min)
(setf min ele
min-idx idx))
:finally (return (values min min-idx))))
-(defun-compiler-macro lvec-eq (va vb &optional (test #'eq))
+(definline lvec-eq (va vb &optional (test #'eq))
(declare (type vector va vb))
(let ((la (length va))
(lb (length vb)))
@@ -48,12 +48,12 @@
:do (return nil)
:finally (return t)))))
-(defun-compiler-macro lvec->list (va)
+(definline lvec->list (va)
(declare (type vector va))
(loop :for ele :across va
:collect ele))
-(defun-compiler-macro lvec->list! (va la)
+(definline lvec->list! (va la)
(declare (type vector va)
(type list la))
(loop
diff --git a/src/utilities/macros.lisp b/src/utilities/macros.lisp
index 9eef3f4..6871843 100644
--- a/src/utilities/macros.lisp
+++ b/src/utilities/macros.lisp
@@ -59,6 +59,13 @@
`(progn
,@body))))
+(defmacro make-array-allocator (allocator-name type init &optional doc)
+ `(definline ,allocator-name (size &optional (initial-element ,init))
+ ,@(unless (null doc)
+ `(,doc))
+ (make-array size
+ :element-type ,type :initial-element initial-element)))
+
(defmacro let-typed (bindings &rest body)
"
This macro works basically like let, but also allows type-declarations
@@ -182,7 +189,7 @@
`(with-gensyms (a b c)
`(let ((,a 1) (,b 2) (,c 3))
(+ ,a ,b ,c))))
- => (LET ((A (GENSYM "A")) (B (GENSYM "B")) (C (GENSYM "C")))
+ => (LET ((A (GENSYM \"A\")) (B (GENSYM \"B\")) (C (GENSYM \"C\")))
`(LET ((,A 1) (,B 2) (,C 3))
(+ ,A ,B ,C)))
@end lisp
@@ -318,42 +325,7 @@
(destructuring-bind (labd args &rest body) lambda-func
(assert (eq labd 'lambda))
`(lambda ,args ,@(cdr (unquote-args body args)))))
-
-(defmacro defun-compiler-macro (func-name (&rest args) &body body)
- "
- Creates a compiler macro mirroring the function definition, this helps
- the compiler produce leaner code when argument types are better known in the
- local environment during compile time.
- DO NOT USE backquotes in the function definition, it will likely be mucked up.
-
- Example:
- @lisp
- > (macroexpand-1
- `(defun-compiler-macro lvec->list (va)
- (declare (type vector va))
- (loop :for ele :across va
- :collect ele)))
- => (PROGN
- (DEFUN LVEC->LIST (VA)
- (DECLARE (TYPE VECTOR VA))
- (LOOP :FOR ELE :ACROSS VA
- :COLLECT ELE))
- (DEFINE-COMPILER-MACRO LVEC->LIST (VA)
- (LIST 'LOCALLY (LIST 'DECLARE (LIST 'TYPE 'VECTOR VA))
- (LIST 'LOOP ':FOR 'ELE ':ACROSS VA ':COLLECT 'ELE))))
- T
- @end lisp
- "
- `(progn
- (defun ,func-name (,@args)
- ,@body)
- (define-compiler-macro ,func-name (,@args)
- (list 'locally
- ,@(cdr (unquote-args body (loop
- :for arg :in args
- :unless (and (symbolp arg) (string= (aref (symbol-name arg) 0) #\&))
- :collect (if (consp arg) (first arg) arg))))))))
-
+
(defmacro looped-mapcar ((func lst) &rest body)
"
A macro to use when caught between the efficiency of imperative looping, and
@@ -491,3 +463,5 @@
"
`(with-optimization (:speed 1)
,@forms))
+
+
diff --git a/tests/loopy-tests.lisp b/tests/loopy-tests.lisp
index e17a747..2ed4ed1 100644
--- a/tests/loopy-tests.lisp
+++ b/tests/loopy-tests.lisp
@@ -32,6 +32,9 @@
(time (axpy! 1d0 x y))
t))
+(definline idxv (&rest dims)
+ (make-array (length dims) :element-type 'index-type :initial-contents dims))
+
(defun test-mm-lisp (n)
(let ((t-a (make-real-tensor n n))
(t-b (make-real-tensor n n))
@@ -52,7 +55,7 @@
(hd-a (head t-a))
(hd-b (head t-b))
(hd-c (head t-c)))
- (declare (type (real-array *) st-a st-b st-c)
+ (declare (type real-store-vector st-a st-b st-c)
(type index-type rstrd-a cstrd-a rstrd-b cstrd-b rstrd-c cstrd-c nr-c
nc-c nc-a hd-a hd-b hd-c))
(mod-dotimes (idx (dimensions t-a))
@@ -63,7 +66,7 @@
do (setf (aref st-a of-a) (random 1d0)
(aref st-b of-b) (random 1d0)
(aref st-c of-c) 0d0))
- (time
+ (time
(very-quickly
(loop repeat nr-c
for rof-a of-type index-type = hd-a then (+ rof-a rstrd-a)
@@ -76,14 +79,27 @@
for of-b of-type index-type = cof-b then (+ of-b rstrd-b)
summing (* (aref st-a of-a) (aref st-b of-b)) into sum of-type real-type
finally (setf (aref st-c of-c) sum))))
- #+nil(mod-dotimes (idx (dimensions t-c))
+ #+nil
+ (mod-dotimes (idx (dimensions t-c))
with (loop-order :row-major)
with (linear-sums
- (of-a (idxv (row-stride t-a) 0) (head t-a))
- (of-b (idxv 0 (col-stride t-b)) (head t-b))
+ (rof-a (idxv rstrd-a 0) (head t-a))
+ (cof-b (idxv 0 cstrd-b) (head t-b))
(of-c (strides t-c) (head t-c)))
- do (incf (aref st-c of-c) (* (aref st-a of-a) (aref st-b of-b)))))))))
-
+ do (loop repeat nc-a
+ for of-a of-type index-type = rof-a then (+ of-a cstrd-a)
+ for of-b of-type index-type = cof-b then (+ of-b rstrd-b)
+ summing (* (aref st-a of-a) (aref st-b of-b)) into sum of-type real-type
+ finally (setf (aref st-c of-c) sum)))
+ #+nil
+ (mod-dotimes (idx (idxv n n n))
+ with (loop-order :row-major)
+ with (linear-sums
+ (of-a (idxv n 0 1))
+ (of-b (idxv 0 1 n))
+ (of-c (idxv n 1 0)))
+ do (incf (aref st-c of-c) (* (aref st-a of-a) (aref st-b of-b))))))
+ (values t-a t-b t-c))))
(defun test-mm-ddot (n)
commit 05cac9e6e247823c2fc6f058da9b3904983e1edb
Author: Akshay Srinivasan <aks...@gm...>
Date: Wed Aug 1 09:19:21 2012 +0530
Moved utilities.lisp into a new file.
diff --git a/doc/matlisp.texinfo b/doc/matlisp.texinfo
new file mode 100644
index 0000000..1ee0b5c
--- /dev/null
+++ b/doc/matlisp.texinfo
@@ -0,0 +1,91 @@
+\input texinfo
+
+@setfilename matlisp.info
+@settitle Matlisp: User manual
+
+@copying
+blasblasd
+
+@quotation
+asdasd
+
+@end quotation
+@end copying
+
+@titlepage
+@title Matlisp: User manual
+@vskip 0pt plus 1filll
+July, 2012
+@page
+@vskip 0pt plus 1fill
+@insertcopying
+@end titlepage
+
+
+@macro femlisp{}
+@sc{Femlisp}
+@end macro
+
+@macro CL{}
+Common Lisp
+@end macro
+
+@alias module = code
+@alias package = code
+@alias arg = var
+@alias function = code
+@alias macro = code
+@alias symbol = code
+@alias class = symbol
+@alias type = symbol
+@alias slot = symbol
+@alias path = file
+@alias program = file
+
+@macro slisp{code}
+@lisp
+\code\
+@end lisp
+@end macro
+
+
+@c===================================================================================
+@contents
+
+@ifnottex
+@node Top
+
+@end ifnottex
+
+@menu
+* Introduction::
+* Index::
+@end menu
+
+@node Introduction
+@chapter Introduction
+@cindex chapter, Introduction
+
+Matlisp is a asjdhkasd
+
+@deffn Macro CHECK-PROPERTIES @var{PLACE} @var{PROPERTIES}
+@findex CHECK-PROPERTIES
+check-properties place properties
+
+Checks if all of the @arg{properties} are in the property list
+@arg{place}.
+
+@lisp
+(let ((x (make-real-tensor '((1 2 3) (4 5 6)))))
+ (scal! pi x))
+@end lisp
+
+@end deffn
+
+
+@node Index
+@unnumbered Index
+
+@printindex cp
+
+@bye
diff --git a/matlisp.asd b/matlisp.asd
index fb30b24..43f09d1 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -51,9 +51,14 @@
:components ((:file "conditions")))
(asdf:defsystem matlisp-utilities
- :pathname #.(translate-logical-pathname "matlisp:srcdir;src;")
+ :pathname #.(translate-logical-pathname "matlisp:srcdir;src;utilities;")
:depends-on ("matlisp-packages" "matlisp-conditions")
- :components ((:file "utilities")))
+ :components ((:file "functions")
+ (:file "string")
+ (:file "macros"
+ :depends-on ("functions"))
+ (:file "lvec"
+ :depends-on ("macros" "functions"))))
(asdf:defsystem lazy-loader
:pathname #.(translate-logical-pathname "matlisp:lib;")
diff --git a/packages.lisp b/packages.lisp
index e71bae6..1bded66 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -79,7 +79,7 @@
#:when-let #:if-let #:if-ret #:with-gensyms #:let-rec
#:mlet* #:make-array-allocator #:let-typed
#:nconsc #:define-constant
- #:macrofy #:looped-mapcar
+ #:macrofy #:looped-mapcar #:defun-compiler-macro
;;
#:inlining #:definline
#:with-optimization #:quickly #:very-quickly #:slowly #:quickly-if))
diff --git a/src/base/blas-helpers.lisp b/src/base/blas-helpers.lisp
index 969c3ea..94d5e21 100644
--- a/src/base/blas-helpers.lisp
+++ b/src/base/blas-helpers.lisp
@@ -65,4 +65,3 @@
(defun combine-jobs (&rest jobs)
(let ((job (intern (apply #'concatenate 'string (mapcar #'symbol-name jobs)) "KEYWORD")))
job))
-
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index 6782ccc..d7e9d02 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -1,5 +1,6 @@
(in-package #:matlisp)
+;;Alias for fixnum.
(deftype index-type ()
'fixnum)
@@ -16,11 +17,11 @@
=======
Allocates index storage.")
-(defun make-index-store (contents)
+(defun make-index-store (&rest contents)
"
Syntax
======
- (MAKE-INDEX-STORE CONTENTS)
+ (MAKE-INDEX-STORE &rest CONTENTS)
Purpose
=======
@@ -29,41 +30,6 @@
(make-array size :element-type 'index-type
:initial-contents contents)))
-(definline idxv (&rest contents)
- (make-index-store contents))
-
-;;
-(definline idx-max (seq)
- (declare (type index-store-vector seq))
- (very-quickly (reduce #'max seq)))
-
-(definline idx-min (seq)
- (declare (type index-store-vector seq))
- (very-quickly (reduce #'min seq)))
-
-(defun idx= (a b)
- (declare (type index-store-vector a b))
- (when (= (length a) (length b))
- (very-quickly
- (loop
- for ele-a across a
- for ele-b across b
- unless (= ele-a ele-b)
- do (return nil)
- finally (return t)))))
-
-(definline idx->list (a)
- (declare (type index-store-vector a))
- (loop for ele across a
- collect ele))
-
-(definline idx->list! (a lst)
- ;;No error checking!
- (mapl (let ((i 0))
- #'(lambda (lst)
- (rplaca lst (aref a i))
- (incf i)))
- lst))
;;
(defclass standard-tensor ()
((rank
@@ -311,7 +277,7 @@
(assert (getf initargs :dimensions) nil 'invalid-arguments :argnum :dimensions
:message "Dimensions are necessary for creating the tensor object.")
(when (consp dims)
- (setf (getf initargs :dimensions) (make-index-store dims)))))
+ (setf (getf initargs :dimensions) (apply #'make-index-store dims)))))
(defmethod initialize-instance :after ((tensor standard-tensor) &rest initargs)
(declare (ignore initargs))
@@ -603,12 +569,12 @@
(assert cocl nil 'tensor-cannot-find-counter-class :tensor-class (class-name (class-of tensor)))
(make-instance cocl
:parent-tensor tensor :store (store tensor) :head nhd
- :dimensions (make-index-store ndim) :strides (make-index-store nstd))))
+ :dimensions (apply #'make-index-store ndim) :strides (apply #'make-index-store nstd))))
((= nrnk 2) (let ((cocl (getf (get-tensor-counterclass (class-name (class-of tensor))) :matrix)))
(assert cocl nil 'tensor-cannot-find-counter-class :tensor-class (class-name (class-of tensor)))
(make-instance cocl
:parent-tensor tensor :store (store tensor) :head nhd
- :dimensions (make-index-store ndim) :strides (make-index-store nstd))))
+ :dimensions (apply #'make-index-store ndim) :strides (apply #'make-index-store nstd))))
(t (make-instance (class-name (class-of tensor))
:parent-tensor tensor :store (store tensor) :head nhd
- :dimensions (make-index-store ndim) :strides (make-index-store nstd)))))))))
+ :dimensions (apply #'make-index-store ndim) :strides (apply #'make-index-store nstd)))))))))
diff --git a/src/utilities.lisp b/src/utilities.lisp
deleted file mode 100644
index 157b98e..0000000
--- a/src/utilities.lisp
+++ /dev/null
@@ -1,441 +0,0 @@
-(in-package #:matlisp-utilities)
-
-;;TODO: cleanup!
-(defmacro mlet* (decls &rest body)
-"
- 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
-
- 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))
-
- 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)))
-"
- (labels ((mlet-decl (vars type decls)
- (when (or type decls)
- `((declare ,@decls
- ,@(when type
- (mapcar #'(lambda (tv) (if (null (first tv))
- `(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
- ;;If there is only one element use let
- ;;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-typed (bindings &rest body)
-"
- let-typed ({var form &key type}*) form*
-
- This macro also handles type declarations.
-
- Example:
- > (let-typed ((x 1 :type fixnum))
- (+ 1 x))
-
- expands into:
-
- > (let ((x 1))
- (declare (type fixnum x))
- (+ 1 x))
-"
- (labels ((parse-bindings (bdng let-decl type-decl)
- (if (null bdng) (values (reverse let-decl) (reverse type-decl))
- ;;Unless the user gives a initialisation form, no point declaring type
- ;; {var is bound to nil}.
- (destructuring-bind (var &optional form &key (type nil)) (ensure-list (car bdng))
- (parse-bindings (cdr bdng)
- (cons (if form `(,var ,form) var) let-decl)
- (if type
- (cons `(type ,type ,var) type-decl)
- type-decl))))))
- (multiple-value-bind (let-bdng type-decl) (parse-bindings bindings nil nil)
- (let ((decl-code (recursive-append
- (cond
- ((and (consp (first body))
- (eq (caar body) 'declare))
- (first body))
- ((consp type-decl)
- '(declare ))
- (t nil))
- type-decl)))
- `(let (,@let-bdng)
- ,@(if (null decl-code) nil `(,decl-code))
- ,@(if (and (consp (first body))
- (eq (caar body) 'declare))
- (cdr body)
- body))))))
-
-(defmacro let-rec (name arglist &rest code)
-"
- (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))))
-"
- (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)
- ,@body))
-
-;; Helper macro to do setf and nconc
-;; for destructive list updates.
-(defmacro nconsc (var &rest args)
- (if (null args) var
- `(if (null ,var)
- (progn
- (setf ,var ,(car args))
- (nconc ,var ,@(cdr args)))
- (nconc ,var ,@args))))
-
-(defun pop-arg! (arglist sym)
- (check-type sym symbol)
- (labels ((get-sym (sym arglist prev)
- (cond
- ((null arglist) nil)
- ((eq (car arglist) sym) (prog1
- (cadr arglist)
- (if prev
- (rplacd prev (cddr arglist)))))
- (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)
- Evaluate form, and if the form is not nil, then return it,
- else run else-body"
- (let ((ret (gensym)))
- `(let ((,ret ,form))
- (or ,ret
- (progn
- ,@else-body)))))
-
-;;
-(defmacro when-let ((var . form) &rest body)
- (check-type var symbol)
- `(let ((,var ,@form))
- (when ,var
- ,@body)))
-
-(defmacro if-let ((var . form) &rest body)
- (check-type var symbol)
- `(let ((,var ,@form))
- (if ,var
- ,@body)))
-
-;;
-(defun cut-cons-chain! (lst test)
- (check-type lst cons)
- (labels ((cut-cons-chain-tin (lst test parent-lst)
- (cond
- ((null lst) nil)
- ((funcall test (cadr lst))
- (let ((keys (cdr lst)))
- (setf (cdr lst) nil)
- (values parent-lst keys)))
- (t (cut-cons-chain-tin (cdr lst) test parent-lst)))))
- (cut-cons-chain-tin lst test lst)))
-
-;;
-(defun zip (&rest args)
- (apply #'map 'list #'list args))
-
-;;
-(defmacro mcase (keyform &rest body)
- (labels ((app-equal (lst)
- (if (null lst)
- nil
- `(((and ,@(mapcar (lambda (pair) (cons 'eq pair))
- (zip keyform (caar lst))))
- ,@(cdar lst))
- ,@(app-equal (cdr lst))))))
- `(cond
- ,@(app-equal body))))
-
-(defmacro zip-eq (a b)
- `(and ,@(mapcar (lambda (pair) (cons 'eq pair))
- (zip (ensure-list a) (ensure-list b)))))
-
-(defun recursive-append (&rest lsts)
- (labels ((bin-append (x y)
- (if (null x)
- (if (typep (car y) 'symbol)
- y
- (car y))
- (append x (if (null y)
- nil
- (if (typep (car y) 'symbol)
- `(,y)
- y))))))
- (if (null lsts)
- nil
- (bin-append (car lsts) (apply #'recursive-append (cdr lsts))))))
-
-(defun unquote-args (lst args)
- "
- Makes list suitable for use inside macros (sort-of).
- Example:
- > (unquote-args '(+ x y z) '(x y))
- (LIST '+ X Y 'Z)
-
- DO NOT use backquotes!
- "
- (labels ((replace-atoms (lst ret)
- (cond
- ((null lst) (reverse ret))
- ((atom lst)
- (let ((ret (reverse ret)))
- (rplacd (last ret) lst)
- ret))
- ((consp lst)
- (replace-atoms (cdr lst) (let ((fst (car 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)
- (if (eq (car lst) 'quote)
- 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)
- "
- Macrofies a lambda function, for use later inside macros (or for symbolic math ?).
- Example:
- > (macroexpand-1 `(macrofy (lambda (x y z) (+ (sin x) y (apply #'cos (list z))))))
- (LAMBDA (X Y Z)
- (LIST '+ (LIST 'SIN X) Y (LIST 'APPLY (LIST 'FUNCTION 'COS) (LIST 'LIST Z))))
- T
- > (funcall (macrofy (lambda (x y z) (+ (sin x) y (apply #'cos (list z))))) 'a 'b 'c)
- (+ (SIN A) B (APPLY #'COS (LIST C)))
-
- DO NOT USE backquotes in the lambda function!
- "
- (destructuring-bind (labd args &rest body) lambda-func
- (assert (eq labd 'lambda))
- `(lambda ,args ,@(cdr (unquote-args body args)))))
-
-(defmacro looped-mapcar ((func lst) &rest body)
- "
- A macro to use when caught between the efficiency of imperative looping, and
- the elegance of mapcar (in a dozen places).
-
- Collects references to func and replaces them with a varible inside a loop.
- Note that although we traverse through the list only once, the collected lists
- aren't freed until the macro is closed.
-
- Example:
- > (macroexpand-1
- `(looped-mapcar (lmap '(1 2 3 4 5 6 7 8 9 10))
- (cons (lmap #'even) (lmap #'(lambda (x) (+ x 1))))))
- (LET ((#:|lst1118| '(1 2 3 4 5 6 7 8 9 10)))
- (LOOP FOR #:|ele1117| IN #:|lst1118|
- COLLECT (FUNCALL #'(LAMBDA (X) (+ X 1))
- #:|ele1117|) INTO #:|collect1116|
- COLLECT (FUNCALL #'EVEN #:|ele1117|) INTO #:|collect1115|
- FINALLY (RETURN (PROGN (CONS #:|collect1115| #:|collect1116|)))))
- "
- (let ((ret nil))
- (labels ((collect-funcs (code tf-code)
- (cond
- ((null code)
- (reverse tf-code))
- ((atom code)
- (let ((ret (reverse tf-code)))
- (rplacd (last ret) code)
- ret))
- ((consp code)
- (let ((carcode (car code)))
- (cond
- ((and (consp carcode)
- (eq (first carcode) func))
- (assert (null (cddr carcode)) nil 'invalid-arguments
- :message "The mapper only takes one argument.")
- (let ((col-sym (gensym "collect")))
- (push `(,col-sym ,(second carcode)) ret)
- (collect-funcs (cdr code) (cons col-sym tf-code))))
- ((consp carcode)
- (collect-funcs (cdr code) (cons (collect-funcs carcode nil) tf-code)))
- (t
- (collect-funcs (cdr code) (cons carcode tf-code)))))))))
- (let ((tf-code (collect-funcs body nil))
- (ele-sym (gensym "ele"))
- (lst-sym (gensym "lst")))
- (if (null ret)
- `(progn
- ,@tf-code)
- `(let ((,lst-sym ,lst))
- (loop for ,ele-sym in ,lst-sym
- ,@(loop for decl in ret
- append `(collect (funcall ,(second decl) ,ele-sym) into ,(first decl)))
- finally (return
- (progn
- ,@tf-code)))))))))
-
-(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 :adjustable t :fill-pointer t)))
- (with-output-to-string (ostr ret)
- (apply #'format (append `(,ostr ,fmt) args)))
- ret))
-
-(defun list-dimensions (lst)
- (declare (type list lst))
- (labels ((lst-tread (idx lst)
- (if (null lst) (reverse idx)
- (progn
- (setf (car idx) (length lst))
- (if (consp (car lst))
- (lst-tread (cons 0 idx) (car lst))
- (reverse idx))))))
- (lst-tread (list 0) lst)))
-
-(defmacro define-constant (name value &optional doc)
- "
- Keeps the lisp implementation from defining constants twice.
- "
- `(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value)
- ,@(when doc (list doc))))
-
-(defmacro inlining (&rest definitions)
- "Declaims the following definitions inline together with executing them."
- `(progn ,@(loop for def in definitions when (eq (first def) 'defun) collect
- `(declaim (inline ,(second def))) collect def)))
-
-(defmacro definline (name &rest rest)
- "Short form for defining an inlined function. It should probably be
-deprecated, because it won't be recognized by default by some IDEs. Better
-use the inlining macro directly."
- `(inlining (defun ,name ,@rest)))
-
-;;TODO: Add general permutation support for currying, and composition.
-(inlining
- (defun curry (func &rest args)
- "Supplies @arg{args} to @arg{func} from the left."
- #'(lambda (&rest after-args)
- (apply func (append args after-args)))))
-
-;;---------------------------------------------------------------;;
-;; Optimization
-;;---------------------------------------------------------------;;
-;;TODO: Figure out a way of adding \"#+lispworks (float 0)\"
-(defmacro with-optimization ((&key speed safety space debug) &body forms)
- "with-optimization (&key speed safety space debug) declaration* form*
- Macro creates a local environment with optimization declarations, and
- executes form*"
- (mapcar #'(lambda (x) (assert (member x '(nil 0 1 2 3))))
- (list speed safety space debug))
- `(locally
- ,(recursive-append
- `(declare ,(append `(optimize)
- (when speed
- `((speed ,speed)))
- (when safety
- `((safety ,safety)))
- (when space
- `((space ,space)))
- (when debug
- `((debug ,debug)))))
- (when (eq (caar forms) 'declare)
- (cdar forms)))
- ,@(if (eq (caar forms) 'declare) (cdr forms) forms)))
-
-(defmacro quickly (&body forms)
- `(with-optimization (:speed 3)
- ,@forms))
-
-(defmacro very-quickly (&body forms)
- `(with-optimization (:safety 0 :space 0 :speed 3)
- ,@forms))
-
-(defmacro slowly (&body forms)
- `(with-optimization (:speed 1)
- ,@forms))
-
-(defmacro quickly-if (test &body forms)
- `(if ,test ;runtime test
- (quickly ,@forms)
- (progn ,@forms)))
-;;---------------------------------------------------------------;;
-
diff --git a/src/utilities/functions.lisp b/src/utilities/functions.lisp
new file mode 100644
index 0000000..fb9d9fa
--- /dev/null
+++ b/src/utilities/functions.lisp
@@ -0,0 +1,219 @@
+(in-package #:matlisp-utilities)
+
+(declaim (inline slot-values))
+(defun slot-values (obj slots)
+ "
+ Returns the slots of the @arg{obj} corresponding to symbols in the list @arg{slots}.
+
+ Example:
+ @lisp
+ > (defstruct obj a b)
+ => OBJ
+
+ > (let ((thing (make-obj :a 1 :b 2)))
+ (slot-values thing '(a b)))
+ => 1 2
+ @end lisp
+ "
+ (values-list
+ (loop :for slt :in slots
+ :collect (slot-value obj slt))))
+
+(declaim (inline linear-array-type))
+(defun linear-array-type (type-sym &optional (size '*))
+ "
+ Creates the list representing simple-array with type @arg{type-sym}.
+
+ Example:
+ @lisp
+ > (linear-array-type 'double-float 10)
+ => (simple-array double-float (10))
+ @end lisp
+ "
+ `(simple-array ,type-sym (,size)))
+
+(declaim (inline ensure-list))
+(defun ensure-list (lst)
+ "
+ Ensconses @arg{lst} inside a list if it is an atom.
+
+ Example:
+ @lisp
+ > (ensure-list 'a)
+ => (a)
+ @end lisp
+ "
+ (if (listp lst) lst `(,lst)))
+
+(defun cut-cons-chain! (lst test)
+ "
+ Destructively cuts @arg{lst} into two parts, at the element where the function
+ @arg{test} returns a non-nil value.
+
+ Example:
+ @lisp
+ > (let ((x (list 3 5 2 1 7 9)))
+ (values-list (cons x (multiple-value-list (cut-cons-chain! x #'evenp)))))
+ => (3 5) (3 5) (2 1 7 9)
+ @end lisp
+ "
+ (declare (type list lst))
+ (labels ((cut-cons-chain-tin (lst test parent-lst)
+ (cond
+ ((null lst) nil)
+ ((funcall test (cadr lst))
+ (let ((keys (cdr lst)))
+ (setf (cdr lst) nil)
+ (values parent-lst keys)))
+ (t (cut-cons-chain-tin (cdr lst) test parent-lst)))))
+ (cut-cons-chain-tin lst test lst)))
+
+(declaim (inline zip))
+(defun zip (&rest args)
+ "
+ Zips the elements of @arg{args}.
+
+ Example:
+ @lisp
+ > (zip '(2 3 4) '(a b c) '(j h c s))
+ => ((2 A J) (3 B H) (4 C C))
+ @end lisp
+ "
+ (apply #'map 'list #'list args))
+
+(defun recursive-append (&rest lsts)
+ "
+ Appends lists in a nested manner, mostly used to bring in the charm of
+ non-lispy languages into macros.
+
+ Basically does
+ @lisp
+ (reduce
+ #'(lambda (x y)
+ (if (null x)
+ (if (typep (car y) 'symbol) y (car y))
+ (append x (if (null y) nil
+ (if (typep (car y) 'symbol) `(,y) y)))))
+ lsts :from-end t)
+ @end lisp
+
+ Examples:
+ @lisp
+ > (recursive-append
+ '(let ((x 1)))
+ '(+ x 2))
+ => (LET ((X 1))
+ (+ X 2))
+
+ > (recursive-append
+ '(let ((x 1)))
+ '((let ((y 2))
+ (setq y 3))
+ (let ((z 2))
+ z)))
+ => (LET ((X 1))
+ (LET ((Y 2))
+ (SETQ Y 3))
+ (LET ((Z 2))
+ Z))
+
+ > (recursive-append
+ nil
+ '((let ((x 1)) x)
+ (progn (+ 1 2))))
+ => (LET ((X 1))
+ X)
+
+ > (recursive-append nil '(let ((x 1)) x))
+ => (LET ((X 1))
+ X)
+ @end lisp
+ "
+ (labels ((bin-append (x y)
+ (if (null x)
+ (if (typep (car y) 'symbol) y (car y))
+ (append x (if (null y) nil
+ (if (typep (car y) 'symbol) `(,y) y))))))
+ (reduce #'bin-append lsts :from-end t)))
+
+(defun unquote-args (lst args)
+ "
+ Makes a list suitable for use inside macros (sort-of), by building a
+ new list quoting every symbol in @arg{lst} other than those in @arg{args}.
+ CAUTION: DO NOT use backquotes!
+
+ @lisp
+ Example:
+ > (unquote-args '(+ x y z) '(x y))
+ => (LIST '+ X Y 'Z)
+
+ > (unquote-args '(let ((x 1)) (+ x 1)) '(x))
+ => (LIST 'LET (LIST (LIST X '1)) (LIST '+ X '1))
+ @end lisp
+ "
+ (labels ((replace-atoms (lst ret)
+ (cond
+ ((null lst) (reverse ret))
+ ((atom lst)
+ (let ((ret (reverse ret)))
+ (rplacd (last ret) lst)
+ ret))
+ ((consp lst)
+ (replace-atoms (cdr lst) (let ((fst (car 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)
+ (if (eq (car lst) 'quote)
+ lst
+ (cons 'list (replace-atoms lst nil))))
+ ((atom lst) lst))))
+ (replace-lst lst nil)))
+
+(defun flatten (x)
+ "
+ Returns a new list by collecting all the symbols found in @arg{x}.
+ Borrowed from Onlisp.
+
+ Example:
+ @lisp
+ > (flatten '(let ((x 1)) (+ x 2)))
+ => (LET X 1 + X 2)
+ @end lisp
+ "
+ (labels ((rec (x acc)
+ (cond ((null x) acc)
+ ((atom x) (cons x acc))
+ (t (rec
+ (car x)
+ (rec (cdr x) acc))))))
+ (rec x nil)))
+
+(defun list-dimensions (lst)
+ "
+ Returns the dimensions of the nested list @arg{lst}, by finding the length
+ of the immediate list, recursively. This does not ensure the uniformity of
+ lengths of the lists.
+
+ Example:
+ @lisp
+ > (list-dimensions '((1 2 3) (4 5 6)))
+ => (2 3)
+ @end lisp
+ "
+ (declare (type list lst))
+ (labels ((lst-tread (idx lst)
+ (if (null lst) (reverse idx)
+ (progn
+ (setf (car idx) (length lst))
+ (if (consp (car lst))
+ (lst-tread (cons 0 idx) (car lst))
+ (reverse idx))))))
+ (lst-tread (list 0) lst)))
diff --git a/src/utilities/lvec.lisp b/src/utilities/lvec.lisp
new file mode 100644
index 0000000..4620d9a
--- /dev/null
+++ b/src/utilities/lvec.lisp
@@ -0,0 +1,63 @@
+(in-package #:matlisp-utilities)
+
+(defun-compiler-macro lvec-foldl (func vec)
+ (declare (type vector))
+ (loop
+ :for i :of-type fixnum :from 0 :below (length vec)
+ :for ret = (aref vec 0) :then (funcall func (aref vec i) ret)
+ :finally (return ret)))
+
+(defun-compiler-macro lvec-foldr (func vec)
+ (declare (type vector))
+ (loop
+ :for i :of-type fixnum :downfrom (1- (length vec)) :to 0
+ :for ret = (aref vec (1- (length vec))) :then (funcall func (aref vec i) ret)
+ :finally (return ret)))
+
+(defun-compiler-macro lvec-max (vec)
+ (declare (type vector vec))
+ (loop :for ele :across vec
+ :for idx :of-type fixnum = 0 :then (+ idx 1)
+ :with max :of-type fixnum = (aref vec 0)
+ :with max-idx :of-type index-type = 0
+ :do (when (> ele max)
+ (setf max ele
+ max-idx idx))
+ :finally (return (values max max-idx))))
+
+(defun-compiler-macro lvec-min (vec)
+ (declare (type vector vec))
+ (loop :for ele :across vec
+ :for idx :of-type fixnum = 0 :then (+ idx 1)
+ :with min :of-type fixnum = (aref vec 0)
+ :with min-idx :of-type index-type = 0
+ :do (when (< ele min)
+ (setf min ele
+ min-idx idx))
+ :finally (return (values min min-idx))))
+
+(defun-compiler-macro lvec-eq (va vb &optional (test #'eq))
+ (declare (type vector va vb))
+ (let ((la (length va))
+ (lb (length vb)))
+ (if (/= la lb) nil
+ (loop
+ :for ele-a :across va
+ :for ele-b :across vb
+ :unless (funcall test ele-a ele-b)
+ :do (return nil)
+ :finally (return t)))))
+
+(defun-compiler-macro lvec->list (va)
+ (declare (type vector va))
+ (loop :for ele :across va
+ :collect ele))
+
+(defun-compiler-macro lvec->list! (va la)
+ (declare (type vector va)
+ (type list la))
+ (loop
+ :for ele :across va
+ :for lst = la :then (cdr lst)
+ :do (setf (car lst) ele))
+ la)
diff --git a/src/utilities/macros.lisp b/src/utilities/macros.lisp
new file mode 100644
index 0000000..9eef3f4
--- /dev/null
+++ b/src/utilities/macros.lisp
@@ -0,0 +1,493 @@
+(in-package #:matlisp-utilities)
+
+(defmacro define-constant (name value &optional doc)
+ "
+ Keeps the lisp implementation from defining constants twice.
+ "
+ `(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value)
+ ,@(when doc (list doc))))
+
+(defmacro mlet* (vars &rest body)
+ "
+ This macro extends the syntax of let* to handle multiple values, it also handles
+ type declarations. The declarations list @arg{vars} is similar to that in let: look
+ at the below examples.
+
+ Examples:
+ @lisp
+ > (macroexpand-1
+ `(mlet* ((x 2 :type fixnum :declare ((optimize (safety 0) (speed 3))))
+ ((a b) (floor 3) :type (nil fixnum)))
+ (+ 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)))
+ @end lisp
+ "
+ (labels ((mlet-decl (vars type decls)
+ (when (or type decls)
+ `((declare ,@decls
+ ,@(when type
+ (mapcar #'(lambda (tv) (if (null (first tv))
+ `(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
+ ;;If there is only one element use let
+ ;;instead of multiple-value-bind
+ ((or (symbolp vars))
+ `(let ((,vars ,form))))
+ (t
+ `(multiple-value-bind (,@vars) ,form)))
+ (if (symbolp vars)
+ (mlet-decl (list vars) (when type (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 vars
+ (car (mlet-walk vars body))
+ `(progn
+ ,@body))))
+
+(defmacro let-typed (bindings &rest body)
+ "
+ This macro works basically like let, but also allows type-declarations
+ with the key :type.
+
+ Example:
+ @lisp
+ > (macroexpand-1
+ `(let-typed ((x 1 :type fixnum))
+ ...
[truncated message content] |
