mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

install r6rs exception printer

Browse source 
* module/rnrs/exceptions.scm: Install an exception printer for R6RS
  exceptions.
This commit is contained in:
Andreas Rottmann 2011-02-11 16:07:14 +01:00 • committed by Andy Wingo
parent 39d41afe18
commit 32b6312952
1 changed files with 81 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

83
module/rnrs/exceptions.scm
View file

@ -1,6 +1,6 @@
;;; exceptions.scm --- The R6RS exceptions library
;; Copyright (C) 2010 Free Software Foundation, Inc.
;; Copyright (C) 2010, 2011 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
@ -20,9 +20,19 @@
(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))
(only (guile) with-throw-handler *unspecified* @@))
(rnrs records inspection (6))
(only (guile)
format
newline
display
filter
set-exception-printer!
with-throw-handler
*unspecified*
@@))
(define raise (@@ (rnrs records procedural) r6rs-raise))
(define raise-continuable
@ -64,4 +74,73 @@
(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)
)