use more specific exceptions0.9.1

1 files changed, 41 insertions, 13 deletions

diff --git a/srfi-259.sld b/srfi-259.sld
index 7a3dfb2..50f0e3e 100644
--- a/srfi-259.sld
+++ b/srfi-259.sld
@@ -31,6 +31,7 @@
   (export define-procedure-tag)
   (include "lowlevel.scm")
   (begin
+    (define is-type? (condition-predicate 'type))
     (define-syntax define-procedure-tag
       (syntax-rules ()
         ((define-procedure-tag constructor predicate? accessor)
@@ -43,7 +44,18 @@
            (let ((id (unique-id)))
              (set! constructor
                    (lambda (tag proc)
-                     (set-tagged-mapping proc id tag)))
+                     (handle-exceptions E (abort
+                                           (make-composite-condition
+                                            (make-property-condition
+                                             'exn
+                                             'location
+                                             (quote accessor)
+                                             'arguments
+                                             (list proc)
+                                             'message
+                                             "not a procedure")
+                                            E))
+                       (set-tagged-mapping proc id tag))))
              (set! predicate?
                    (lambda (proc)
                      (cond
@@ -52,15 +64,31 @@
                        (else #f))))
              (set! accessor
                    (lambda (proc)
-                     (let ((map (get-mapping proc))
-                           (raise-error (lambda ()
-                                          (raise
-                                           (make-property-condition
-                                            '(srfi-259 assertion-violation)
-                                            'message
-                                            "procedure does not contain id"
-                                            'arguments
-                                            (list proc id))))))
-                       (if map
-                           (fxmapping-ref map id raise-error)
-                           (raise-error))))))))))))
\ No newline at end of file
+                     (define map
+                       (handle-exceptions E (abort
+                                             (make-composite-condition
+                                              (make-property-condition
+                                               'exn
+                                               'location
+                                               (quote accessor)
+                                               'arguments
+                                               (list proc)
+                                               'message
+                                               "not a procedure")
+                                              E))
+                         (get-mapping proc)))
+                     (define (raise-error)
+                       (abort
+                        (make-composite-condition
+                         (make-property-condition 'exn
+                                                  'location
+                                                  (quote accessor)
+                                                  'arguments
+                                                  (list proc)
+                                                  'message
+                                                  "tag was not found")
+                         (make-property-condition 'assertion
+                                                  'tag))))
+                     (if map
+                         (fxmapping-ref map id raise-error)
+                         (raise-error)))))))))))
\ No newline at end of file