Changeset 47 for trunk

Timestamp:

03/28/08 03:12:26 (8 months ago)

Author:

lhealy

Message:

Unification of errors and warnings using a single class
'gsl-condition. Each numbered GSL conditions is a subclass of this
condition, under the name given by GSL, e.g. 'EDOM.

Location:

trunk

Files:

• documentation/index.html (modified) (2 diffs)
• histogram/updating-accessing.lisp (modified) (4 diffs)
• init/conditions.lisp (modified) (2 diffs)
• init/interface.lisp (modified) (2 diffs)
• numerical-integration.lisp (modified) (2 diffs)
• special-functions/elliptic-functions.lisp (modified) (2 diffs)
• special-functions/exponential-integrals.lisp (modified) (2 diffs)
• special-functions/gamma.lisp (modified) (3 diffs)
• special-functions/legendre.lisp (modified) (2 diffs)

trunk/documentation/index.html

@@ -70 +70 @@
 <pre>
 (jacobian-elliptic-functions 0.61802d0 1.5d0)
-debugger invoked on a GSL-ERROR in thread #<THREAD "initial thread" {10032258C1}>:
-  Input domain error (EDOM), |m| > 1.0 in elljac.c at line 46
+Input domain error |m| > 1.0 in elljac.c at line 46
+   [Condition of type EDOM]
 </pre>
  </div>
@@ -159 +159 @@
 <!-- hhmts start -->
     <small>
-       Time-stamp: <2008-03-08 11:22:52EST index.html>
+       Time-stamp: <2008-03-27 23:08:11EDT index.html>
        </small>
 <!-- hhmts end -->

trunk/histogram/updating-accessing.lisp

@@ -1 +1 @@
 ;; Updating and accessing histogram elements.
 ;; Liam Healy, Mon Jan  1 2007 - 14:43
-;; Time-stamp: <2008-02-23 18:49:16EST updating-accessing.lisp>
+;; Time-stamp: <2008-03-27 23:09:26EDT updating-accessing.lisp>
 ;; $Id$
 
@@ -117 +117 @@
               ((first values) (second values))))
 
-;;; Examples and unit test
-
-#|
-(make-tests histogram
  (letm ((histo (histogram 10)))         ; should be a gsl-warning here, how to check?
      (set-ranges-uniform histo 0.0d0 10.0d0)
      (increment histo -2.0d0))
+;;; Examples and unit test
+
+#|
+(make-tests histogram
+   ;; The first one gives a warning while compiling in SBCL,
+   ;; should only give a warning while runnin.
+ (letm ((histo (histogram 10)))
+     (set-ranges-uniform histo 0.0d0 10.0d0)
+     (increment histo -2.0d0))
  (letm ((histo (histogram 10)))
    (set-ranges-uniform histo 0.0d0 10.0d0)
@@ -162 +167 @@
 
 (LISP-UNIT:DEFINE-TEST HISTOGRAM
-  (LISP-UNIT::ASSERT-NUMERICAL-EQUAL
-   (LIST)
-   (MULTIPLE-VALUE-LIST
-    (LETM ((HISTO (HISTOGRAM 10)))
-      (SET-RANGES-UNIFORM HISTO 0.0d0 10.0d0)
-      (INCREMENT HISTO -2.0d0))))
+  (LISP-UNIT:ASSERT-ERROR
+   'GSL-CONDITION
+   (LETM ((HISTO (HISTOGRAM 10)))
+     (SET-RANGES-UNIFORM HISTO 0.0d0 10.0d0)
+     (INCREMENT HISTO -2.0d0)))
   (LISP-UNIT::ASSERT-NUMERICAL-EQUAL
    (LIST 0.0d0)
@@ -193 +197 @@
       (MAREF HISTO 6))))
   (LISP-UNIT:ASSERT-ERROR
-   'GSL-ERROR
+   'GSL-CONDITION
    (LETM ((HISTO (HISTOGRAM 10)))
      (SET-RANGES-UNIFORM HISTO 0.0d0 10.0d0)

trunk/init/conditions.lisp

@@ -1 +1 @@
 ;; GSL errors                                
 ;; Liam Healy Sat Mar  4 2006 - 18:33
-;; Time-stamp: <2008-03-08 12:39:50EST conditions.lisp>
+;; Time-stamp: <2008-03-27 23:07:29EDT conditions.lisp>
 ;; $Id$
 
 (in-package :gsl)
 
-(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)
+;;;;****************************************************************************
+;;;; GSL conditions
+;;;;****************************************************************************
 
-(defparameter *gsl-error-alist*
-  '((-2 . "Iteration has not converged")
-    (-1 . "Failure")
-    (0 . "Success") 
-    (1 . "Input domain error")
-    (2 . "Output range error")
-    (3 . "Invalid pointer")
-    (4 . "Invalid argument")
-    (5 . "Generic failure")
-    (6 . "Factorization failed")
-    (7 . "Sanity check failed - shouldn't happen")
-    (8 . "Malloc failed")
-    (9 . "Problem with user-supplied function")
-    (10 . "Iterative process is out of control")
-    (11 . "Exceeded max number of iterations")
-    (12 . "Tried to divide by zero")
-    (13 . "User specified an invalid tolerance")
-    (14 . "Failed to reach the specified tolerance")
-    (15 . "Underflow")
-    (16 . "Overflow ")
-    (17 . "Loss of accuracy")
-    (18 . "Failed because of roundoff error")
-    (19 . "Matrix, vector lengths are not conformant")
-    (20 . "Matrix not square")
-    (21 . "Apparent singularity detected")
-    (22 . "Integral or series is divergent")
-    (23 . "Requested feature is not supported by the hardware")
-    (24 . "Requested feature not (yet) implemented")
-    (25 . "Cache limit exceeded")
-    (26 . "Table limit exceeded")
-    (27 . "Iteration is not making progress towards solution")
-    (28 . "Jacobian evaluations are not improving the solution")
-    (29 . "Cannot reach the specified tolerance in F")
-    (30 . "Cannot reach the specified tolerance in X")
-    (31 . "Cannot reach the specified tolerance in gradient")
-    (32 . "End of file")))
-
-;;; It would be nice to be able to return, or give the option to return,
-;;; the portable equivalent of #.SB-EXT:DOUBLE-FLOAT-POSITIVE-INFINITY
-;;; for :EOVRFLW.
-
-(define-condition gsl-error (arithmetic-error)
-  ((gsl-errno :initarg :gsl-errno :reader gsl-errno)
-   (gsl-reason :initarg :gsl-reason :reader gsl-reason)
-   (gsl-source-file :initform nil :initarg :gsl-source-file :reader gsl-source-file)
-   (gsl-line-number :initform 0 :initarg :gsl-line-number :reader gsl-line-number))
+(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))
   (:report
    (lambda (condition stream)
-     (format stream "~a (~a), ~a ~@[in ~a at line ~d~]"
-             (rest (assoc (gsl-errno condition) *gsl-error-alist*))
-             (cffi:foreign-enum-keyword 'gsl-errorno (gsl-errno condition))
-             (gsl-reason condition)
-             (gsl-source-file condition)
-             (gsl-line-number condition))))
+     (format stream "~a ~a ~@[in ~a at line ~d~]"
+             (error-text condition)
+             (explanation condition)
+             (source-file condition)
+             (line-number condition))))
   (:documentation
-   "An error that has been signalled by the GNU Scientific Library."))
+   "A condition that has been signalled by the GNU Scientific Library."))
 
-(define-condition gsl-warning (warning)
-  ((gsl-errno :initarg :gsl-errno :reader gsl-errno)
-   (gsl-context :initarg :gsl-context :reader gsl-context))
-  (:report
-   (lambda (condition stream)
-     (format stream "GSL condition ~a (~d), ~a in ~a"
-             (cffi:foreign-enum-keyword 'gsl-errorno (gsl-errno condition))
-             (gsl-errno condition)
-             (rest (assoc (gsl-errno condition) *gsl-error-alist*))
-             (gsl-context condition))))
-  (:documentation
-   "An warning that has been signalled by the GNU Scientific Library."))
+(defparameter *errorno-keyword* nil)
+
+(defmacro define-gsl-condition (keyword number text)
+  `(progn
+    (define-condition ,keyword (gsl-condition)
+      ((error-number :initform ,number :reader error-number :allocation :class)
+       (error-text :initform ,text :reader error-text :allocation :class))
+      (:documentation
+       (format nil
+               "The condition ~a, ~a, signalled by the GNU Scientific Library."
+               ',keyword ,text)))
+    (setf *errorno-keyword* (acons ,number ',keyword *errorno-keyword*))
+    (export ',keyword)))
+
+(define-gsl-condition EDOM 1 "Input domain error")
+(define-gsl-condition ERANGE 2 "Output range error")
+(define-gsl-condition EFAULT 3 "Invalid pointer")
+(define-gsl-condition EINVAL 4 "Invalid argument")
+(define-gsl-condition EFAILED 5 "Generic failure")
+(define-gsl-condition EFACTOR 6 "Factorization failed")
+(define-gsl-condition ESANITY 7 "Sanity check failed - shouldn't happen")
+(define-gsl-condition ENOMEM 8 "Malloc failed")
+(define-gsl-condition EBADFUNC 9 "Problem with user-supplied function")
+(define-gsl-condition ERUNAWAY 10 "Iterative process is out of control")
+(define-gsl-condition EMAXITER 11 "Exceeded max number of iterations")
+(define-gsl-condition EZERODIV 12 "Tried to divide by zero")
+(define-gsl-condition EBADTOL 13 "User specified an invalid tolerance")
+(define-gsl-condition ETOL 14 "Failed to reach the specified tolerance")
+(define-gsl-condition EUNDRFLW 15 "Underflow")
+(define-gsl-condition EOVRFLW 16 "Overflow")
+(define-gsl-condition ELOSS 17 "Loss of accuracy")
+(define-gsl-condition EROUND 18 "Failed because of roundoff error")
+(define-gsl-condition EBADLEN 19 "Matrix, vector lengths are not conformant")
+(define-gsl-condition ENOTSQR 20 "Matrix not square")
+(define-gsl-condition ESING 21 "Apparent singularity detected")
+(define-gsl-condition EDIVERGE 22 "Integral or series is divergent")
+(define-gsl-condition EUNSUP 23 "Requested feature is not supported by the hardware")
+(define-gsl-condition EUNIMPL 24 "Requested feature not (yet) implemented")
+(define-gsl-condition ECACHE 25 "Cache limit exceeded")
+(define-gsl-condition ETABLE 26 "Table limit exceeded")
+(define-gsl-condition ENOPROG 27 "Iteration is not making progress towards solution")
+(define-gsl-condition ENOPROGJ 28 "Jacobian evaluations are not improving the solution")
+(define-gsl-condition ETOLF 29 "Cannot reach the specified tolerance in F")
+(define-gsl-condition ETOLX 30 "Cannot reach the specified tolerance in X")
+(define-gsl-condition ETOLG 31 "Cannot reach the specified tolerance in gradient")
+(define-gsl-condition EOF 32 "End of file")
+;;; It is possible to return +positive-infinity+
+;;; by defining a handler for :EOVRFLW.
+
+(defun lookup-condition (number)
+  (or (rest (assoc number *errorno-keyword*))
+      ;; go for "Generic failure" of the code doesn't come up
+      'EFAILED))
+
+(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))
+
+(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))
 
 (cffi:defcallback gsl-error :void
     ((reason :string) (file :string) (line :int) (error-number :int))
-  (error 'gsl-error
-         :gsl-errno error-number
-         :gsl-reason reason
-         :gsl-source-file file
-         :gsl-line-number line))
+  (signal-gsl-error error-number reason file line))
 
 (defun establish-handler ()
@@ -104 +110 @@
 #+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

trunk/init/interface.lisp

@@ -1 +1 @@
 ;; Macros to interface GSL functions.
 ;; Liam Healy 
-;; Time-stamp: <2008-03-15 21:51:07EDT interface.lisp>
+;; Time-stamp: <2008-03-27 22:36:35EDT interface.lisp>
 ;; $Id$
 
@@ -74 +74 @@
   "Check the return status code from a GSL function and signal a warning
    if it is not :SUCCESS."
-  (unless (eql :success (cffi:foreign-enum-keyword 'gsl-errorno status-code))
-    (warn 'gsl-warning
-          :gsl-errno status-code :gsl-context context)))
+  (unless (eql status-code success)
+    (signal-gsl-warning status-code (format nil "in ~a" context))))
 
 (defun check-null-pointer (pointer error-code reason)
   (when (cffi:null-pointer-p pointer)
-    (error 'gsl-error
-           :gsl-errno (cffi:foreign-enum-value 'gsl-errorno error-code)
-           :gsl-reason reason)))
+    (signal-gsl-error error-code reason)))
 
 (defun success-failure (value)

trunk/numerical-integration.lisp

@@ -1 +1 @@
 ;; Numerical integration
 ;; Liam Healy, Wed Jul  5 2006 - 23:14
-;; Time-stamp: <2008-02-17 11:43:47EST numerical-integration.lisp>
+;; Time-stamp: <2008-03-27 21:30:20EDT numerical-integration.lisp>
 ;; $Id$
 
@@ -247 +247 @@
                        WS))))
   (LISP-UNIT:ASSERT-ERROR
-   'GSL-ERROR
+   'GSL-CONDITION
    (LETM ((WS (INTEGRATION-WORKSPACE 20)))
      (INTEGRATION-QAG ONE-SINE 0.0d0 PI :GAUSS15 50 WS))))

trunk/special-functions/elliptic-functions.lisp

@@ -1 +1 @@
 ;; Jacobian elliptic functions
 ;; Liam Healy, Mon Mar 20 2006 - 22:21
-;; Time-stamp: <2008-02-16 20:42:55EST elliptic-functions.lisp>
+;; Time-stamp: <2008-03-27 21:29:35EDT elliptic-functions.lisp>
 ;; $Id$
 
@@ -38 +38 @@
    (MULTIPLE-VALUE-LIST
     (JACOBIAN-ELLIPTIC-FUNCTIONS 0.2d0 0.81d0)))
-  (LISP-UNIT:ASSERT-ERROR 'GSL-ERROR
+  (LISP-UNIT:ASSERT-ERROR 'GSL-CONDITION
                           (JACOBIAN-ELLIPTIC-FUNCTIONS
                            0.61802d0 1.5d0)))

trunk/special-functions/exponential-integrals.lisp

@@ -1 +1 @@
 ;; Exponential integrals
 ;; Liam Healy, Tue Mar 21 2006 - 17:37
-;; Time-stamp: <2008-02-16 22:16:29EST exponential-integrals.lisp>
+;; Time-stamp: <2008-03-27 21:29:32EDT exponential-integrals.lisp>
 ;; $Id$
 
@@ -105 +105 @@
 
 (LISP-UNIT:DEFINE-TEST EXPONENTIAL-INTEGRALS
-  (LISP-UNIT:ASSERT-ERROR 'GSL-ERROR (EXPINT-E1 0.0d0))
+  (LISP-UNIT:ASSERT-ERROR 'GSL-CONDITION (EXPINT-E1 0.0d0))
   (LISP-UNIT::ASSERT-NUMERICAL-EQUAL
    (LIST 0.21938393439552029d0 2.6541220085226265d-16)

trunk/special-functions/gamma.lisp

@@ -1 +1 @@
 ;; Gamma functions
 ;; Liam Healy, Thu Apr 27 2006 - 22:06
-;; Time-stamp: <2008-02-16 21:58:18EST gamma.lisp>
+;; Time-stamp: <2008-03-27 21:29:36EDT gamma.lisp>
 ;; $Id$
 
@@ -219 +219 @@
 
 (LISP-UNIT:DEFINE-TEST GAMMA
-  (LISP-UNIT:ASSERT-ERROR 'GSL-ERROR (GAMMA -1.0d0))
+  (LISP-UNIT:ASSERT-ERROR 'GSL-CONDITION (GAMMA -1.0d0))
   (LISP-UNIT::ASSERT-NUMERICAL-EQUAL
    (LIST 120.0d0 2.6645352591003757d-14)
    (MULTIPLE-VALUE-LIST (GAMMA 6.0d0)))
-  (LISP-UNIT:ASSERT-ERROR 'GSL-ERROR (LOG-GAMMA -100.0d0))
+  (LISP-UNIT:ASSERT-ERROR 'GSL-CONDITION (LOG-GAMMA -100.0d0))
   (LISP-UNIT::ASSERT-NUMERICAL-EQUAL
    (LIST 359.13420536957534d0 2.4544868717695813d-13)
@@ -260 +260 @@
    (LIST 56.0d0 7.460698725481052d-14)
    (MULTIPLE-VALUE-LIST (CHOOSE 8 3)))
-  (LISP-UNIT:ASSERT-ERROR 'GSL-ERROR (CHOOSE 3 8))
+  (LISP-UNIT:ASSERT-ERROR 'GSL-CONDITION (CHOOSE 3 8))
   (LISP-UNIT::ASSERT-NUMERICAL-EQUAL
    (LIST 29.422274169864693d0 1.9338924605168215d-13)

trunk/special-functions/legendre.lisp

@@ -1 +1 @@
 ;; Legendre functions
 ;; Liam Healy, Sat Apr 29 2006 - 19:16
-;; Time-stamp: <2008-03-09 19:29:17EDT legendre.lisp>
+;; Time-stamp: <2008-03-27 21:30:02EDT legendre.lisp>
 ;; $Id$
 
@@ -307 +307 @@
    (LIST -0.38249999999999995d0 1.9984014443252816d-16)
    (MULTIPLE-VALUE-LIST (LEGENDRE-P3 0.3d0)))
-  (LISP-UNIT:ASSERT-ERROR 'GSL-ERROR
+  (LISP-UNIT:ASSERT-ERROR 'GSL-CONDITION
                           (LEGENDRE-PL -4 0.3d0))
-  (LISP-UNIT:ASSERT-ERROR 'GSL-ERROR
+  (LISP-UNIT:ASSERT-ERROR 'GSL-CONDITION
                           (LEGENDRE-PL 4 3.0d0))
   (LISP-UNIT::ASSERT-NUMERICAL-EQUAL