File: dispcond.scm

package info (click to toggle)
scsh 0.5.1-2
  • links: PTS
  • area: non-free
  • in suites: potato, slink
  • size: 6,540 kB
  • ctags: 8,656
  • sloc: lisp: 39,346; ansic: 13,466; sh: 1,669; makefile: 624
file content (77 lines) | stat: -rw-r--r-- 1,991 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
; Copyright (c) 1993, 1994 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))))))))))))