[bpt/guile.git] / module / rnrs / exceptions.scm

;;; exceptions.scm --- The R6RS exceptions library

;;      Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;; 
;; This library 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
;; Lesser General Public License for more details.
;; 
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
\f

(library (rnrs exceptions (6))
  (export guard with-exception-handler raise raise-continuable)
  (import (rnrs base (6))
          (rnrs control (6))
          (rnrs conditions (6))
	  (rnrs records procedural (6))
	  (rnrs records inspection (6))
	  (only (guile)
                format
                newline
                display
                filter
                acons
                assv-ref
                throw
                set-exception-printer!
                with-throw-handler
                *unspecified*
                @@))

  ;; When a native guile exception is caught by an R6RS exception
  ;; handler, we convert it to an R6RS compound condition that includes
  ;; not only the standard condition objects expected by R6RS code, but
  ;; also a special &guile condition that preserves the original KEY and
  ;; ARGS passed to the native Guile catch handler.

  (define-condition-type &guile &condition
    make-guile-condition guile-condition?
    (key  guile-condition-key)
    (args guile-condition-args))

  (define (default-guile-condition-converter key args)
    (condition (make-serious-condition)
               (guile-common-conditions key args)))

  (define (guile-common-conditions key args)
    (apply (case-lambda
             ((subr msg margs . _)
              (condition (make-who-condition subr)
                         (make-message-condition msg)
                         (make-irritants-condition margs)))
             (_ (make-irritants-condition args)))
           args))

  (define (convert-guile-condition key args)
    (let ((converter (assv-ref guile-condition-converters key)))
      (condition (or (and converter (converter key args))
                     (default-guile-condition-converter key args))
                 ;; Preserve the original KEY and ARGS in the R6RS
                 ;; condition object.
                 (make-guile-condition key args))))

  ;; If an R6RS exception handler chooses not to handle a given
  ;; condition, it will re-raise the condition to pass it on to the next
  ;; handler.  If the condition was converted from a native Guile
  ;; exception, we must re-raise using the native Guile facilities and
  ;; the original exception KEY and ARGS.  We arrange for this in
  ;; 'raise' so that native Guile exception handlers will continue to
  ;; work when mixed with R6RS code.

  (define (raise obj)
    (if (guile-condition? obj)
        (apply throw (guile-condition-key obj) (guile-condition-args obj))
        ((@@ (rnrs records procedural) r6rs-raise) obj)))
  (define raise-continuable
    (@@ (rnrs records procedural) r6rs-raise-continuable))

  (define raise-object-wrapper? 
    (@@ (rnrs records procedural) raise-object-wrapper?))
  (define raise-object-wrapper-obj
    (@@ (rnrs records procedural) raise-object-wrapper-obj))
  (define raise-object-wrapper-continuation
    (@@ (rnrs records procedural) raise-object-wrapper-continuation))

  (define (with-exception-handler handler thunk)
    (with-throw-handler #t
     thunk
     (lambda (key . args)
       (cond ((not (eq? key 'r6rs:exception))
              (let ((obj (convert-guile-condition key args)))
                (handler obj)
                (raise (make-non-continuable-violation))))
             ((and (not (null? args))
                   (raise-object-wrapper? (car args)))
              (let* ((cargs (car args))
                     (obj (raise-object-wrapper-obj cargs))
                     (continuation (raise-object-wrapper-continuation cargs))
                     (handler-return (handler obj)))
                (if continuation
                    (continuation handler-return)
                    (raise (make-non-continuable-violation)))))))))

  (define-syntax guard0
    (syntax-rules ()
      ((_ (variable cond-clause ...) . body)
       (call/cc (lambda (continuation)
		  (with-exception-handler
		   (lambda (variable)
		     (continuation (cond cond-clause ...)))
		   (lambda () . body)))))))

  (define-syntax guard
    (syntax-rules (else)
      ((_ (variable cond-clause ... . ((else else-clause ...))) . body)
       (guard0 (variable cond-clause ... (else else-clause ...)) . body))
      ((_ (variable cond-clause ...) . body)
       (guard0 (variable cond-clause ... (else (raise variable))) . body))))

  ;;; Exception printing

  (define (exception-printer port key args punt)
    (cond ((and (= 1 (length args))
                (raise-object-wrapper? (car args)))
           (let ((obj (raise-object-wrapper-obj (car args))))
             (cond ((condition? obj)
                    (display "ERROR: R6RS exception:\n" port)
                    (format-condition port obj))
                   (else
                    (format port "ERROR: R6RS exception: `~s'" obj)))))
          (else
           (punt))))

  (define (format-condition port condition)
    (let ((components (simple-conditions condition)))
      (if (null? components)
          (format port "Empty condition object")
          (let loop ((i 1) (components components))
            (cond ((pair? components)
                   (format port "  ~a. " i)
                   (format-simple-condition port (car components))
                   (when (pair? (cdr components))
                     (newline port))
                   (loop (+ i 1) (cdr components))))))))

  (define (format-simple-condition port condition)
    (define (print-rtd-fields rtd field-names)
      (let ((n-fields (vector-length field-names)))
        (do ((i 0 (+ i 1)))
            ((>= i n-fields))
          (format port "      ~a: ~s"
                  (vector-ref field-names i)
                  ((record-accessor rtd i) condition))
          (unless (= i (- n-fields 1))
            (newline port)))))
    (let ((condition-name (record-type-name (record-rtd condition))))
      (let loop ((rtd (record-rtd condition))
                 (rtd.fields-list '())
                 (n-fields 0))
        (cond (rtd
               (let ((field-names (record-type-field-names rtd)))
                 (loop (record-type-parent rtd)
                       (cons (cons rtd field-names) rtd.fields-list)
                       (+ n-fields (vector-length field-names)))))
              (else
               (let ((rtd.fields-list
                      (filter (lambda (rtd.fields)
                                (not (zero? (vector-length (cdr rtd.fields)))))
                              (reverse rtd.fields-list))))
                 (case n-fields
                   ((0) (format port "~a" condition-name))
                   ((1) (format port "~a: ~s"
                                condition-name
                                ((record-accessor (caar rtd.fields-list) 0)
                                 condition)))
                   (else
                    (format port "~a:\n" condition-name)
                    (let loop ((lst rtd.fields-list))
                      (when (pair? lst)
                        (let ((rtd.fields (car lst)))
                          (print-rtd-fields (car rtd.fields) (cdr rtd.fields))
                          (when (pair? (cdr lst))
                            (newline port))
                          (loop (cdr lst)))))))))))))

  (set-exception-printer! 'r6rs:exception exception-printer)

  ;; Guile condition converters
  ;;
  ;; Each converter is a procedure (converter KEY ARGS) that returns
  ;; either an R6RS condition or #f.  If #f is returned,
  ;; 'default-guile-condition-converter' will be used.

  (define (guile-syntax-violation-converter key args)
    (apply (case-lambda
             ((who what where form subform . extra)
              (condition (make-syntax-violation form subform)
                         (make-who-condition who)
                         (make-message-condition what)))
             (_ #f))
           args))

  (define (guile-lexical-violation-converter key args)
    (condition (make-lexical-violation) (guile-common-conditions key args)))

  (define (guile-assertion-violation-converter key args)
    (condition (make-assertion-violation) (guile-common-conditions key args)))

  (define (guile-undefined-violation-converter key args)
    (condition (make-undefined-violation) (guile-common-conditions key args)))

  (define (guile-implementation-restriction-converter key args)
    (condition (make-implementation-restriction-violation)
               (guile-common-conditions key args)))

  (define (guile-error-converter key args)
    (condition (make-error) (guile-common-conditions key args)))

  (define (guile-system-error-converter key args)
    (apply (case-lambda
             ((subr msg msg-args errno . rest)
              ;; XXX TODO we should return a more specific error
              ;; (usually an I/O error) as expected by R6RS programs.
              ;; Unfortunately this often requires the 'filename' (or
              ;; other?) which is not currently provided by the native
              ;; Guile exceptions.
              (condition (make-error) (guile-common-conditions key args)))
             (_ (guile-error-converter key args)))
           args))

  ;; TODO: Arrange to have the needed information included in native
  ;;       Guile I/O exceptions, and arrange here to convert them to the
  ;;       proper conditions.  Remove the earlier exception conversion
  ;;       mechanism: search for 'with-throw-handler' in the 'rnrs'
  ;;       tree, e.g. 'with-i/o-filename-conditions' and
  ;;       'with-i/o-port-error' in (rnrs io ports).

  ;; XXX TODO: How should we handle the 'misc-error', 'vm-error', and
  ;;           'signal' native Guile exceptions?

  ;; XXX TODO: Should we handle the 'quit' exception specially?

  ;; An alist mapping native Guile exception keys to converters.
  (define guile-condition-converters
    `((read-error                . ,guile-lexical-violation-converter)
      (syntax-error              . ,guile-syntax-violation-converter)
      (unbound-variable          . ,guile-undefined-violation-converter)
      (wrong-number-of-args      . ,guile-assertion-violation-converter)
      (wrong-type-arg            . ,guile-assertion-violation-converter)
      (keyword-argument-error    . ,guile-assertion-violation-converter)
      (out-of-range              . ,guile-assertion-violation-converter)
      (regular-expression-syntax . ,guile-assertion-violation-converter)
      (program-error             . ,guile-assertion-violation-converter)
      (goops-error               . ,guile-assertion-violation-converter)
      (null-pointer-error        . ,guile-assertion-violation-converter)
      (system-error              . ,guile-system-error-converter)
      (host-not-found            . ,guile-error-converter)
      (getaddrinfo-error         . ,guile-error-converter)
      (no-data                   . ,guile-error-converter)
      (no-recovery               . ,guile-error-converter)
      (try-again                 . ,guile-error-converter)
      (stack-overflow            . ,guile-implementation-restriction-converter)
      (numerical-overflow        . ,guile-implementation-restriction-converter)
      (memory-allocation-error   . ,guile-implementation-restriction-converter)))

  (define (set-guile-condition-converter! key proc)
    (set! guile-condition-converters
          (acons key proc guile-condition-converters))))
Commit	Line	Data
ce543a9f JG	1	;;; exceptions.scm --- The R6RS exceptions library
ce543a9f JG	2
02500d44	3	;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
ce543a9f JG	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))
d1c83d38	21	(export guard with-exception-handler raise raise-continuable)
ce543a9f	22	(import (rnrs base (6))
32b63129	23	(rnrs control (6))
ce543a9f JG	24	(rnrs conditions (6))
ce543a9f JG	25	(rnrs records procedural (6))
32b63129 AR	26	(rnrs records inspection (6))
	27	(only (guile)
	28	format
	29	newline
	30	display
	31	filter
02500d44 MW	32	acons
	33	assv-ref
	34	throw
32b63129 AR	35	set-exception-printer!
	36	with-throw-handler
	37	unspecified
	38	@@))
ce543a9f	39
02500d44 MW	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
ce543a9f	85	(@@ (rnrs records procedural) r6rs-raise-continuable))
02500d44	86
ce543a9f JG	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)
02500d44	95	(with-throw-handler #t
ce543a9f JG	96	thunk
ce543a9f JG	97	(lambda (key . args)
02500d44 MW	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)))))))))
d1c83d38 JG	111
d1c83d38 JG	112	(define-syntax guard0
0c7398a7	113	(syntax-rules ()
23988e8c	114	((_ (variable cond-clause ...) . body)
0c7398a7 JG	115	(call/cc (lambda (continuation)
	116	(with-exception-handler
	117	(lambda (variable)
	118	(continuation (cond cond-clause ...)))
23988e8c	119	(lambda () . body)))))))
d1c83d38 JG	120
d1c83d38 JG	121	(define-syntax guard
0c7398a7	122	(syntax-rules (else)
23988e8c AR	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))))
32b63129 AR	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
02500d44 MW	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))))