/usr/share/scheme48-1.9/env/dispcond.scm is in scheme48 1.9-5.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 | ; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
; Displaying conditions
(define display-condition
(let ((display display) (newline newline))
(lambda (c port . rest)
(let ((depth (if (pair? rest)
(car rest)
5))
(length (if (and (pair? rest) (pair? (cdr rest)))
(cadr rest)
6)))
(if (ignore-errors (lambda ()
(newline port)
(really-display-condition c port depth length)
#f))
(begin (display "<Error while displaying condition.>" port)
(newline port)))))))
(define (really-display-condition c port depth length)
(call-with-values
(lambda () (decode-condition c))
(lambda (type who message stuff)
(display type port)
(display ": " port)
(if (string? message)
(display message port)
(limited-write message port depth length))
(let ((spaces
(make-string (+ (string-length (symbol->string type)) 2)
#\space)))
(if who
(begin
(display " [" port)
(display who port)
(display "]" port)))
(for-each (lambda (irritant)
(newline port)
(display spaces port)
(limited-write irritant port depth length))
stuff))))
(newline port))
(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))))))))))))
|