Commit 3cf4781e authored by Liam Healy's avatar Liam Healy

Maref and (setf maref) for GSL vector pointers; optional arguments in :method

The generic function #'maref will work on foreign pointers and assume
them to be pointing to either a gsl-vector-c or a gsl-matrix-c,
depending on how many indices are given.  This then functions like the
old #'vref and #'mref.  It is used in the new function
#'make-vector-from-gsl which creates a CL vector (using make-array*)
which is needed by several functions in solve-minimize-fit.  It is
also useful in the callbacks a user would define for
solve-minimize-fit functions.  Similar functionality added to (setf
aref) which was turned into a generic function.

As part of the changes needed to define these methods, the defmfun
family was modified to accept optional arguments in
#'expand-defmfun-method, which is invoked when :definition :method is
given.  Functions with optional arguments fall into two categories as
far as defmfun is concerned: those that correspond to multiple GSL
functions, and those that don't.  This should work in both cases.
parent 694552b3
;; Data using ffa
;; Liam Healy 2008-04-06 21:23:41EDT data-ffa.lisp
;; Time-stamp: <2008-08-21 21:05:36EDT data.lisp>
;; Time-stamp: <2008-08-23 17:42:15EDT data.lisp>
;; $Id$
(in-package :gsl)
......@@ -50,6 +50,10 @@
"The first dimension of the object."
(first (dimensions object)))
(defun dim1 (object)
"The first dimension of the object."
(second (dimensions object)))
(defun element-size (object)
"The size of each element as stored in C."
(cffi:foreign-type-size (cl-ffa (element-type object))))
......@@ -280,19 +284,51 @@
(cffi:mem-aref pointer cffi-type pointer-index)
(cffi:mem-aref pointer cffi-type (1+ pointer-index)))))))
(defgeneric maref (object &rest indices)
(defgeneric maref (object index &optional index2)
(:documentation "An element of the data.")
(:method ((object gsl-data) &rest indices)
(:method ((object gsl-data) index &optional index2)
(copy-c-to-cl object)
(apply 'aref (cl-array object) indices)))
(if index2
(aref (cl-array object) index index2)
(aref (cl-array object) index))))
;;; Alternative to complete copy is to mark which elements have
;;; changed and just copy them. Is it worth it?
(defun (setf maref) (value object &rest indices)
"Set an element of the data."
(apply '(setf aref) value (cl-array object) indices)
#-native
(setf c-invalid t))
(defgeneric (setf maref) (value object index &optional index2)
(:documentation "Set an element of the data.")
(:method (value (object gsl-data) index &optional index2)
(if index2
(setf (aref (cl-array object) index index2) value)
(setf (aref (cl-array object) index) value))
#-native
(setf c-invalid t)))
;;; It is necessary to have access to elements from the GSL
;;; vector/matrix pointers for things like callback functions in
;;; solve-minimize-fit and in #'make-vector-from-gsl.
(defmfun maref ((pointer #.(class-name (class-of (cffi:null-pointer))))
index &optional index2)
;; If passed a pointer, assume that it is a GSL vector or matrix,
;; depending on the number of indices. This is useful in the
;; callback functions for solve-minimize-fit.
("gsl_vector_get" "gsl_matrix_get")
(((pointer :pointer) (index sizet))
((pointer :pointer) (index sizet) (index2 sizet)))
:definition :method
:c-return :double)
(defmfun (setf maref)
(value (pointer #.(class-name (class-of (cffi:null-pointer))))
index &optional index2)
;; If passed a pointer, assume that it is a GSL vector or matrix,
;; depending on the number of indices. This is useful in the
;; callback functions for solve-minimize-fit.
("gsl_vector_set" "gsl_matrix_set")
(((pointer :pointer) (index sizet) (value :double))
((pointer :pointer) (index sizet) (index2 sizet) (value :double)))
:definition :method
:c-return :double)
;;;;****************************************************************************
;;;; C structures
......
;; Vectors
;; Liam Healy 2008-04-13 09:39:02EDT vector-ffa.lisp
;; Time-stamp: <2008-06-30 22:53:27EDT vector.lisp>
;; Time-stamp: <2008-08-23 17:51:33EDT vector.lisp>
;; $Id$
(in-package :gsl)
......@@ -24,6 +24,37 @@
;;; Define all the mvector subclasses that are supported by FFA
#.(data-defclass 'vector 'mvector)
(defun make-vector-from-pointer ())
;;;;****************************************************************************
;;;; Make from GSL vector
;;;;****************************************************************************
;;; Some functions in solve-minimize-fit return a pointer to a GSL
;;; vector with double-floats. The functions here turn that into a
;;; foreign-friendly array. There is no choice but to copy over the
;;; data; because GSL is doing the mallocing, the data are not
;;; CL-accessible.
(defmfun free-vector (pointer)
"gsl_vector_free"
((pointer :pointer))
:index nil
:export nil
:c-return :void)
(defun make-vector-from-gsl (pointer)
"Given a C pointer to a GSL vector, make the CL object."
(let* ((size (cffi:foreign-slot-value pointer 'gsl-vector-c 'size))
(array (make-array* size 'double-float)))
;; Copy over from the C side
(loop for i below size
do (setf (aref array i) (maref pointer i)))
;; Free the C/GSL vector
(free-vector pointer)
;; Return the CL array
array))
;;;;****************************************************************************
;;;; Function definitions
;;;;****************************************************************************
......
;; Macro for defining GSL functions.
;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp
;; Time-stamp: <2008-08-20 21:05:54EDT defmfun.lisp>
;; Time-stamp: <2008-08-23 18:37:25EDT defmfun.lisp>
;; $Id$
(in-package :gsl)
......@@ -275,8 +275,7 @@
(actual-element-c-type eltype args))
c-arguments)
key-args
'body-optional-arg
t)
'body-optional-arg)
(complete-definition
defn
(if (eq defn :method) (list nil name) name)
......@@ -405,22 +404,29 @@
;;; (MATRIX VECTOR)
;;;;****************************************************************************
;;;; A method for a generic function
;;;; A method for a generic function, on any class
;;;;****************************************************************************
(defun expand-defmfun-method (name arglist gsl-name c-arguments key-args)
"Create a specific method for a previously-defined generic function."
(with-defmfun-key-args key-args
(remf key-args :documentation)
(complete-definition
'cl:defmethod
name
arglist
(progn
(push gsl-name indexed-functions)
gsl-name)
c-arguments
key-args)))
(if (listp gsl-name)
(mapc (lambda (n) (push n indexed-functions)) gsl-name)
(push gsl-name indexed-functions))
(with-defmfun-key-args key-args
(remf key-args :documentation)
(complete-definition
'cl:defmethod
name
arglist
gsl-name
c-arguments
key-args
(if (and (llkp arglist) (listp gsl-name))
;; Even though it might have optional arguments, if there
;; is only one GSL function, we use 'body-no-optional-arg.
'body-optional-arg 'body-no-optional-arg)
(listp gsl-name)))))
;;;;****************************************************************************
;;;; Optional argument(s)
......@@ -493,7 +499,9 @@
(defun complete-definition
(definition name arglist gsl-name c-arguments key-args
&optional (body-maker 'body-no-optional-arg) mapdown)
&optional
(body-maker 'body-no-optional-arg)
(mapdown (eq body-maker 'body-optional-arg)))
"A complete definition form, starting with defun, :method, or defmethod."
(destructuring-bind
(&key documentation &allow-other-keys) key-args
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment