condition.scm 1.9 KB

123456789101112131415161718192021222324252627282930313233343536
  1. ; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.
  2. ; Retrofit the RTS's condition type as R6RS records.
  3. (define-retrofitted-record-type &condition rts:&condition #f #f #f)
  4. (define-retrofitted-record-type (&message &condition) rts:&message #f #f #f (immutable message))
  5. (define-retrofitted-record-type (&warning &condition) rts:&warning #f #f #f)
  6. (define-retrofitted-record-type (&serious &condition) rts:&serious #f #f #f)
  7. (define-retrofitted-record-type (&error &serious) rts:&error #f #f #f)
  8. (define-retrofitted-record-type (&violation &serious) rts:&violation #f #f #f)
  9. (define-retrofitted-record-type (&non-continuable &violation) rts:&non-continuable #f #f #f)
  10. (define-retrofitted-record-type (&implementation-restriction &violation) rts:&implementation-restriction #f #f #f)
  11. (define-retrofitted-record-type (&lexical &violation) rts:&lexical #f #f #f)
  12. (define-retrofitted-record-type (&syntax &violation) rts:&syntax #f #f #f
  13. (immutable form) (immutable subform))
  14. (define-retrofitted-record-type (&undefined &violation) rts:&undefined #f #f #f)
  15. (define-retrofitted-record-type (&assertion &violation) rts:&assertion #f #f #f)
  16. (define-retrofitted-record-type (&irritants &condition) rts:&irritants #f #f #f)
  17. (define-retrofitted-record-type (&who &condition) rts:&who #f #f #f)
  18. (define-syntax define-condition-type
  19. (syntax-rules ()
  20. ((define-condition-type ?name ?supertype ?constructor ?predicate
  21. (?field1 ?accessor1) ...)
  22. (begin
  23. (define rts-supertype (record-type-descriptor ?supertype))
  24. (rts:define-condition-type rts-name rts-supertype ?constructor ?predicate
  25. (?field1 ?accessor1) ...)
  26. ;; the default discloser uses the wrong name; overwrite
  27. (define-record-discloser rts-name
  28. (lambda (r)
  29. (list '?name (?accessor1 r) ...)))
  30. (define-retrofitted-record-type (?name ?supertype) rts-name #f #f #f
  31. (immutable ?field1) ...)))))