scsh-0.6/scheme/env/dispcond.scm

78 lines
1.9 KiB
Scheme
Raw Normal View History

1999-09-14 08:45:02 -04:00
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Displaying conditions
(define display-condition
(let ((display display) (newline newline))
(lambda (c port)
(if (ignore-errors (lambda ()
(newline port)
(really-display-condition c port)
#f))
(begin (display "<Error while displaying condition.>" port)
(newline port))))))
(define (really-display-condition c port)
(let* ((stuff (disclose-condition c))
(stuff (if (and (list? stuff)
(not (null? stuff))
(symbol? (car stuff)))
stuff
(list 'condition stuff))))
(display-type-name (car stuff) port)
(if (not (null? (cdr stuff)))
(begin (display ": " port)
(let ((message (cadr stuff)))
(if (string? message)
(display message port)
(limited-write message port *depth* *length*)))
(let ((spaces
(make-string (+ (string-length
(symbol->string (car stuff)))
2)
#\space)))
(for-each (lambda (irritant)
(newline port)
(display spaces port)
(limited-write irritant port *depth* *length*))
(cddr stuff)))))
(newline port)))
(define *depth* 5)
(define *length* 6)
(define-generic disclose-condition &disclose-condition)
(define-method &disclose-condition (c) c)
(define (limited-write obj port max-depth max-length)
(let recur ((obj obj) (depth 0))
(if (and (= depth max-depth)
(not (or (boolean? obj)
(null? obj)
(number? obj)
(symbol? obj)
(char? obj)
(string? obj))))
(display "#" port)
(call-with-current-continuation
(lambda (escape)
(recurring-write obj port
(let ((count 0))
(lambda (sub)
(if (= count max-length)
(begin (display "---" port)
(write-char
(if (or (pair? obj) (vector? obj))
#\)
#\})
port)
(escape #t))
(begin (set! count (+ count 1))
(recur sub (+ depth 1))))))))))))