From d3d82a26f6c9f26302bde808fdbb443719e69354 Mon Sep 17 00:00:00 2001 From: Liam Healy <lnp@healy.washington.dc.us> Date: Mon, 23 Mar 2009 13:00:24 -0400 Subject: [PATCH] New errno code interpretation and gsl-condition definitions Make a defconstant on earmuffed symbols of cffi:defcenum gsl-errorno, e.g. +continue+, +failure+, +success+, etc., and use those in define-gsl-condition forms in condition.lisp. Remove the symbol macro definition of 'success. Define a condition 'unspecified-errno in case an error code is processed that isn't in the list. Redefine #'success-failure to true if either +success+ or +continue+, from non-negative. In roots-multi, fixed error in multiroot-test-residual return for, and changed roots-multi-example-no-derivative to insure the loop is executed at least once so that fnval and argval are always bound before exiting. --- init/callback.lisp | 4 +- init/conditions.lisp | 153 ++++++++++++++++------------ init/interface.lisp | 23 ++--- solve-minimize-fit/roots-multi.lisp | 7 +- 4 files changed, 105 insertions(+), 82 deletions(-) diff --git a/init/callback.lisp b/init/callback.lisp index 4f453723..f7ab1bee 100644 --- a/init/callback.lisp +++ b/init/callback.lisp @@ -1,6 +1,6 @@ ;; Foreign callback functions. ;; Liam Healy -;; Time-stamp: <2009-02-25 21:23:42EST callback.lisp> +;; Time-stamp: <2009-03-23 11:18:51EDT callback.lisp> ;; $Id$ (in-package :gsl) @@ -192,7 +192,7 @@ (:success-failure ;; We always return success, because if there was a ;; problem, a CL error would be signalled. - '(success)) + '(+success+)) (:pointer ;; For unclear reasons, some GSL functions want callbacks ;; to return a void pointer which is apparently meaningless. diff --git a/init/conditions.lisp b/init/conditions.lisp index 7d6650a9..2a2c73ac 100644 --- a/init/conditions.lisp +++ b/init/conditions.lisp @@ -1,10 +1,31 @@ ;; GSL errors ;; Liam Healy Sat Mar 4 2006 - 18:33 -;; Time-stamp: <2009-03-16 10:36:05EDT conditions.lisp> +;; Time-stamp: <2009-03-23 12:27:09EDT conditions.lisp> ;; $Id$ (in-package :gsl) +;;;;**************************************************************************** +;;;; Define non-error and error C return codes +;;;;**************************************************************************** + +(eval-when (:compile-toplevel :load-toplevel :execute) + (cffi:defcenum gsl-errorno + "Error codes for GSL, from /usr/include/gsl/gsl_errno.h." + (:CONTINUE -2) + :FAILURE :SUCCESS :EDOM :ERANGE :EFAULT :EINVAL :EFAILED :EFACTOR + :ESANITY :ENOMEM :EBADFUNC :ERUNAWAY :EMAXITER :EZERODIV :EBADTOL + :ETOL :EUNDRFLW :EOVRFLW :ELOSS :EROUND :EBADLEN :ENOTSQR :ESING + :EDIVERGE :EUNSUP :EUNIMPL :ECACHE :ETABLE :ENOPROG :ENOPROGJ + :ETOLF :ETOLX :ETOLG :EOF)) + +#.(cons 'progn + (loop for i from (cffi:foreign-enum-value 'gsl-errorno :continue) + to (cffi:foreign-enum-value 'gsl-errorno :eof) + for name = (string (cffi:foreign-enum-keyword 'gsl-errorno i)) + collect + `(defconstant ,(intern (format nil "+~:@(~a~)+" name) :gsll) ,i))) + ;;;;**************************************************************************** ;;;; GSL conditions ;;;;**************************************************************************** @@ -49,74 +70,98 @@ (setf *errorno-keyword* (acons ,number ',keyword *errorno-keyword*)) (export ',keyword))) -(define-gsl-condition input-domain 1 "Input domain error") -(define-gsl-condition input-range 2 "Output range error") -(define-gsl-condition invalid-pointer 3 "Invalid pointer") -(define-gsl-condition invalid-argument 4 "Invalid argument") -(define-gsl-condition generic-failure 5 "Generic failure") -(define-gsl-condition factorization-failure 6 "Factorization failed") +(define-condition unspecified-errno (gsl-condition) + ((error-text :initform "Returned errno code not recognized" + :reader error-text :allocation :class)) + (:documentation + "Errno value from GNU Scientific Library not recognized.")) + +(define-gsl-condition input-domain +edom+ "Input domain error") +(define-gsl-condition input-range +erange+ "Output range error") +(define-gsl-condition invalid-pointer +efault+ "Invalid pointer") +(define-gsl-condition invalid-argument +einval+ "Invalid argument") +(define-gsl-condition generic-failure +efailed+ "Generic failure") +(define-gsl-condition generic-failure +failure+ "Generic failure") +(define-gsl-condition factorization-failure +efactor+ "Factorization failed") (define-gsl-condition sanity-check-failure - 7 "Sanity check failed - shouldn't happen") -(define-gsl-condition memory-allocation-failure 8 "Malloc failed") + +esanity+ "Sanity check failed - shouldn't happen") +(define-gsl-condition memory-allocation-failure +enomem+ "Malloc failed") (define-gsl-condition bad-function-supplied - 9 "Problem with user-supplied function") + +ebadfunc+ "Problem with user-supplied function") (define-gsl-condition runaway-iteration - 10 "Iterative process is out of control") + +erunaway+ "Iterative process is out of control") (define-gsl-condition exceeded-maximum-iterations - 11 "Exceeded max number of iterations") + +emaxiter+ "Exceeded max number of iterations") (define-gsl-condition gsl-division-by-zero - 12 "Tried to divide by zero" gsl-condition division-by-zero) -(define-gsl-condition invalid-tolerance 13 "User specified an invalid tolerance") + +ezerodiv+ "Tried to divide by zero" gsl-condition division-by-zero) +(define-gsl-condition invalid-tolerance + +ebadtol+ "User specified an invalid tolerance") (define-gsl-condition failure-to-reach-tolerance - 14 "Failed to reach the specified tolerance") -(define-gsl-condition underflow 15 "Underflow") -(define-gsl-condition overflow 16 "Overflow") -(define-gsl-condition loss-of-accuracy 17 "Loss of accuracy") -(define-gsl-condition roundoff-failure 18 "Failed because of roundoff error") + +etol+ "Failed to reach the specified tolerance") +(define-gsl-condition underflow +eundrflw+ "Underflow") +(define-gsl-condition overflow +eovrflw+ "Overflow") +(define-gsl-condition loss-of-accuracy +eloss+ "Loss of accuracy") +(define-gsl-condition roundoff-failure + +eround+ "Failed because of roundoff error") (define-gsl-condition nonconformant-dimensions - 19 "Matrix, vector lengths are not conformant") -(define-gsl-condition nonsquare-matrix 20 "Matrix not square") -(define-gsl-condition singularity 21 "Apparent singularity detected") -(define-gsl-condition divergence 22 "Integral or series is divergent") + +ebadlen+ "Matrix, vector lengths are not conformant") +(define-gsl-condition nonsquare-matrix +enotsqr+ "Matrix not square") +(define-gsl-condition singularity +esing+ "Apparent singularity detected") +(define-gsl-condition divergence +ediverge+ "Integral or series is divergent") (define-gsl-condition unsupported-feature - 23 "Requested feature is not supported by the hardware") + +eunsup+ "Requested feature is not supported by the hardware") (define-gsl-condition unimplemented-feature - 24 "Requested feature not (yet) implemented") -(define-gsl-condition cache-limit-exceeded 25 "Cache limit exceeded") -(define-gsl-condition table-limit-exceeded 26 "Table limit exceeded") -(define-gsl-condition no-progress 27 + +eunimpl+ "Requested feature not (yet) implemented") +(define-gsl-condition cache-limit-exceeded +ecache+ "Cache limit exceeded") +(define-gsl-condition table-limit-exceeded +etable+ "Table limit exceeded") +(define-gsl-condition no-progress +enoprog+ "Iteration is not making progress towards solution") (define-gsl-condition jacobian-not-improving - 28 "Jacobian evaluations are not improving the solution") + +enoprogj+ "Jacobian evaluations are not improving the solution") (define-gsl-condition failure-to-reach-tolerance-f - 29 "Cannot reach the specified tolerance in F") + +etolf+ "Cannot reach the specified tolerance in F") (define-gsl-condition failure-to-reach-tolerance-x - 30 "Cannot reach the specified tolerance in X") + +etolx+ "Cannot reach the specified tolerance in X") (define-gsl-condition failure-to-reach-tolerance-g - 31 "Cannot reach the specified tolerance in gradient") + +etolg+ "Cannot reach the specified tolerance in gradient") ;; not a subclass of gsl-condition -(define-gsl-condition gsl-eof 32 "End of file" end-of-file) +(define-gsl-condition gsl-eof +eof+ "End of file" end-of-file) ;;; It is possible to return +positive-infinity+ ;;; by defining a handler for 'overflow. (defun lookup-condition (number) (or (rest (assoc number *errorno-keyword*)) - ;; go for "Generic failure" of the code doesn't come up - 'generic-failure)) + 'unspecified-errno)) (defun signal-gsl-error (number explanation &optional file line) "Signal an error from the GSL library." - (error (lookup-condition number) - :explanation explanation - :source-file file - :line-number line)) + (unless (success-failure number) + (let ((condition (lookup-condition number))) + (if (eq condition 'unspecified-errno) + (error condition + :error-number number + :explanation explanation + :source-file file + :line-number line) + (error condition + :explanation explanation + :source-file file + :line-number line))))) (defun signal-gsl-warning (number explanation &optional file line) "Signal a warning from the GSL library." - (warn (lookup-condition number) - :explanation explanation - :source-file file - :line-number line)) + (unless (success-failure number) + (let ((condition (lookup-condition number))) + (if (eq condition 'unspecified-errno) + (warn condition + :error-number number + :explanation explanation + :source-file file + :line-number line) + (warn condition + :explanation explanation + :source-file file + :line-number line))))) (cffi:defcallback gsl-error :void ((reason :string) (file :string) (line :int) (error-number :int)) @@ -132,25 +177,3 @@ ;;; This insures that conditions will be signalled if GSLL is dumped ;;; in save-lisp-and-die. #+sbcl (push 'establish-handler sb-ext:*init-hooks*) - -;;;;**************************************************************************** -;;;; Define non-error C codes -;;;;**************************************************************************** - -(cffi:defcenum gsl-errorno - "Error codes for GSL, from /usr/include/gsl/gsl_errno.h." - ;; We really only need the first three here; the rest are handled - ;; above. - (:CONTINUE -2) - :FAILURE :SUCCESS :EDOM :ERANGE :EFAULT :EINVAL :EFAILED :EFACTOR - :ESANITY :ENOMEM :EBADFUNC :ERUNAWAY :EMAXITER :EZERODIV :EBADTOL - :ETOL :EUNDRFLW :EOVRFLW :ELOSS :EROUND :EBADLEN :ENOTSQR :ESING - :EDIVERGE :EUNSUP :EUNIMPL :ECACHE :ETABLE :ENOPROG :ENOPROGJ - :ETOLF :ETOLX :ETOLG :EOF) - -(defmacro gsl-errorno-sm (keyword) - `(define-symbol-macro - ,(intern (symbol-name keyword) (find-package :gsl)) - (cffi:foreign-enum-value 'gsl-errorno ,keyword))) - -(gsl-errorno-sm :success) diff --git a/init/interface.lisp b/init/interface.lisp index f742db88..1fd5b8c5 100644 --- a/init/interface.lisp +++ b/init/interface.lisp @@ -1,6 +1,6 @@ ;; Macros to interface GSL functions, including definitions necessary for defmfun. ;; Liam Healy -;; Time-stamp: <2009-02-16 18:39:59EST interface.lisp> +;; Time-stamp: <2009-03-23 12:14:14EDT interface.lisp> ;; $Id$ (in-package :gsl) @@ -71,26 +71,25 @@ ;;;; Checking results from GSL functions ;;;;**************************************************************************** +(defun success-failure (value) + "If status is either +success+ or +continue+, return T; + otherwise, return NIL." + (member value (list +success+ +continue+))) + +(defun success-continue (value) + "If status is +success+, return T, othewise return NIL." + (eql value +success+)) + (defun check-gsl-status (status-code context) "Check the return status code from a GSL function and signal a warning if it is not :SUCCESS." - (unless (eql status-code success) + (unless (success-failure status-code) (signal-gsl-warning status-code (format nil "in ~a" context)))) (defun check-null-pointer (pointer error-code reason) (when (cffi:null-pointer-p pointer) (signal-gsl-error error-code reason))) -(defun success-failure (value) - "If status indicates failure, return NIL, othewise return T." - ;;(not (eql value (cffi:foreign-enum-value 'gsl-errorno :FAILURE))) - ;; More general, to allow :CONTINUE - (not (minusp value))) - -(defun success-continue (value) - "If status indicates success, return T, othewise return NIL." - (eql value success)) - ;;;;**************************************************************************** ;;;; Argument check ;;;;**************************************************************************** diff --git a/solve-minimize-fit/roots-multi.lisp b/solve-minimize-fit/roots-multi.lisp index 629bf69e..0516f080 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-03-20 11:33:58EDT roots-multi.lisp> +;;; Time-stamp: <2009-03-23 12:50:44EDT roots-multi.lisp> ;;; $Id$ (in-package :gsl) @@ -228,7 +228,7 @@ (defmfun multiroot-test-residual (solver absolute-error) "gsl_multiroot_test_residual" (((multiroot-slot solver 'f) :pointer) (absolute-error :double)) - :c-return :success-failure + :c-return :success-continue :documentation ; FDL "Test the residual value f against the absolute error, returning T if the following condition is achieved: @@ -409,7 +409,8 @@ (loop for iter from 0 with fnval and argval while (and (< iter max-iter) - (not (multiroot-test-residual solver 1.0d-7))) + (or (zerop iter) + (not (multiroot-test-residual solver 1.0d-7)))) do (iterate solver) (setf fnval (function-value solver) -- GitLab