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. ;; Foreign callback functions.
;; Liam Healy ;; Liam Healy
;; Time-stamp: <2009-01-25 19:21:02EST callback.lisp> ;; Time-stamp: <2009-02-02 11:33:32EST callback.lisp>
;; $Id$ ;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -269,3 +269,32 @@ ...@@ -269,3 +269,32 @@
structure structure
`((defcbstruct ,cbsymb ,structure `((defcbstruct ,cbsymb ,structure
,(if dim `((dimensions ,dim)))))))))) ,(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. ;; Definition of GSL objects and ways to use them.
;; Liam Healy, Sun Dec 3 2006 - 10:21 ;; 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. ;;; GSL objects are represented in GSLL as and instance of a 'mobject.
;;; The macro demobject takes care of defining the appropriate ;;; The macro demobject takes care of defining the appropriate
...@@ -23,6 +23,7 @@ ...@@ -23,6 +23,7 @@
(class prefix allocation-args description (class prefix allocation-args description
&key documentation initialize-suffix initialize-name initialize-args &key documentation initialize-suffix initialize-name initialize-args
arglists-function inputs gsl-version allocator allocate-inputs freer arglists-function inputs gsl-version allocator allocate-inputs freer
;;callbacks
(superclasses '(mobject))) (superclasses '(mobject)))
"Define the class, the allocate, initialize-instance and "Define the class, the allocate, initialize-instance and
reinitialize-instance methods, and the make-* function for the GSL object." reinitialize-instance methods, and the make-* function for the GSL object."
...@@ -55,80 +56,102 @@ ...@@ -55,80 +56,102 @@
:c-return :pointer :c-return :pointer
:index ,maker) :index ,maker)
(defmethod initialize-instance :after ,(make-initialize-instance
((object ,class) &key mpointer ,@(union cl-alloc-args cl-initialize-args)) class cl-alloc-args cl-initialize-args prefix freer)
,@(let ((not-alloc (set-difference cl-initialize-args cl-alloc-args)))
(when not-alloc)
`((declare (ignore ,@not-alloc))))
(unless mpointer
(setf mpointer
(allocate object ,@(symbol-keyword-symbol cl-alloc-args))
(slot-value object 'mpointer) mpointer))
(tg:finalize object
(lambda ()
(cffi:foreign-funcall
,(or freer (format nil "~a_free" prefix))
:pointer mpointer :void))))
,@(when initializerp ,@(when initializerp
`((defmfun reinitialize-instance (make-reinitialize-instance
((object ,class) &key ,@cl-initialize-args) class cl-initialize-args initialize-name prefix
,(or initialize-name initialize-suffix initialize-args inputs))
(format nil "~a_~a" prefix
(if (listp initialize-suffix)
(first initialize-suffix)
initialize-suffix)))
(((mpointer object) :pointer) ,@initialize-args)
:definition :method
:qualifier :after
,@(when (and initialize-suffix (listp initialize-suffix))
`(:c-return ,(second initialize-suffix)))
:return (object)
,@(when inputs `(:inputs ,inputs))
:export nil
:index (reinitialize-instance ,class))))
(export ',maker) (export ',maker)
(defun ,maker ,(mobject-maker
,(if arglists maker arglists initargs class cl-alloc-args cl-initialize-args
(first arglists) description documentation initialize-args initializerp settingp))
`(,@cl-alloc-args `(progn
,@(when initargs (export ',maker)
(append (defun ,maker (&rest args)
(list (declare (ignore args))
'&optional (list (first initargs) nil settingp)) (error 'obsolete-gsl-version
(rest initargs))))) :name ',class :gsl-name ,prefix
,(format :gsl-version ',gsl-version))))))
nil "Create the GSL object representing a ~a (class ~a).~@[~&~a~]"
description class documentation) (defun make-initialize-instance
(let ((object (class cl-alloc-args cl-initialize-args prefix freer)
(make-instance `(defmethod initialize-instance :after
',class ((object ,class) &key mpointer ,@(union cl-alloc-args cl-initialize-args))
,@(if arglists ,@(let ((not-alloc (set-difference cl-initialize-args cl-alloc-args)))
(second arglists) (when not-alloc)
(symbol-keyword-symbol cl-alloc-args))))) `((declare (ignore ,@not-alloc))))
;; There is an initialization step (unless mpointer
,@(when initializerp (setf mpointer
(if initialize-args ; with arguments (allocate object ,@(symbol-keyword-symbol cl-alloc-args))
(if initargs (slot-value object 'mpointer) mpointer))
`((when ,settingp (tg:finalize object
(reinitialize-instance (lambda ()
object (cffi:foreign-funcall
,@(if arglists ,(or freer (format nil "~a_free" prefix))
(third arglists) :pointer mpointer :void)))))
(symbol-keyword-symbol cl-initialize-args)))))
`((reinitialize-instance (defun make-reinitialize-instance
object (class cl-initialize-args initialize-name prefix
,@(if arglists initialize-suffix initialize-args inputs)
(third arglists) `((defmfun reinitialize-instance
(symbol-keyword-symbol cl-initialize-args))))) ((object ,class) &key ,@cl-initialize-args)
'((reinitialize-instance object)))) ; without arguments ,(or initialize-name
object))) (format nil "~a_~a" prefix
`(defun ,maker (&rest args) (if (listp initialize-suffix)
(declare (ignore args)) (first initialize-suffix)
(error 'obsolete-gsl-version initialize-suffix)))
:name ',class :gsl-name ,prefix (((mpointer object) :pointer) ,@initialize-args)
:gsl-version ',gsl-version))))) :definition :method
:qualifier :after
,@(when (and initialize-suffix (listp initialize-suffix))
`(:c-return ,(second initialize-suffix)))
:return (object)
,@(when inputs `(:inputs ,inputs))
:export nil
:index (reinitialize-instance ,class))))
(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
,@(when initargs
(append
(list
'&optional (list (first initargs) nil settingp))
(rest initargs)))))
,(format
nil "Create the GSL object representing a ~a (class ~a).~@[~&~a~]"
description class documentation)
(let ((object
(make-instance
',class
,@(if arglists
(second arglists)
(symbol-keyword-symbol cl-alloc-args)))))
;; There is an initialization step
,@(when initializerp
(if initialize-args ; with arguments
(if initargs
`((when ,settingp
(reinitialize-instance
object
,@(if arglists
(third arglists)
(symbol-keyword-symbol cl-initialize-args)))))
`((reinitialize-instance
object
,@(if arglists
(third arglists)
(symbol-keyword-symbol cl-initialize-args)))))
'((reinitialize-instance object)))) ; without arguments
object)))
(defun symbol-keyword-symbol (symbol) (defun symbol-keyword-symbol (symbol)
(if (listp symbol) (if (listp symbol)
......
;;; Multivariate roots. ;;; Multivariate roots.
;;; Liam Healy 2008-01-12 12:49:08 ;;; 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$ ;;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -354,7 +354,7 @@ ...@@ -354,7 +354,7 @@
(defparameter *rosenbrock-a* 1.0d0) (defparameter *rosenbrock-a* 1.0d0)
(defparameter *rosenbrock-b* 10.0d0) (defparameter *rosenbrock-b* 10.0d0)
(defun rosenbrock (arg0 arg1) (defun* rosenbrock (arg0 arg1) (2 2)
"Rosenbrock test function." "Rosenbrock test function."
(values (values
(* *rosenbrock-a* (- 1 arg0)) (* *rosenbrock-a* (- 1 arg0))
...@@ -395,7 +395,8 @@ ...@@ -395,7 +395,8 @@
(maref fnval 0) (maref fnval 0)
(maref fnval 1)))))) (maref fnval 1))))))
(defun rosenbrock-df (arg0 arg1) (defun* rosenbrock-df (arg0 arg1)
(2 (2 2))
"The partial derivatives of the Rosenbrock functions." "The partial derivatives of the Rosenbrock functions."
(declare (ignore arg1)) (declare (ignore arg1))
(values (- *rosenbrock-a*) (values (- *rosenbrock-a*)
...@@ -415,7 +416,8 @@ ...@@ -415,7 +416,8 @@
(defparameter *solver-df-cb* (defparameter *solver-df-cb*
(make-solver-functions rosenbrock rosenbrock-df rosenbrock-fdf 2)) (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 "Solving Rosenbrock with derivatives, the example given in Sec. 34.8
of the GSL manual." of the GSL manual."
(flet ((print-state (iter argval fnval) (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