make define-procedure-tag a define form, and fix incorrect C primitive code

1 files changed, 49 insertions, 51 deletions

diff --git a/srfi-259.sld b/srfi-259.sld
index 50f0e3e..649f42d 100644
--- a/srfi-259.sld
+++ b/srfi-259.sld
@@ -35,60 +35,58 @@
     (define-syntax define-procedure-tag
       (syntax-rules ()
         ((define-procedure-tag constructor predicate? accessor)
-         ;; Hygiene is broken here on CHICKEN, because `id` is not renamed
-         ;; here. It needs to be lexical, not global.
-         (begin
-           (define constructor #f)
-           (define predicate? #f)
-           (define accessor #f)
+         ;; This uses `define-values` instead of a define for `id` because
+         ;; Chicken breaks hygiene for top-level `define` names.
+         (define-values (constructor predicate? accessor)
            (let ((id (unique-id)))
-             (set! constructor
-                   (lambda (tag proc)
-                     (handle-exceptions E (abort
-                                           (make-composite-condition
-                                            (make-property-condition
-                                             'exn
+             (values
+              ;; constructor
+              (lambda (tag proc)
+                (handle-exceptions E (abort
+                                      (make-composite-condition
+                                       (make-property-condition
+                                        'exn
+                                        'location
+                                        (quote constructor)
+                                        'arguments
+                                        (list proc)
+                                        'message
+                                        "not a procedure")
+                                       E))
+                  (set-tagged-mapping proc id tag)))
+              ;; predicate?
+              (lambda (proc)
+                (cond
+                  ((not (procedure? proc)) #f)
+                  ((get-mapping proc)
+                   => (cut fxmapping-contains? <> id))
+                  (else #f)))
+              ;; accessor
+              (lambda (proc)
+                (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
-                                             "not a procedure")
-                                            E))
-                       (set-tagged-mapping proc id tag))))
-             (set! predicate?
-                   (lambda (proc)
-                     (cond
-                       ((not (procedure? proc)) #f)
-                       ((get-mapping proc) => (cut fxmapping-contains? <> id))
-                       (else #f))))
-             (set! accessor
-                   (lambda (proc)
-                     (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
+                                             "tag was not found")
+                    (make-property-condition 'assertion))))
+                (if map
+                    (fxmapping-ref map id raise-error)
+                    (raise-error)))))))))))
\ No newline at end of file