Commit 7b9eb8c5 authored by Liam Healy's avatar Liam Healy

Split up definition of defmobject, add definition of defun*

The definition of defmobject has become too large so the parts that
are responsible for construction of the various functions are broken
out as functions:
  make-initialize-instance
  make-reinitialize-instance
  mobject-maker

The definition of callbacks for GSL will be changed so that the
callback function (defmcallback) is defined at the time the function
is defined, and the callback GSL structure is made (defcbstruct) at
the time the corresponding defmobject is made, along with a freeing
function to add to the finalizers.  (For callbacks used in functions
without mobjects, the struct will be allocated before and then freed
after the call.)  As a first step toward this organization, defun* is
defined to handle in one form the definition of a CL function and of a
callback.
parent cbcc15dd
;; Foreign callback functions.
;; Liam Healy
;; Time-stamp: <2009-01-25 19:21:02EST callback.lisp>
;; Time-stamp: <2009-02-02 11:33:32EST callback.lisp>
;; $Id$
(in-package :gsl)
......@@ -269,3 +269,32 @@
structure
`((defcbstruct ,cbsymb ,structure
,(if dim `((dimensions ,dim))))))))))
(defun cbname-for-marrays (name)
(intern (format nil "~a-~a" name "MARRAY")))
(defun cbname-for-cvectors (name)
(intern (format nil "~a-~a" name "CVECTOR")))
(defmacro defun*
(name args (dimensions-in dimensions-out) &body body)
"Define a function as with a defun, and make a callback for it so
that it can be sent to GSL."
(let ((dimin (if (listp dimensions-in) dimensions-in (list dimensions-in)))
(dimout (if (listp dimensions-out) dimensions-out (list dimensions-out))))
`(progn
(defun ,name ,args ,@body)
,@(if dimensions-in
`((defmcallback ,(cbname-for-marrays name)
:success-failure
((:double ,@dimin))
((:set :double ,@dimout))
t
,name)
(defmcallback ,(cbname-for-cvectors name)
:success-failure
((:double ,@dimin))
((:set :double ,@dimout))
nil
,name))
`((defmcallback ,name :success-failure :pointer :pointer))))))
;; Definition of GSL objects and ways to use them.
;; Liam Healy, Sun Dec 3 2006 - 10:21
;; Time-stamp: <2009-01-28 19:19:54EST mobject.lisp>
;; Time-stamp: <2009-02-02 11:26:12EST mobject.lisp>
;;; GSL objects are represented in GSLL as and instance of a 'mobject.
;;; The macro demobject takes care of defining the appropriate
......@@ -23,6 +23,7 @@
(class prefix allocation-args description
&key documentation initialize-suffix initialize-name initialize-args
arglists-function inputs gsl-version allocator allocate-inputs freer
;;callbacks
(superclasses '(mobject)))
"Define the class, the allocate, initialize-instance and
reinitialize-instance methods, and the make-* function for the GSL object."
......@@ -55,7 +56,27 @@
:c-return :pointer
:index ,maker)
(defmethod initialize-instance :after
,(make-initialize-instance
class cl-alloc-args cl-initialize-args prefix freer)
,@(when initializerp
(make-reinitialize-instance
class cl-initialize-args initialize-name prefix
initialize-suffix initialize-args inputs))
(export ',maker)
,(mobject-maker
maker arglists initargs class cl-alloc-args cl-initialize-args
description documentation initialize-args initializerp settingp))
`(progn
(export ',maker)
(defun ,maker (&rest args)
(declare (ignore args))
(error 'obsolete-gsl-version
:name ',class :gsl-name ,prefix
:gsl-version ',gsl-version))))))
(defun make-initialize-instance
(class cl-alloc-args cl-initialize-args prefix freer)
`(defmethod initialize-instance :after
((object ,class) &key mpointer ,@(union cl-alloc-args cl-initialize-args))
,@(let ((not-alloc (set-difference cl-initialize-args cl-alloc-args)))
(when not-alloc)
......@@ -68,9 +89,11 @@
(lambda ()
(cffi:foreign-funcall
,(or freer (format nil "~a_free" prefix))
:pointer mpointer :void))))
:pointer mpointer :void)))))
,@(when initializerp
(defun make-reinitialize-instance
(class cl-initialize-args initialize-name prefix
initialize-suffix initialize-args inputs)
`((defmfun reinitialize-instance
((object ,class) &key ,@cl-initialize-args)
,(or initialize-name
......@@ -88,8 +111,12 @@
:export nil
:index (reinitialize-instance ,class))))
(export ',maker)
(defun ,maker
(defun mobject-maker
(maker arglists initargs class cl-alloc-args cl-initialize-args
description documentation initialize-args initializerp settingp)
"Make the defun form that makes the mobject."
`(defun ,maker
,(if arglists
(first arglists)
`(,@cl-alloc-args
......@@ -124,11 +151,7 @@
(symbol-keyword-symbol cl-initialize-args)))))
'((reinitialize-instance object)))) ; without arguments
object)))
`(defun ,maker (&rest args)
(declare (ignore args))
(error 'obsolete-gsl-version
:name ',class :gsl-name ,prefix
:gsl-version ',gsl-version)))))
(defun symbol-keyword-symbol (symbol)
(if (listp symbol)
......
;;; Multivariate roots.
;;; Liam Healy 2008-01-12 12:49:08
;;; Time-stamp: <2009-01-26 21:45:23EST roots-multi.lisp>
;;; Time-stamp: <2009-02-02 11:27:16EST roots-multi.lisp>
;;; $Id$
(in-package :gsl)
......@@ -354,7 +354,7 @@
(defparameter *rosenbrock-a* 1.0d0)
(defparameter *rosenbrock-b* 10.0d0)
(defun rosenbrock (arg0 arg1)
(defun* rosenbrock (arg0 arg1) (2 2)
"Rosenbrock test function."
(values
(* *rosenbrock-a* (- 1 arg0))
......@@ -395,7 +395,8 @@
(maref fnval 0)
(maref fnval 1))))))
(defun rosenbrock-df (arg0 arg1)
(defun* rosenbrock-df (arg0 arg1)
(2 (2 2))
"The partial derivatives of the Rosenbrock functions."
(declare (ignore arg1))
(values (- *rosenbrock-a*)
......@@ -415,7 +416,8 @@
(defparameter *solver-df-cb*
(make-solver-functions rosenbrock rosenbrock-df rosenbrock-fdf 2))
(defun roots-multi-example-derivative (&optional (method *gnewton-mfdfsolver*) (print-steps t))
(defun roots-multi-example-derivative
(&optional (method *gnewton-mfdfsolver*) (print-steps t))
"Solving Rosenbrock with derivatives, the example given in Sec. 34.8
of the GSL manual."
(flet ((print-state (iter argval fnval)
......
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