Commit 6b35d063 authored by Liam Healy's avatar Liam Healy

New macro #'def-make-callbacks

New macro #'def-make-callbacks will expand to the appropriate
defmethod for make-callback-fn, so that the defmcallbacks are defined
appropriately.
parent d70406ec
;; Foreign callback functions.
;; Liam Healy
;; Time-stamp: <2009-02-08 17:39:32EST callback.lisp>
;; Time-stamp: <2009-02-08 22:21:59EST callback.lisp>
;; $Id$
(in-package :gsl)
......@@ -328,6 +328,15 @@
(defgeneric make-callbacks-fn (class args)
(:documentation "Function to make forms that expand into defmcallback(s)."))
(defmacro def-make-callbacks (class arglist &body body)
(with-unique-names (cls args)
`(eval-when (:compile-toplevel :load-toplevel)
(defmethod make-callbacks-fn
((,cls (eql ',class)) ,args)
(declare (ignore ,cls))
(destructuring-bind ,arglist ,args
,@body)))))
(export 'make-callbacks)
(defmacro make-callbacks (class &rest args)
"Make the callbacks for the named class. The args are generally of the form
......
;; Univariate minimization
;; Liam Healy Tue Jan 8 2008 - 21:02
;; Time-stamp: <2009-02-08 18:53:13EST minimization-one.lisp>
;; Time-stamp: <2009-02-08 22:20:42EST minimization-one.lisp>
;; $Id$
(in-package :gsl)
......@@ -31,17 +31,12 @@
(:type type)
(:functions (list function) :minimum minimum :lower lower :upper upper))))
(eval-when (:compile-toplevel :load-toplevel)
(defmethod make-callbacks-fn
((class (eql 'one-dimensional-minimizer)) args)
;; This is "make-single-function"
(declare (ignore class))
(destructuring-bind (function) args
(def-make-callbacks one-dimensional-minimizer (function)
`(defmcallback ,function
:double :double
nil
t
,function))))
,function))
(defmfun set-fminimizer-with-values
(minimizer function x-minimum x-lower x-upper
......
;;; Multivariate roots.
;;; Liam Healy 2008-01-12 12:49:08
;;; Time-stamp: <2009-02-07 17:17:58EST roots-multi.lisp>
;;; Time-stamp: <2009-02-08 22:56:14EST roots-multi.lisp>
;;; $Id$
(in-package :gsl)
......@@ -38,11 +38,8 @@
(:functions (list function-or-dimension) :initial initial)))
:inputs (initial))
(eval-when (:compile-toplevel :load-toplevel)
(defmethod make-callbacks-fn
((class (eql 'multi-dimensional-root-solver-f)) args)
(declare (ignore class))
(destructuring-bind (function dimension &optional (scalars t)) args
(def-make-callbacks
multi-dimensional-root-solver-f (function dimension &optional (scalars t))
(if scalars
`(defmcallback ,function
:success-failure
......@@ -53,7 +50,7 @@
:success-failure
(:pointer) (:pointer)
T
,function)))))
,function)))
(defmobject multi-dimensional-root-solver-fdf "gsl_multiroot_fdfsolver"
((type :pointer) ((first dimensions) sizet))
......@@ -76,11 +73,9 @@
(:functions function-or-dimension :initial initial)))
:inputs (initial))
(eval-when (:compile-toplevel :load-toplevel)
(defmethod make-callbacks-fn
((class (eql 'multi-dimensional-root-solver-fdf)) args)
(declare (ignore class))
(destructuring-bind (function df fdf dimension &optional (array t)) args
(def-make-callbacks
multi-dimensional-root-solver-fdf
(function df fdf dimension &optional (array t))
`(progn
(defmcallback ,function
:success-failure
......@@ -97,7 +92,7 @@
((:double ,dimension))
((:set :double ,dimension) (:set :double ,dimension ,dimension))
,array
,fdf)))))
,fdf)))
(defmfun name ((solver multi-dimensional-root-solver-f))
"gsl_multiroot_fsolver_name"
......
;; One-dimensional root solver.
;; Liam Healy
;; Time-stamp: <2009-02-08 18:35:44EST roots-one.lisp>
;; Time-stamp: <2009-02-08 22:18:24EST roots-one.lisp>
;; $Id$
(in-package :gsl)
......@@ -24,17 +24,12 @@
(:type type)
(:functions (list function) :lower lower :upper upper))))
(eval-when (:compile-toplevel :load-toplevel)
(defmethod make-callbacks-fn
((class (eql 'one-dimensional-root-solver-f)) args)
;; This is "make-single-function"
(declare (ignore class))
(destructuring-bind (function) args
(def-make-callbacks one-dimensional-root-solver-f (function)
`(defmcallback ,function
:double :double
nil
t
,function))))
,function))
(defmobject one-dimensional-root-solver-fdf "gsl_root_fdfsolver"
((type :pointer))
......@@ -44,12 +39,7 @@
:initialize-suffix "set"
:initialize-args ((callback :pointer) (root-guess :double)))
(eval-when (:compile-toplevel :load-toplevel)
(defmethod make-callbacks-fn
((class (eql 'one-dimensional-root-solver-fdf)) args)
;; This is "make-solver-functions"
(declare (ignore class))
(destructuring-bind (function df fdf) args
(def-make-callbacks one-dimensional-root-solver-fdf (function df fdf)
`(progn
(defmcallback ,function
:double :double
......@@ -64,7 +54,7 @@
(defmcallback ,fdf
:void :double ((:set :double 1) (:set :double 1))
nil
,fdf)))))
,fdf)))
(defmfun name ((solver one-dimensional-root-solver-f))
"gsl_root_fsolver_name"
......
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