exceptions.scm 5.7 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147
  1. ;;; exceptions.scm --- The R6RS exceptions library
  2. ;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
  3. ;;
  4. ;; This library is free software; you can redistribute it and/or
  5. ;; modify it under the terms of the GNU Lesser General Public
  6. ;; License as published by the Free Software Foundation; either
  7. ;; version 3 of the License, or (at your option) any later version.
  8. ;;
  9. ;; This library is distributed in the hope that it will be useful,
  10. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  12. ;; Lesser General Public License for more details.
  13. ;;
  14. ;; You should have received a copy of the GNU Lesser General Public
  15. ;; License along with this library; if not, write to the Free Software
  16. ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17. (library (rnrs exceptions (6))
  18. (export guard with-exception-handler raise raise-continuable)
  19. (import (rnrs base (6))
  20. (rnrs control (6))
  21. (rnrs conditions (6))
  22. (rnrs records procedural (6))
  23. (rnrs records inspection (6))
  24. (only (guile)
  25. format
  26. newline
  27. display
  28. filter
  29. set-exception-printer!
  30. with-throw-handler
  31. *unspecified*
  32. @@))
  33. (define raise (@@ (rnrs records procedural) r6rs-raise))
  34. (define raise-continuable
  35. (@@ (rnrs records procedural) r6rs-raise-continuable))
  36. (define raise-object-wrapper?
  37. (@@ (rnrs records procedural) raise-object-wrapper?))
  38. (define raise-object-wrapper-obj
  39. (@@ (rnrs records procedural) raise-object-wrapper-obj))
  40. (define raise-object-wrapper-continuation
  41. (@@ (rnrs records procedural) raise-object-wrapper-continuation))
  42. (define (with-exception-handler handler thunk)
  43. (with-throw-handler 'r6rs:exception
  44. thunk
  45. (lambda (key . args)
  46. (if (and (not (null? args))
  47. (raise-object-wrapper? (car args)))
  48. (let* ((cargs (car args))
  49. (obj (raise-object-wrapper-obj cargs))
  50. (continuation (raise-object-wrapper-continuation cargs))
  51. (handler-return (handler obj)))
  52. (if continuation
  53. (continuation handler-return)
  54. (raise (make-non-continuable-violation))))
  55. *unspecified*))))
  56. (define-syntax guard0
  57. (syntax-rules ()
  58. ((_ (variable cond-clause ...) . body)
  59. (call/cc (lambda (continuation)
  60. (with-exception-handler
  61. (lambda (variable)
  62. (continuation (cond cond-clause ...)))
  63. (lambda () . body)))))))
  64. (define-syntax guard
  65. (syntax-rules (else)
  66. ((_ (variable cond-clause ... . ((else else-clause ...))) . body)
  67. (guard0 (variable cond-clause ... (else else-clause ...)) . body))
  68. ((_ (variable cond-clause ...) . body)
  69. (guard0 (variable cond-clause ... (else (raise variable))) . body))))
  70. ;;; Exception printing
  71. (define (exception-printer port key args punt)
  72. (cond ((and (= 1 (length args))
  73. (raise-object-wrapper? (car args)))
  74. (let ((obj (raise-object-wrapper-obj (car args))))
  75. (cond ((condition? obj)
  76. (display "ERROR: R6RS exception:\n" port)
  77. (format-condition port obj))
  78. (else
  79. (format port "ERROR: R6RS exception: `~s'" obj)))))
  80. (else
  81. (punt))))
  82. (define (format-condition port condition)
  83. (let ((components (simple-conditions condition)))
  84. (if (null? components)
  85. (format port "Empty condition object")
  86. (let loop ((i 1) (components components))
  87. (cond ((pair? components)
  88. (format port " ~a. " i)
  89. (format-simple-condition port (car components))
  90. (when (pair? (cdr components))
  91. (newline port))
  92. (loop (+ i 1) (cdr components))))))))
  93. (define (format-simple-condition port condition)
  94. (define (print-rtd-fields rtd field-names)
  95. (let ((n-fields (vector-length field-names)))
  96. (do ((i 0 (+ i 1)))
  97. ((>= i n-fields))
  98. (format port " ~a: ~s"
  99. (vector-ref field-names i)
  100. ((record-accessor rtd i) condition))
  101. (unless (= i (- n-fields 1))
  102. (newline port)))))
  103. (let ((condition-name (record-type-name (record-rtd condition))))
  104. (let loop ((rtd (record-rtd condition))
  105. (rtd.fields-list '())
  106. (n-fields 0))
  107. (cond (rtd
  108. (let ((field-names (record-type-field-names rtd)))
  109. (loop (record-type-parent rtd)
  110. (cons (cons rtd field-names) rtd.fields-list)
  111. (+ n-fields (vector-length field-names)))))
  112. (else
  113. (let ((rtd.fields-list
  114. (filter (lambda (rtd.fields)
  115. (not (zero? (vector-length (cdr rtd.fields)))))
  116. (reverse rtd.fields-list))))
  117. (case n-fields
  118. ((0) (format port "~a" condition-name))
  119. ((1) (format port "~a: ~s"
  120. condition-name
  121. ((record-accessor (caar rtd.fields-list) 0)
  122. condition)))
  123. (else
  124. (format port "~a:\n" condition-name)
  125. (let loop ((lst rtd.fields-list))
  126. (when (pair? lst)
  127. (let ((rtd.fields (car lst)))
  128. (print-rtd-fields (car rtd.fields) (cdr rtd.fields))
  129. (when (pair? (cdr lst))
  130. (newline port))
  131. (loop (cdr lst)))))))))))))
  132. (set-exception-printer! 'r6rs:exception exception-printer)
  133. )