Skip to content
Snippets Groups Projects
Commit 3cf4781e authored by Liam Healy's avatar Liam Healy
Browse files

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
No related branches found
No related tags found
No related merge requests found
;; 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
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment