Skip to content
Snippets Groups Projects
Commit 86da4ec7 authored by Liam Healy's avatar Liam Healy
Browse files

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.
parent b6d90200
No related branches found
No related tags found
No related merge requests found
;; 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.
......
;; 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.
......
;; 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
......
;; 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
......
;; 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
......
;; 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
......
;; 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))
......
;;; 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)
......
;; 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)~&"))
......
;********************************************************
; 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.
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment