conditions.lisp 7.75 KB
Newer Older
1 2
;; GSL errors                                
;; Liam Healy Sat Mar  4 2006 - 18:33
3
;; Time-stamp: <2010-07-20 17:55:56EDT conditions.lisp>
4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19
;;
;; Copyright 2006, 2007, 2008, 2009 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
20 21 22

(in-package :gsl)

23 24 25 26
;;;;****************************************************************************
;;;; Define non-error and error C return codes 
;;;;****************************************************************************

27 28 29 30 31 32
#.(append '(eval-when (:compile-toplevel :load-toplevel :execute))
	  (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)))
33

34 35 36
;;;;****************************************************************************
;;;; GSL conditions
;;;;****************************************************************************
37

38 39 40 41 42 43 44
(export 'gsl-condition)
(define-condition gsl-condition (arithmetic-error warning)
  ((error-number :initarg :error-number :reader error-number)
   (error-text :initarg :error-text :reader error-text)   
   (explanation :initarg :explanation :reader explanation)
   (source-file :initform nil :initarg :source-file :reader source-file)
   (line-number :initform 0 :initarg :line-number :reader line-number))
45 46
  (:report
   (lambda (condition stream)
Liam Healy's avatar
Liam Healy committed
47
     (format stream "~a~@[; ~a~] ~@[in ~a at line ~d~]"
48 49 50 51
	     (error-text condition)
	     (explanation condition)
	     (source-file condition)
	     (line-number condition))))
52
  (:documentation
53
   "A condition that has been signalled by the GNU Scientific Library."))
54

Liam Healy's avatar
Liam Healy committed
55 56 57 58 59 60 61 62
#|
;;; This makes the printing of the condition object more informative,
;;; but also overrides the :report which I don't want to do.
(defmethod print-object ((object gsl-condition) stream)
  (print-unreadable-object (object stream :type t :identity t) 
    (format stream "~a (GSL condition)" (error-text object))))
|#

63 64
(defparameter *errorno-keyword* nil)

65
(defmacro define-gsl-condition (keyword number text &rest superclasses)
66
  `(progn
67 68
    (define-condition
	  ,keyword ,(or superclasses '(gsl-condition))
69 70 71
      ((error-number :initform ,number :reader error-number :allocation :class)
       (error-text :initform ,text :reader error-text :allocation :class))
      (:documentation
72 73 74
       ,(format nil
	       "The condition ~a, `~a,' signalled by the GNU Scientific Library."
	       keyword text)))
75 76 77
    (setf *errorno-keyword* (acons ,number ',keyword *errorno-keyword*))
    (export ',keyword)))

78 79 80 81 82 83 84 85 86 87
(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")
88 89
(define-gsl-condition generic-failure-1 +efailed+ "Generic failure")
(define-gsl-condition generic-failure-2 +failure+ "Generic failure")
90
(define-gsl-condition factorization-failure +efactor+ "Factorization failed")
91
(define-gsl-condition sanity-check-failure
92 93
    +esanity+ "Sanity check failed - shouldn't happen")
(define-gsl-condition memory-allocation-failure +enomem+ "Malloc failed")
94
(define-gsl-condition bad-function-supplied
95
    +ebadfunc+ "Problem with user-supplied function")
96
(define-gsl-condition runaway-iteration
97
    +erunaway+ "Iterative process is out of control")
98
(define-gsl-condition exceeded-maximum-iterations
99
    +emaxiter+ "Exceeded max number of iterations")
100
(define-gsl-condition gsl-division-by-zero
101 102 103
    +ezerodiv+ "Tried to divide by zero" gsl-condition division-by-zero)
(define-gsl-condition invalid-tolerance
    +ebadtol+ "User specified an invalid tolerance")
104
(define-gsl-condition failure-to-reach-tolerance
105 106 107 108 109 110
    +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")
111
(define-gsl-condition nonconformant-dimensions
112 113 114 115
    +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")
116
(define-gsl-condition unsupported-feature
117
    +eunsup+ "Requested feature is not supported by the hardware")
118
(define-gsl-condition unimplemented-feature
119 120 121 122
    +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+
123 124
  "Iteration is not making progress towards solution")
(define-gsl-condition jacobian-not-improving
125
    +enoprogj+ "Jacobian evaluations are not improving the solution")
126
(define-gsl-condition failure-to-reach-tolerance-f
127
    +etolf+ "Cannot reach the specified tolerance in F")
128
(define-gsl-condition failure-to-reach-tolerance-x
129
    +etolx+ "Cannot reach the specified tolerance in X")
130
(define-gsl-condition failure-to-reach-tolerance-g
131
    +etolg+ "Cannot reach the specified tolerance in gradient")
132
;; not a subclass of gsl-condition
133
(define-gsl-condition gsl-eof +eof+ "End of file" end-of-file)
134
;;; It is possible to return +positive-infinity+
135
;;; by defining a handler for 'overflow.
136 137 138

(defun lookup-condition (number)
  (or (rest (assoc number *errorno-keyword*))
139
      'unspecified-errno))
140 141 142

(defun signal-gsl-error (number explanation &optional file line)
  "Signal an error from the GSL library."
143 144 145 146 147 148 149 150 151 152 153 154
  (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)))))
155 156 157

(defun signal-gsl-warning (number explanation &optional file line)
  "Signal a warning from the GSL library."
158 159 160 161 162 163 164 165 166 167 168 169
  (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)))))
170 171 172

(cffi:defcallback gsl-error :void
    ((reason :string) (file :string) (line :int) (error-number :int))
173
  (signal-gsl-error error-number reason file line))
174

175 176 177 178
(defun establish-handler ()
  (cffi:foreign-funcall
   "gsl_set_error_handler"
   :pointer (cffi:callback gsl-error)))
179

180 181 182 183
(establish-handler)

;;; This insures that conditions will be signalled if GSLL is dumped
;;; in save-lisp-and-die.
184
#+sbcl (push 'establish-handler sb-ext:*init-hooks*)