dispcond.scm 1.9 KB

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