module/rnrs/exceptions.scm

   1 ;;; exceptions.scm --- The R6RS exceptions library
   2
   3 ;;      Copyright (C) 2010, 2011 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                 set-exception-printer!
  33                 with-throw-handler
  34                 *unspecified*
  35                 @@))
  36
  37   (define raise (@@ (rnrs records procedural) r6rs-raise))
  38   (define raise-continuable
  39     (@@ (rnrs records procedural) r6rs-raise-continuable))
  40   (define raise-object-wrapper?
  41     (@@ (rnrs records procedural) raise-object-wrapper?))
  42   (define raise-object-wrapper-obj
  43     (@@ (rnrs records procedural) raise-object-wrapper-obj))
  44   (define raise-object-wrapper-continuation
  45     (@@ (rnrs records procedural) raise-object-wrapper-continuation))
  46
  47   (define (with-exception-handler handler thunk)
  48     (with-throw-handler 'r6rs:exception
  49      thunk
  50      (lambda (key . args)
  51        (if (and (not (null? args))
  52                 (raise-object-wrapper? (car args)))
  53            (let* ((cargs (car args))
  54                   (obj (raise-object-wrapper-obj cargs))
  55                   (continuation (raise-object-wrapper-continuation cargs))
  56                   (handler-return (handler obj)))
  57              (if continuation
  58                  (continuation handler-return)
  59                  (raise (make-non-continuable-violation))))
  60            *unspecified*))))
  61
  62   (define-syntax guard0
  63     (syntax-rules ()
  64       ((_ (variable cond-clause ...) . body)
  65        (call/cc (lambda (continuation)
  66                   (with-exception-handler
  67                    (lambda (variable)
  68                      (continuation (cond cond-clause ...)))
  69                    (lambda () . body)))))))
  70
  71   (define-syntax guard
  72     (syntax-rules (else)
  73       ((_ (variable cond-clause ... . ((else else-clause ...))) . body)
  74        (guard0 (variable cond-clause ... (else else-clause ...)) . body))
  75       ((_ (variable cond-clause ...) . body)
  76        (guard0 (variable cond-clause ... (else (raise variable))) . body))))
  77
  78   ;;; Exception printing
  79
  80   (define (exception-printer port key args punt)
  81     (cond ((and (= 1 (length args))
  82                 (raise-object-wrapper? (car args)))
  83            (let ((obj (raise-object-wrapper-obj (car args))))
  84              (cond ((condition? obj)
  85                     (display "ERROR: R6RS exception:\n" port)
  86                     (format-condition port obj))
  87                    (else
  88                     (format port "ERROR: R6RS exception: `~s'" obj)))))
  89           (else
  90            (punt))))
  91
  92   (define (format-condition port condition)
  93     (let ((components (simple-conditions condition)))
  94       (if (null? components)
  95           (format port "Empty condition object")
  96           (let loop ((i 1) (components components))
  97             (cond ((pair? components)
  98                    (format port "  ~a. " i)
  99                    (format-simple-condition port (car components))
 100                    (when (pair? (cdr components))
 101                      (newline port))
 102                    (loop (+ i 1) (cdr components))))))))
 103
 104   (define (format-simple-condition port condition)
 105     (define (print-rtd-fields rtd field-names)
 106       (let ((n-fields (vector-length field-names)))
 107         (do ((i 0 (+ i 1)))
 108             ((>= i n-fields))
 109           (format port "      ~a: ~s"
 110                   (vector-ref field-names i)
 111                   ((record-accessor rtd i) condition))
 112           (unless (= i (- n-fields 1))
 113             (newline port)))))
 114     (let ((condition-name (record-type-name (record-rtd condition))))
 115       (let loop ((rtd (record-rtd condition))
 116                  (rtd.fields-list '())
 117                  (n-fields 0))
 118         (cond (rtd
 119                (let ((field-names (record-type-field-names rtd)))
 120                  (loop (record-type-parent rtd)
 121                        (cons (cons rtd field-names) rtd.fields-list)
 122                        (+ n-fields (vector-length field-names)))))
 123               (else
 124                (let ((rtd.fields-list
 125                       (filter (lambda (rtd.fields)
 126                                 (not (zero? (vector-length (cdr rtd.fields)))))
 127                               (reverse rtd.fields-list))))
 128                  (case n-fields
 129                    ((0) (format port "~a" condition-name))
 130                    ((1) (format port "~a: ~s"
 131                                 condition-name
 132                                 ((record-accessor (caar rtd.fields-list) 0)
 133                                  condition)))
 134                    (else
 135                     (format port "~a:\n" condition-name)
 136                     (let loop ((lst rtd.fields-list))
 137                       (when (pair? lst)
 138                         (let ((rtd.fields (car lst)))
 139                           (print-rtd-fields (car rtd.fields) (cdr rtd.fields))
 140                           (when (pair? (cdr lst))
 141                             (newline port))
 142                           (loop (cdr lst)))))))))))))
 143
 144   (set-exception-printer! 'r6rs:exception exception-printer)
 145
 146 )