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