preparing for CHICKEN 6

7 files changed, 110 insertions, 34 deletions

diff --git a/README.md b/README.md
index 96a5fd2..1a696b5 100644
--- a/README.md
+++ b/README.md
@@ -6,7 +6,6 @@ Notable features:
 
 * Different than `extend-procedure`, because `extend-procedure` is
   stateful.
-* Uses an efficient set type (integer maps) to store tags.
 
 This is the first time I've written low-level CHICKEN code: use at your own
 risk.
@@ -14,7 +13,7 @@ risk.
 ## Usage
 
 Import `(srfi 259)` for only the standard bindings. Import
-`(srfi 259 extensions)` for the SRFI-259 macro and the extensions
+`(extensions srfi 259)` for the SRFI-259 macro and the extensions
 described below.
 
 ## Extensions
diff --git a/extensions.sld b/extensions.sld
index 3612398..bc6c047 100644
--- a/extensions.sld
+++ b/extensions.sld
@@ -21,9 +21,8 @@
  | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  |#
 
-(define-library (srfi 259 extensions)
+(define-library (extensions srfi 259)
   (import (scheme base)
-          integer-map
           (chicken base)
           (chicken foreign)
           (chicken condition)
diff --git a/internal.scm b/internal.scm
index 8db7999..89705bd 100644
--- a/internal.scm
+++ b/internal.scm
@@ -28,7 +28,8 @@
     (cond
       ((not (procedure? proc)) #f)
       ((get-mapping proc)
-       => (cut fxmapping-contains? <> id))
+       =>
+       (lambda (alist) (pair? (assv id alist))))
       (else #f))))
 
 (define (create-accessor id)
@@ -45,7 +46,7 @@
                               'message
                               "not a procedure")
                              E))
-        (get-mapping proc)))
+                         (get-mapping proc)))
     (define (raise-error)
       (abort
        (make-composite-condition
@@ -57,9 +58,10 @@
                                  'message
                                  "tag was not found")
         (make-property-condition 'assertion))))
-    (if map
-        (fxmapping-ref map id raise-error)
-        (raise-error))))
+    (cond
+      ((not map) (raise-error))
+      ((assv id map) => cdr)
+      (else (raise-error)))))
 
 ;;; ;;;;;;;;;;;;;;;
 ;;; Bootstrapping
@@ -71,6 +73,14 @@
 (define procedure/self-tag -1)
 (define procedure/self? (create-predicate procedure/self-tag))
 
+(define (set-assv key val alist)
+  (cond
+    ((null? alist) (list (cons key val)))
+    ((eqv? key (caar alist)) (cons (cons key val)
+                                   (cdr alist)))
+    (else (cons (car alist)
+                (set-assv key val (cdr alist))))))
+
 (define (create-constructor id)
   (lambda (tag proc)
     (cond
@@ -94,20 +104,19 @@
                   (create/signifier-pair (lambda args
                                            (apply base nproc args))
                                          (make-signifier
-                                          (fxmapping-set (get-mapping proc)
-                                                         id
-                                                         tag)))))
+                                          (set-assv id tag
+                                                    (get-mapping proc))))))
          nproc))
       ((tagged-procedure? proc)
        (let ((map (get-mapping proc)))
          (set-signifier-pair proc
                              unique-symbol
                              (make-signifier
-                              (fxmapping-set map id tag)))))
+                              (set-assv id tag map)))))
       (else (create/signifier-pair proc
                                    (make-signifier
-                                    (fxmapping id tag
-                                               0 proc)))))))
+                                    (list (cons id tag)
+                                          (cons 0 proc))))))))
 
 (define tag/this (create-constructor -1))
 
diff --git a/srfi-259.egg b/srfi-259.egg
index 5581e4d..76a252a 100644
--- a/srfi-259.egg
+++ b/srfi-259.egg
@@ -1,19 +1,31 @@
 ((author "Peter McGoron")
- (version "1.1.0")
+ (version "2.0.0")
  (synopsis "Tagged procedures with type safety (with SRFI-229 compatability)")
  (category data)
  (license "MIT")
- (dependencies r7rs integer-map)
+ (dependencies r7rs)
  (test-dependencies test)
  (components (extension srfi-259
                (source "srfi-259.sld")
-               (component-dependencies srfi.259.extensions)
-               (csc-options "-R" "r7rs" "-X" "r7rs" "-O3"))
-             (extension srfi.259.extensions
+               (component-dependencies extensions.srfi.259)
+               (cond-expand
+                (chicken-6
+                  (csc-options "-O3"))
+                (else
+                 (csc-options "-R" "r7rs" "-X" "r7rs" "-O3"))))
+             (extension extensions.srfi.259
                (source "extensions.sld")
                (source-dependencies "lowlevel.scm" "internal.scm")
-               (csc-options "-R" "r7rs" "-X" "r7rs" "-O3"))
+               (cond-expand
+                (chicken-6
+                  (csc-options "-O3"))
+                (else
+                 (csc-options "-R" "r7rs" "-X" "r7rs" "-O3"))))
              (extension srfi-229
                (source "srfi-229.sld")
                (component-dependencies srfi-259)
-               (csc-options "-R" "r7rs" "-X" "r7rs" "-O3"))))
+               (cond-expand
+                (chicken-6
+                  (csc-options "-O3"))
+                (else
+                 (csc-options "-R" "r7rs" "-X" "r7rs" "-O3"))))))
diff --git a/srfi-259.release-info b/srfi-259.release-info
index 0e3f006..2fddba2 100644
--- a/srfi-259.release-info
+++ b/srfi-259.release-info
@@ -1,6 +1,7 @@
 (repo git "https://software.mcgoron.com/peter/srfi-259-egg.git")
 
 (uri targz "https://files.mcgoron.com/chicken/srfi-259-egg/{egg-release}-{chicken-release}.tar.gz")
+(release "1.1.1")
 (release "1.1.0")
 (release "1.0.0")
 (release "0.10.0")
diff --git a/srfi-259.sld b/srfi-259.sld
index f302ebb..cef8f63 100644
--- a/srfi-259.sld
+++ b/srfi-259.sld
@@ -22,5 +22,5 @@
  |#
 
 (define-library (srfi 259)
-  (import (scheme base) (srfi 259 extensions))
+  (import (scheme base) (extensions srfi 259))
   (export define-procedure-tag))
\ No newline at end of file
diff --git a/tests/run.scm b/tests/run.scm
index f965ba3..41269d8 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -22,7 +22,15 @@
  | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  |#
 
-(import r7rs test (chicken condition) (chicken gc) (srfi 259 extensions) (srfi 229))
+(import test
+        (chicken condition)
+        (chicken gc)
+        (extensions srfi 259)
+        (srfi 229))
+
+(cond-expand
+ (chicken-5 (import r7rs))
+ (else))
 
 (test-begin "SRFI 259")
 
@@ -34,66 +42,99 @@
          (tagged (tag-foo 'bar (lambda (x)
                                  (set! var (+ var x))
                                  var))))
+    (gc #t)
     (test-assert "tag-foo is tag-foo?" (tag-foo? tagged))
+    (gc #t)
     (test "get-tag-foo returns tagged value" 'bar (get-tag-foo tagged))
+    (gc #t)
     (test "var is previous value" 100 var)
+    (gc #t)
     (test "tagged procedure is callable" 110 (tagged 10))
+    (gc #t)
     (test "var has changed" 110 var)
+    (gc #t)
     (test-assert "not tag-baz?" (not (tag-baz? tagged)))
+    (gc #t)
     (test "get-tag-baz raises an exception"
           'assertion
           (condition-case (begin (get-tag-baz tagged) 'success)
                           ((exn assertion) 'assertion)
                           (exn () 'error)))
+    (gc #t)
     (test-group "tagged again"
       (let ((tagged-again (tag-foo 'quux tagged)))
+        (gc #t)
         (test-assert "tagging again retains tag-foo?" (tag-foo? tagged-again))
+        (gc #t)
         (test "tagging again sets new value" 'quux (get-tag-foo tagged-again))
-        (gc #f)
+        (gc #t)
         (test "tagging again retains old value in previous procedure" 'bar (get-tag-foo tagged))
+        (gc #t)
         (test-assert "the procedures not eqv?" (not (eqv? tagged tagged-again)))
+        (gc #t)
         (test "tagging again returns a procedure" 150 (tagged 40))
-        (test "var has changed" 150 var)))
+        (gc #t)
+        (test "var has changed" 150 var)
+        (gc #t)))
     (test-group "tagged baz"
       (let ((tagged-baz (tag-baz 'corge tagged)))
         (test-assert "tag-baz?" (tag-baz? tagged-baz))
+        (gc #t)
         (test-assert "tag-baz and tag-foo?" (tag-foo? tagged-baz))
+        (gc #t)
         (test "retains get-tag-foo" 'bar (get-tag-foo tagged-baz))
+        (gc #t)
         (test "retains get-tag-baz" 'corge (get-tag-baz tagged-baz))
-        (test-assert "previous procedure is not tag-baz?" (not (tag-baz? tagged)))))))
+        (gc #t)
+        (test-assert "previous procedure is not tag-baz?" (not (tag-baz? tagged)))
+        (gc #t)))))
 
 (test-group "tagging imported procedures"
   (let* ((tagged (tag-foo 'foo +))
          (tagged (tag-baz 'baz tagged)))
     (test-assert "not tag-foo?" (not (tag-foo? +)))
+    (gc #t)
     (test-assert "not tag-baz?" (not (tag-baz? +)))
+    (gc #t)
     (test-assert "tag-foo?" (tag-foo? tagged))
+    (gc #t)
     (test-assert "tag-baz?" (tag-baz? tagged))
+    (gc #t)
     (test "operationally the same procedure?"
           (+ 50 50)
           (tagged 50 50))
+    (gc #t)
     (test "get-tag-foo" 'foo (get-tag-foo tagged))
-    (test "get-tag-baz" 'baz (get-tag-baz tagged))))
+    (gc #t)
+    (test "get-tag-baz" 'baz (get-tag-baz tagged))
+    (gc #t)))
 
 (define-syntax raises-type-error
   (syntax-rules ()
     ((raises-type-error name expr)
-     (test name
-           'type
-           (condition-case (begin expr 'success)
-                           ((exn type) 'type)
-                           (var () (display (condition->list var)) 'error))))))
+     (begin
+       (test name
+             'type
+             (condition-case (begin expr 'success)
+                             ((exn type) 'type)
+                             (var () (display (condition->list var)) 'error)))
+       (gc #t)))))
 
 (test-group "predicates on other objects"
   (test-assert "integers are not tagged" (not (tag-foo? 0)))
+  (gc #t)
   (raises-type-error "integers are not tagged" (tag-foo 'data 0))
   (test-assert "strings are not tagged" (not (tag-foo? "hello")))
+  (gc #t)
   (raises-type-error "strings are not tagged" (tag-foo 'data "hello"))
   (test-assert "bytevectors are not tagged" (not (tag-foo? #u8(1 2 3 4))))
+  (gc #t)
   (raises-type-error "bytevectors are not tagged" (tag-foo 'data #u8(1 2 3 4)))
   (test-assert "vectors are not tagged" (not (tag-foo? #(call/cc))))
+  (gc #t)
   (raises-type-error "vectors are not tagged" (tag-foo 'data #(call/cc)))
   (test-assert "lists are not tagged" (not (tag-foo? '(1 2 3 4))))
+  (gc #t)
   (raises-type-error "lists are not tagged" (tag-foo 'data '(1 2 3 4))))
 
 (test-group "define-procedure-tag is a define form"
@@ -104,11 +145,17 @@
     (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))
+    (gc #t)
     (test-assert "square is tag-pure?" (tag-pure? tagged-square))
+    (gc #t)
     (test "square order" 2 (get-tag-order tagged-square))
+    (gc #t)
     (test-assert "square pure" (get-tag-pure tagged-square))
+    (gc #t)
     (test-assert "is a procedure?" (procedure? tagged-square))
-    (test "square value" (tagged-square 10) (square 10))))
+    (gc #t)
+    (test "square value" (tagged-square 10) (square 10))
+    (gc #t)))
 
 (test-end "SRFI 259")
 
@@ -122,15 +169,24 @@
   x)
 
 (test "no tag" 10 (try-this 10))
+(gc #t)
 
 (define new-try-this (tag-foo 10 try-this))
 (test "with tag-foo" 20 (new-try-this 10))
+(gc #t)
+
 (test "does not affect the one with no tag" 10 (try-this 10))
+(gc #t)
 
 (define new-new-try-this (tag-baz 20 new-try-this))
 (test "with tag-baz" 40 (new-new-try-this 10))
+(gc #t)
+
 (test "does not affect the one with tag-foo" 20 (new-try-this 10))
+(gc #t)
+
 (test "does not affect the one with no tag" 10 (try-this 10))
+(gc #t)
 
 (test-end "SRFI 259 extensions")