1; Part of Scheme 48 1.9.  See file COPYING for notices and license.
2
3; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
4
5
6
7; Displaying conditions
8
9(define display-condition
10  (let ((display display) (newline newline))
11    (lambda (c port . rest)
12      (let ((depth (if (pair? rest)
13		       (car rest)
14		       5))
15	    (length (if (and (pair? rest) (pair? (cdr rest)))
16			(cadr rest)
17			6)))
18	(if (ignore-errors (lambda ()
19			     (newline port)
20			     (really-display-condition c port depth length)
21			     #f))
22	    (begin (display "<Error while displaying condition.>" port)
23		   (newline port)))))))
24
25(define (really-display-condition c port depth length)
26  (call-with-values
27      (lambda () (decode-condition c))
28    (lambda (type who message stuff)
29      (display type port)
30      (display ": " port)
31      (if (string? message)
32	  (display message port)
33	  (limited-write message port depth length))
34      (let ((spaces
35	     (make-string (+ (string-length (symbol->string type)) 2)
36			  #\space)))
37	(if who
38	    (begin
39	      (display " [" port)
40	      (display who port)
41	      (display "]" port)))
42	(for-each (lambda (irritant)
43		    (newline port)
44		    (display spaces port)
45		    (limited-write irritant port depth length))
46		  stuff))))
47  (newline port))
48
49(define (limited-write obj port max-depth max-length)
50  (let recur ((obj obj) (depth 0))
51    (if (and (= depth max-depth)
52	     (not (or (boolean? obj)
53		      (null? obj)
54		      (number? obj)
55		      (symbol? obj)
56		      (char? obj)
57		      (string? obj))))
58	(display "#" port)
59	(call-with-current-continuation
60	  (lambda (escape)
61	    (recurring-write obj port
62	      (let ((count 0))
63		(lambda (sub)
64		  (if (= count max-length)
65		      (begin (display "---" port)
66			     (write-char
67			      (if (or (pair? obj) (vector? obj))
68				  #\)
69				  #\})
70			      port)
71			     (escape #t))
72		      (begin (set! count (+ count 1))
73			     (recur sub (+ depth 1))))))))))))
74
75