From 86da4ec7d19bf755f9b6390ea2e6f65b886c5b70 Mon Sep 17 00:00:00 2001 From: Liam Healy <liam@thinkpad.local> Date: Mon, 26 Jan 2009 22:09:11 -0500 Subject: [PATCH] Non-native and :callback-toplevel-only fixes Fixed several bugs that affected non-native implementations, where :inputs, :outputs, or both were not properly declared. According to the CFFI manual, "Portability note: defcallback will not work correctly on some Lisps if it's not a top-level form." Evidently, this includes Clozure CL, so a new symbol :callback-toplevel-only has been pushed onto *features* if openmcl. This changes examples with callbacks to define the callbacks in a separate defparameter rather than in-line when the mobject is made of the function is called. As a result of both these changes, the only errors left in CCL tests were ones seen previously. CCL 64: TOTAL: 1259 assertions passed, 3 failed, 0 execution errors. SBCL 64: TOTAL: 1257 assertions passed, 5 failed, 0 execution errors. --- init/init.lisp | 6 +++++- .../evolution.lisp | 4 +++- .../ode-example.lisp | 10 ++++++++-- series-acceleration.lisp | 4 +++- solve-minimize-fit/minimization-multi.lisp | 17 ++++++++++++++++- solve-minimize-fit/minimization-one.lisp | 8 ++++++-- .../nonlinear-least-squares.lisp | 16 ++++++++++++---- solve-minimize-fit/roots-multi.lisp | 17 +++++++++++++++-- solve-minimize-fit/roots-one.lisp | 19 +++++++++++++++++-- test-unit/additional-definitions.lisp | 12 ++++-------- 10 files changed, 89 insertions(+), 24 deletions(-) diff --git a/init/init.lisp b/init/init.lisp index 6a59273a..0c606ffa 100644 --- a/init/init.lisp +++ b/init/init.lisp @@ -1,6 +1,6 @@ ;; Load GSL ;; Liam Healy Sat Mar 4 2006 - 18:53 -;; Time-stamp: <2009-01-24 18:07:19EST init.lisp> +;; Time-stamp: <2009-01-26 21:39:39EST init.lisp> ;; $Id$ (defpackage gsll @@ -39,6 +39,10 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (pushnew :native *features*)) +#+openmcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (pushnew :callback-toplevel-only *features*)) + ;;; CFFI currently doesn't allow uninterned callback names for CCL; ;;; patch here. diff --git a/ordinary-differential-equations/evolution.lisp b/ordinary-differential-equations/evolution.lisp index 2d8832b5..0b1101cc 100644 --- a/ordinary-differential-equations/evolution.lisp +++ b/ordinary-differential-equations/evolution.lisp @@ -1,6 +1,6 @@ ;; Evolution functions for ODE integration. ;; Liam Healy, Sun Sep 30 2007 - 14:31 -;; Time-stamp: <2009-01-25 17:52:45EST evolution.lisp> +;; Time-stamp: <2009-01-26 21:25:15EST evolution.lisp> ;; $Id$ (in-package :gsl) @@ -21,6 +21,8 @@ (dydt :pointer) ((c-pointer time) :pointer) (max-time :double) ((c-pointer step-size) :pointer) ((c-pointer y) :pointer)) + :inputs (time step-size y) + :outputs (time step-size y) :documentation ; FDL "Advance the system (e, dydt) from time and position y using the stepping function step. diff --git a/ordinary-differential-equations/ode-example.lisp b/ordinary-differential-equations/ode-example.lisp index e9724c10..383ff2ed 100644 --- a/ordinary-differential-equations/ode-example.lisp +++ b/ordinary-differential-equations/ode-example.lisp @@ -1,6 +1,6 @@ ;; Example ODE ;; Liam Healy Sat Sep 29 2007 - 17:49 -;; Time-stamp: <2009-01-25 19:15:39EST ode-example.lisp> +;; Time-stamp: <2009-01-26 21:45:43EST ode-example.lisp> ;; $Id$ ;;; van der Pol as given in Section 25.5 of the GSL manual. To @@ -26,6 +26,10 @@ (defparameter *max-iter* 2000) +#+callback-toplevel-only +(defparameter *vanderpol-cb* + (make-ode-functions vanderpol vanderpol-jacobian 2)) + (defun integrate-vanderpol (max-time &optional (step-size 1.0d-6) (stepper *step-rk8pd*) (print-steps t)) "Integrate the van der Pol oscillator as given in Section 25.5 of the @@ -33,7 +37,9 @@ (let ((mu 10.0d0) (initial-time 0.0d0) (iter 0)) (declare (special mu)) (with-ode-integration - ((make-ode-functions vanderpol vanderpol-jacobian 2) + (#-callback-toplevel-only + (make-ode-functions vanderpol vanderpol-jacobian 2) + #+callback-toplevel-only *vanderpol-cb* time step max-time (dep0 dep1) 2 stepper) (setf dep0 1.0d0 dep1 0.0d0 step step-size time initial-time) (loop diff --git a/series-acceleration.lisp b/series-acceleration.lisp index 6474bb6a..b5ea3abf 100644 --- a/series-acceleration.lisp +++ b/series-acceleration.lisp @@ -1,6 +1,6 @@ ;; Series acceleration. ;; Liam Healy, Wed Nov 21 2007 - 18:41 -;; Time-stamp: <2009-01-25 10:12:17EST series-acceleration.lisp> +;; Time-stamp: <2009-01-26 21:31:38EST series-acceleration.lisp> ;; $Id$ (in-package :gsl) @@ -37,6 +37,7 @@ "gsl_sum_levin_u_accel" (((c-pointer array) :pointer) ((dim0 array) sizet) ((mpointer levin) :pointer) (accelerated-sum :double) (absolute-error :double)) + :inputs (array) :documentation ; FDL "From the terms of a series in array, compute the extrapolated limit of the series using a Levin u-transform. Additional @@ -64,6 +65,7 @@ "gsl_sum_levin_utrunc_accel" (((c-pointer array) :pointer) ((dim0 array) sizet) ((mpointer levin) :pointer) (accelerated-sum :double) (absolute-error :double)) + :inputs (array) :documentation ; FDL "From the terms of a series in array, compute the extrapolated limit of the series using a Levin u-transform. Additional diff --git a/solve-minimize-fit/minimization-multi.lisp b/solve-minimize-fit/minimization-multi.lisp index 5a2f6c17..e38b0253 100644 --- a/solve-minimize-fit/minimization-multi.lisp +++ b/solve-minimize-fit/minimization-multi.lisp @@ -1,6 +1,6 @@ ;; Multivariate minimization. ;; Liam Healy <Tue Jan 8 2008 - 21:28> -;; Time-stamp: <2009-01-25 10:09:46EST minimization-multi.lisp> +;; Time-stamp: <2009-01-26 21:55:26EST minimization-multi.lisp> ;; $Id$ (in-package :gsl) @@ -191,6 +191,7 @@ (defmfun min-test-gradient (gradient absolute-error) "gsl_multimin_test_gradient" (((mpointer gradient) :pointer) (absolute-error :double)) + :inputs (gradient) :c-return :success-continue :documentation ; FDL "Test the norm of the gradient against the @@ -319,15 +320,23 @@ (parabaloid-derivative arguments-gv-pointer derivative-gv-pointer))) +#+callback-toplevel-only +(defparameter *minmultidf-cb* + (make-minimization-functions + parabaloid-vector 2 + parabaloid-derivative parabaloid-and-derivative t)) + (defun multimin-example-derivative (&optional (method *conjugate-fletcher-reeves*) (print-steps t)) (let* ((initial #m(5.0d0 7.0d0)) (minimizer (make-multi-dimensional-minimizer-fdf method 2 + #-callback-toplevel-only (make-minimization-functions parabaloid-vector 2 parabaloid-derivative parabaloid-and-derivative t) + #+callback-toplevel-only *minmultidf-cb* initial 0.01d0 1.0d-4))) (loop with status = T for iter from 0 below 100 @@ -360,6 +369,10 @@ (* 20 (expt (- y dp1) 2)) 30))) +#+callback-toplevel-only +(defparameter *minmulti-cb* + (make-minimization-functions parabaloid-scalar 2)) + (defun multimin-example-no-derivative (&optional (method *simplex-nelder-mead*) (print-steps t)) (let ((step-size (make-marray 'double-float :dimensions 2))) @@ -367,7 +380,9 @@ (let ((minimizer (make-multi-dimensional-minimizer-f method 2 + #-callback-toplevel-only (make-minimization-functions parabaloid-scalar 2) + #+callback-toplevel-only *minmulti-cb* #m(5.0d0 7.0d0) step-size))) (loop with status = T and size for iter from 0 below 100 diff --git a/solve-minimize-fit/minimization-one.lisp b/solve-minimize-fit/minimization-one.lisp index bb1c6445..7de2394f 100644 --- a/solve-minimize-fit/minimization-one.lisp +++ b/solve-minimize-fit/minimization-one.lisp @@ -1,6 +1,6 @@ ;; Univariate minimization ;; Liam Healy Tue Jan 8 2008 - 21:02 -;; Time-stamp: <2009-01-25 10:07:59EST minimization-one.lisp> +;; Time-stamp: <2009-01-26 21:40:02EST minimization-one.lisp> ;; $Id$ (in-package :gsl) @@ -180,6 +180,9 @@ (defun minimization-one-fn (x) (1+ (cos x))) +#+callback-toplevel-only +(defparameter *minone-cb* (make-single-function minimization-one-fn)) + (defun minimization-one-example (&optional (minimizer-type *brent-fminimizer*) (print-steps t)) "Solving a minimum, the example given in Sec. 33.8 of the GSL manual." @@ -187,7 +190,8 @@ (minimizer (make-one-dimensional-minimizer minimizer-type - (make-single-function minimization-one-fn) + #-callback-toplevel-only (make-single-function minimization-one-fn) + #+callback-toplevel-only *minone-cb* 2.0d0 0.0d0 6.0d0))) (when print-steps (format diff --git a/solve-minimize-fit/nonlinear-least-squares.lisp b/solve-minimize-fit/nonlinear-least-squares.lisp index 7f2aa954..07bde585 100644 --- a/solve-minimize-fit/nonlinear-least-squares.lisp +++ b/solve-minimize-fit/nonlinear-least-squares.lisp @@ -1,6 +1,6 @@ ;; Nonlinear least squares fitting. ;; Liam Healy, 2008-02-09 12:59:16EST nonlinear-least-squares.lisp -;; Time-stamp: <2009-01-25 10:11:21EST nonlinear-least-squares.lisp> +;; Time-stamp: <2009-01-26 21:43:22EST nonlinear-least-squares.lisp> ;; $Id$ (in-package :gsl) @@ -372,15 +372,23 @@ "Find the norm of the fit function f." (euclidean-norm (function-value fit))) +#+callback-toplevel-only +(defparameter *fitting-cb* + (make-fitting-functions + exponential-residual 3 40 + exponential-residual-derivative exponential-residual-fdf)) + (defun nonlinear-least-squares-example (&optional (number-of-observations 40) (method *levenberg-marquardt*) (print-steps t)) (let ((*nlls-example-data* (generate-nlls-data number-of-observations)) (nlls-callback - (make-fitting-functions - exponential-residual 3 number-of-observations - exponential-residual-derivative exponential-residual-fdf))) + #-callback-toplevel-only + (make-fitting-functions + exponential-residual 3 number-of-observations + exponential-residual-derivative exponential-residual-fdf) + #+callback-toplevel-only *fitting-cb*)) (setf (number-of-observations nlls-callback) number-of-observations) (let* ((init #m(1.0d0 0.0d0 0.0d0)) (number-of-parameters (number-of-parameters nlls-callback)) diff --git a/solve-minimize-fit/roots-multi.lisp b/solve-minimize-fit/roots-multi.lisp index 1a861673..fe13aee2 100644 --- a/solve-minimize-fit/roots-multi.lisp +++ b/solve-minimize-fit/roots-multi.lisp @@ -1,6 +1,6 @@ ;;; Multivariate roots. ;;; Liam Healy 2008-01-12 12:49:08 -;;; Time-stamp: <2009-01-25 10:06:14EST roots-multi.lisp> +;;; Time-stamp: <2009-01-26 21:45:23EST roots-multi.lisp> ;;; $Id$ (in-package :gsl) @@ -360,12 +360,19 @@ (* *rosenbrock-a* (- 1 arg0)) (* *rosenbrock-b* (- arg1 (expt arg0 2))))) +#+callback-toplevel-only +(defparameter *solver-nodf-cb* + (make-solver-functions rosenbrock nil nil 2)) + (defun roots-multi-example-no-derivative (&optional (method *hybrid-scaled*) (print-steps t)) "Solving Rosenbrock, the example given in Sec. 34.8 of the GSL manual." (let ((max-iter 1000) (solver (make-multi-dimensional-root-solver-f - method (make-solver-functions rosenbrock nil nil 2) + method + #-callback-toplevel-only + (make-solver-functions rosenbrock nil nil 2) + #+callback-toplevel-only *solver-nodf-cb* #m(-10.0d0 -5.0d0)))) (loop for iter from 0 with fnval and argval @@ -404,6 +411,10 @@ (rosenbrock-df arg0 arg1) (values v0 v1 j0 j1 j2 j3)))) +#+callback-toplevel-only +(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)) "Solving Rosenbrock with derivatives, the example given in Sec. 34.8 of the GSL manual." @@ -418,7 +429,9 @@ (let ((max-iter 1000) (solver (make-multi-dimensional-root-solver-fdf method + #-callback-toplevel-only (make-solver-functions rosenbrock rosenbrock-df rosenbrock-fdf 2) + #+callback-toplevel-only *solver-df-cb* #m(-10.0d0 -5.0d0)))) (loop for iter from 0 with fnval = (function-value solver) diff --git a/solve-minimize-fit/roots-one.lisp b/solve-minimize-fit/roots-one.lisp index 105ef266..7acc8d77 100644 --- a/solve-minimize-fit/roots-one.lisp +++ b/solve-minimize-fit/roots-one.lisp @@ -1,6 +1,6 @@ ;; One-dimensional root solver. ;; Liam Healy -;; Time-stamp: <2009-01-25 10:10:24EST roots-one.lisp> +;; Time-stamp: <2009-01-26 21:44:26EST roots-one.lisp> ;; $Id$ (in-package :gsl) @@ -280,13 +280,20 @@ (values (+ (* (+ (* a x) b) x) c) (+ (* 2 a x) b)))) +#+callback-toplevel-only +(defparameter *roots-one-noderiv-cb* + (make-single-function quadratic)) + (defun roots-one-example-no-derivative (&optional (method *brent-fsolver*) (print-steps t)) "Solving a quadratic, the example given in Sec. 32.10 of the GSL manual." (let ((max-iter 50) (solver (make-one-dimensional-root-solver-f - method (make-single-function quadratic) 0.0d0 5.0d0))) + method + #-callback-toplevel-only (make-single-function quadratic) + #+callback-toplevel-only *roots-one-noderiv-cb* + 0.0d0 5.0d0))) (when print-steps (format t "iter ~6t [lower ~24tupper] ~36troot ~44terr ~54terr(est)~&")) (loop for iter from 0 @@ -304,6 +311,11 @@ (- upper lower))) finally (return root)))) +#+callback-toplevel-only +(defparameter *roots-one-deriv-cb* + (make-solver-functions + quadratic quadratic-derivative quadratic-and-derivative)) + (defun roots-one-example-derivative (&optional (method *newton-fdfsolver*) (print-steps t)) "Solving a quadratic, the example given in Sec. 32.10 of the GSL manual." @@ -311,8 +323,11 @@ (initial 5.0d0) (solver (make-one-dimensional-root-solver-fdf method + #-callback-toplevel-only (make-solver-functions quadratic quadratic-derivative quadratic-and-derivative) + #+callback-toplevel-only + *roots-one-deriv-cb* initial))) (when print-steps (format t "iter ~6t ~8troot ~22terr ~34terr(est)~&")) diff --git a/test-unit/additional-definitions.lisp b/test-unit/additional-definitions.lisp index 7f3eb1c4..04846f6e 100644 --- a/test-unit/additional-definitions.lisp +++ b/test-unit/additional-definitions.lisp @@ -1,11 +1,7 @@ -;******************************************************** -; file: tests.lisp -; description: Test functions. -; date: Sat Apr 22 2006 - 16:52 -; author: Liam M. Healy -; modified: Tue Jul 18 2006 - 22:36 -;******************************************************** -;;; $Id$ +;; Test functions. +;; Liam Healy Sat Apr 22 2006 - 16:52 +;; Time-stamp: <2009-01-26 21:34:35EST additional-definitions.lisp> +;; $Id: $ ;;; Interface with lisp-unit, add a definition for comparing floating ;;; point numbers and a form for generating floating point tests. -- GitLab