module/rnrs/exceptions.scm

   1 ;;; exceptions.scm --- The R6RS exceptions library
   2
   3 ;;      Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
   4 ;;
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 3 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18 \f
  19
  20 (library (rnrs exceptions (6))
  21   (export guard with-exception-handler raise raise-continuable)
  22   (import (rnrs base (6))
  23           (rnrs control (6))
  24           (rnrs conditions (6))
  25           (rnrs records procedural (6))
  26           (rnrs records inspection (6))
  27           (only (guile)
  28                 format
  29                 newline
  30                 display
  31                 filter
  32                 acons
  33                 assv-ref
  34                 throw
  35                 set-exception-printer!
  36                 with-throw-handler
  37                 *unspecified*
  38                 @@))
  39
  40   ;; When a native guile exception is caught by an R6RS exception
  41   ;; handler, we convert it to an R6RS compound condition that includes
  42   ;; not only the standard condition objects expected by R6RS code, but
  43   ;; also a special &guile condition that preserves the original KEY and
  44   ;; ARGS passed to the native Guile catch handler.
  45
  46   (define-condition-type &guile &condition
  47     make-guile-condition guile-condition?
  48     (key  guile-condition-key)
  49     (args guile-condition-args))
  50
  51   (define (default-guile-condition-converter key args)
  52     (condition (make-serious-condition)
  53                (guile-common-conditions key args)))
  54
  55   (define (guile-common-conditions key args)
  56     (apply (case-lambda
  57              ((subr msg margs . _)
  58               (condition (make-who-condition subr)
  59                          (make-message-condition msg)
  60                          (make-irritants-condition margs)))
  61              (_ (make-irritants-condition args)))
  62            args))
  63
  64   (define (convert-guile-condition key args)
  65     (let ((converter (assv-ref guile-condition-converters key)))
  66       (condition (or (and converter (converter key args))
  67                      (default-guile-condition-converter key args))
  68                  ;; Preserve the original KEY and ARGS in the R6RS
  69                  ;; condition object.
  70                  (make-guile-condition key args))))
  71
  72   ;; If an R6RS exception handler chooses not to handle a given
  73   ;; condition, it will re-raise the condition to pass it on to the next
  74   ;; handler.  If the condition was converted from a native Guile
  75   ;; exception, we must re-raise using the native Guile facilities and
  76   ;; the original exception KEY and ARGS.  We arrange for this in
  77   ;; 'raise' so that native Guile exception handlers will continue to
  78   ;; work when mixed with R6RS code.
  79
  80   (define (raise obj)
  81     (if (guile-condition? obj)
  82         (apply throw (guile-condition-key obj) (guile-condition-args obj))
  83         ((@@ (rnrs records procedural) r6rs-raise) obj)))
  84   (define raise-continuable
  85     (@@ (rnrs records procedural) r6rs-raise-continuable))
  86
  87   (define raise-object-wrapper?
  88     (@@ (rnrs records procedural) raise-object-wrapper?))
  89   (define raise-object-wrapper-obj
  90     (@@ (rnrs records procedural) raise-object-wrapper-obj))
  91   (define raise-object-wrapper-continuation
  92     (@@ (rnrs records procedural) raise-object-wrapper-continuation))
  93
  94   (define (with-exception-handler handler thunk)
  95     (with-throw-handler #t
  96      thunk
  97      (lambda (key . args)
  98        (cond ((not (eq? key 'r6rs:exception))
  99               (let ((obj (convert-guile-condition key args)))
 100                 (handler obj)
 101                 (raise (make-non-continuable-violation))))
 102              ((and (not (null? args))
 103                    (raise-object-wrapper? (car args)))
 104               (let* ((cargs (car args))
 105                      (obj (raise-object-wrapper-obj cargs))
 106                      (continuation (raise-object-wrapper-continuation cargs))
 107                      (handler-return (handler obj)))
 108                 (if continuation
 109                     (continuation handler-return)
 110                     (raise (make-non-continuable-violation)))))))))
 111
 112   (define-syntax guard0
 113     (syntax-rules ()
 114       ((_ (variable cond-clause ...) . body)
 115        (call/cc (lambda (continuation)
 116                   (with-exception-handler
 117                    (lambda (variable)
 118                      (continuation (cond cond-clause ...)))
 119                    (lambda () . body)))))))
 120
 121   (define-syntax guard
 122     (syntax-rules (else)
 123       ((_ (variable cond-clause ... . ((else else-clause ...))) . body)
 124        (guard0 (variable cond-clause ... (else else-clause ...)) . body))
 125       ((_ (variable cond-clause ...) . body)
 126        (guard0 (variable cond-clause ... (else (raise variable))) . body))))
 127
 128   ;;; Exception printing
 129
 130   (define (exception-printer port key args punt)
 131     (cond ((and (= 1 (length args))
 132                 (raise-object-wrapper? (car args)))
 133            (let ((obj (raise-object-wrapper-obj (car args))))
 134              (cond ((condition? obj)
 135                     (display "ERROR: R6RS exception:\n" port)
 136                     (format-condition port obj))
 137                    (else
 138                     (format port "ERROR: R6RS exception: `~s'" obj)))))
 139           (else
 140            (punt))))
 141
 142   (define (format-condition port condition)
 143     (let ((components (simple-conditions condition)))
 144       (if (null? components)
 145           (format port "Empty condition object")
 146           (let loop ((i 1) (components components))
 147             (cond ((pair? components)
 148                    (format port "  ~a. " i)
 149                    (format-simple-condition port (car components))
 150                    (when (pair? (cdr components))
 151                      (newline port))
 152                    (loop (+ i 1) (cdr components))))))))
 153
 154   (define (format-simple-condition port condition)
 155     (define (print-rtd-fields rtd field-names)
 156       (let ((n-fields (vector-length field-names)))
 157         (do ((i 0 (+ i 1)))
 158             ((>= i n-fields))
 159           (format port "      ~a: ~s"
 160                   (vector-ref field-names i)
 161                   ((record-accessor rtd i) condition))
 162           (unless (= i (- n-fields 1))
 163             (newline port)))))
 164     (let ((condition-name (record-type-name (record-rtd condition))))
 165       (let loop ((rtd (record-rtd condition))
 166                  (rtd.fields-list '())
 167                  (n-fields 0))
 168         (cond (rtd
 169                (let ((field-names (record-type-field-names rtd)))
 170                  (loop (record-type-parent rtd)
 171                        (cons (cons rtd field-names) rtd.fields-list)
 172                        (+ n-fields (vector-length field-names)))))
 173               (else
 174                (let ((rtd.fields-list
 175                       (filter (lambda (rtd.fields)
 176                                 (not (zero? (vector-length (cdr rtd.fields)))))
 177                               (reverse rtd.fields-list))))
 178                  (case n-fields
 179                    ((0) (format port "~a" condition-name))
 180                    ((1) (format port "~a: ~s"
 181                                 condition-name
 182                                 ((record-accessor (caar rtd.fields-list) 0)
 183                                  condition)))
 184                    (else
 185                     (format port "~a:\n" condition-name)
 186                     (let loop ((lst rtd.fields-list))
 187                       (when (pair? lst)
 188                         (let ((rtd.fields (car lst)))
 189                           (print-rtd-fields (car rtd.fields) (cdr rtd.fields))
 190                           (when (pair? (cdr lst))
 191                             (newline port))
 192                           (loop (cdr lst)))))))))))))
 193
 194   (set-exception-printer! 'r6rs:exception exception-printer)
 195
 196   ;; Guile condition converters
 197   ;;
 198   ;; Each converter is a procedure (converter KEY ARGS) that returns
 199   ;; either an R6RS condition or #f.  If #f is returned,
 200   ;; 'default-guile-condition-converter' will be used.
 201
 202   (define (guile-syntax-violation-converter key args)
 203     (apply (case-lambda
 204              ((who what where form subform . extra)
 205               (condition (make-syntax-violation form subform)
 206                          (make-who-condition who)
 207                          (make-message-condition what)))
 208              (_ #f))
 209            args))
 210
 211   (define (guile-lexical-violation-converter key args)
 212     (condition (make-lexical-violation) (guile-common-conditions key args)))
 213
 214   (define (guile-assertion-violation-converter key args)
 215     (condition (make-assertion-violation) (guile-common-conditions key args)))
 216
 217   (define (guile-undefined-violation-converter key args)
 218     (condition (make-undefined-violation) (guile-common-conditions key args)))
 219
 220   (define (guile-implementation-restriction-converter key args)
 221     (condition (make-implementation-restriction-violation)
 222                (guile-common-conditions key args)))
 223
 224   (define (guile-error-converter key args)
 225     (condition (make-error) (guile-common-conditions key args)))
 226
 227   (define (guile-system-error-converter key args)
 228     (apply (case-lambda
 229              ((subr msg msg-args errno . rest)
 230               ;; XXX TODO we should return a more specific error
 231               ;; (usually an I/O error) as expected by R6RS programs.
 232               ;; Unfortunately this often requires the 'filename' (or
 233               ;; other?) which is not currently provided by the native
 234               ;; Guile exceptions.
 235               (condition (make-error) (guile-common-conditions key args)))
 236              (_ (guile-error-converter key args)))
 237            args))
 238
 239   ;; TODO: Arrange to have the needed information included in native
 240   ;;       Guile I/O exceptions, and arrange here to convert them to the
 241   ;;       proper conditions.  Remove the earlier exception conversion
 242   ;;       mechanism: search for 'with-throw-handler' in the 'rnrs'
 243   ;;       tree, e.g. 'with-i/o-filename-conditions' and
 244   ;;       'with-i/o-port-error' in (rnrs io ports).
 245
 246   ;; XXX TODO: How should we handle the 'misc-error', 'vm-error', and
 247   ;;           'signal' native Guile exceptions?
 248
 249   ;; XXX TODO: Should we handle the 'quit' exception specially?
 250
 251   ;; An alist mapping native Guile exception keys to converters.
 252   (define guile-condition-converters
 253     `((read-error                . ,guile-lexical-violation-converter)
 254       (syntax-error              . ,guile-syntax-violation-converter)
 255       (unbound-variable          . ,guile-undefined-violation-converter)
 256       (wrong-number-of-args      . ,guile-assertion-violation-converter)
 257       (wrong-type-arg            . ,guile-assertion-violation-converter)
 258       (keyword-argument-error    . ,guile-assertion-violation-converter)
 259       (out-of-range              . ,guile-assertion-violation-converter)
 260       (regular-expression-syntax . ,guile-assertion-violation-converter)
 261       (program-error             . ,guile-assertion-violation-converter)
 262       (goops-error               . ,guile-assertion-violation-converter)
 263       (null-pointer-error        . ,guile-assertion-violation-converter)
 264       (system-error              . ,guile-system-error-converter)
 265       (host-not-found            . ,guile-error-converter)
 266       (getaddrinfo-error         . ,guile-error-converter)
 267       (no-data                   . ,guile-error-converter)
 268       (no-recovery               . ,guile-error-converter)
 269       (try-again                 . ,guile-error-converter)
 270       (stack-overflow            . ,guile-implementation-restriction-converter)
 271       (numerical-overflow        . ,guile-implementation-restriction-converter)
 272       (memory-allocation-error   . ,guile-implementation-restriction-converter)))
 273
 274   (define (set-guile-condition-converter! key proc)
 275     (set! guile-condition-converters
 276           (acons key proc guile-condition-converters))))