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

6 files changed, 80 insertions, 58 deletions

diff --git a/.gitignore b/.gitignore
index 02015c2..ef8fb45 100644
--- a/.gitignore
+++ b/.gitignore
@@ -5,3 +5,4 @@
 *.static*
 *.import*
 *.so
+*.tar.gz
diff --git a/lowlevel.scm b/lowlevel.scm
index e6bb9c5..1c338b5 100644
--- a/lowlevel.scm
+++ b/lowlevel.scm
@@ -33,7 +33,7 @@
 
 (define unique-id
   ;; Generate a fixnum, which will serve as the ID for each tagged
-  ;; procedure constructor.
+  ;; procedure constructor. This number is always positive.
   (let ((i 0))
     (lambda ()
       (set! i (fx+ i 1))
@@ -59,7 +59,6 @@ int i;
 closure[0] = C_CLOSURE_TYPE | (old_size + 1);
 for (i = 0; i < old_size; i++)
     C_block_item(closure, i) = C_block_item(proc, i);
-    // C_mutate_slot(&C_block_item(closure, i), C_block_item(proc, i));
 C_block_item(closure, old_size) = sig;
 
 C_return(closure);"))
@@ -80,12 +79,10 @@ closure[0] = C_CLOSURE_TYPE | size;
 
 for (i = 0; i < size; i++) {
     item = C_block_item(proc, i);
-    if (!C_immediatep(item) && C_pairp(item) && C_eqp(unique_symbol, C_u_i_car(item))) {
+    if (C_i_pairp(item) == C_SCHEME_TRUE && C_eqp(unique_symbol, C_u_i_car(item)) == C_SCHEME_TRUE) {
         C_block_item(closure, i) = sig;
-        // C_mutate_slot(&C_block_item(closure, i), sig);
     } else {
         C_block_item(closure, i) = item;
-        // C_mutate_slot(&C_block_item(closure, i), C_block_item(proc, i));
     }
 }
 
diff --git a/srfi-259.egg b/srfi-259.egg
index 278ef6f..f0dae1e 100644
--- a/srfi-259.egg
+++ b/srfi-259.egg
@@ -1,5 +1,5 @@
 ((author "Peter McGoron")
- (version "0.9.1")
+ (version "0.9.2")
  (synopsis "Tagged procedures with type safety")
  (category data)
  (license "MIT")
diff --git a/srfi-259.release-info b/srfi-259.release-info
index d57b6be..c108f0b 100644
--- a/srfi-259.release-info
+++ b/srfi-259.release-info
@@ -1,4 +1,5 @@
 (repo git "https://software.mcgoron.com/peter/srfi-259-egg.git")
 
-(uri targz "https://files.mcgoron.com/chicken/srfi-259-egg/0.9.0.tar.gz")
+(uri targz "https://files.mcgoron.com/chicken/srfi-259-egg/{release}.tar.gz")
+(release "0.9.1")
 (release "0.9.0")
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
diff --git a/tests/run.scm b/tests/run.scm
index a6a9f29..feb1cc1 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -96,4 +96,29 @@
   (test-assert "lists are not tagged" (not (tag-foo? '(1 2 3 4))))
   (raises-type-error "lists are not tagged" (tag-foo 'data '(1 2 3 4))))
 
+(import (chicken pretty-print))
+
+(define (debug-dump obj)
+  (let ((vec (make-vector (##sys#size obj))))
+    (display (##sys#size obj)) (newline)
+    (do ((i 0 (+ i 1)))
+        ((= i (##sys#size obj)) (newline))
+      (vector-set! vec i (##sys#slot obj i)))
+    (pp vec)
+    (newline)))
+
+(test-group "define-procedure-tag is a define form"
+  (let ()
+    (define (square x) (* x x))
+    (define-procedure-tag tag-order tag-order? get-tag-order)
+    (define tagged-square (tag-order 2 square))
+    (define-procedure-tag tag-pure tag-pure? get-tag-pure)
+    (define tagged-square (tag-pure #t tagged-square))
+    (test-assert "square is tag-order?" (tag-order? tagged-square))
+    (test-assert "square is tag-pure?" (tag-pure? tagged-square))
+    (test "square order" 2 (get-tag-order tagged-square))
+    (test-assert "square pure" (get-tag-pure tagged-square))
+    (test-assert "is a procedure?" (procedure? tagged-square))
+    (test "square value" (tagged-square 10) (square 10))))
+
 (test-end "SRFI 259")