preparing for CHICKEN 6

1 files changed, 20 insertions, 11 deletions

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))