Menu
▾
▴
[Matlisp-commit] [matlisp-git]matlisp branch tensor updated. 2012-02-23-91-g8bb55ab
|
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
|
