Export some common comparers from hash-map.

5 files changed, 74 insertions, 48 deletions

diff --git a/csc/cps.csc b/csc/cps.csc
index e7f0fe6..81ba933 100644
--- a/csc/cps.csc
+++ b/csc/cps.csc
@@ -10,6 +10,7 @@
             insert
             key-not-found-error?
             lookup
+            make-comparer
             make-map
             map->alist
             merge)
@@ -315,14 +316,18 @@
         (_ (error "unexpected type in to-cps" expr))))
 
 
-    (define (make-ref-map)
-      (make-map
+    (define compare-refs
+      (make-comparer
         (lambda (ref)
           (gensym->int (lexical-ref-gensym ref)))
         (lambda (x y)
           (- (gensym->int (lexical-ref-gensym y)) (gensym->int (lexical-ref-gensym x))))))
 
 
+    (define (make-ref-map)
+      (make-map compare-refs))
+
+
     (define (get-boxed expr)
       (match expr
         ((% %update ref _ continuation)
diff --git a/csc/hash-map-test.csc b/csc/hash-map-test.csc
index 7885908..da58e69 100644
--- a/csc/hash-map-test.csc
+++ b/csc/hash-map-test.csc
@@ -12,19 +12,8 @@
         (csc hash-map))
 
 
-(define (hash-symbol s)
-  (hash-bytevector (string->utf8 (symbol->string s))))
-
-
-(define (cmp-symbols s1 s2)
-  (cond
-    ((symbol=? s1 s2) 0)
-    ((string<? (symbol->string s1) (symbol->string s2)) -1)
-    (else 1)))
-
-
 (define (alist->map->alist l)
-  (map->alist (alist->map hash-symbol cmp-symbols l)))
+  (map->alist (alist->map compare-symbols l)))
 
 
 (test map->alist-singleton
@@ -78,18 +67,18 @@
 (test lookup
   (assert-equal
     2
-    (lookup (alist->map hash-symbol cmp-symbols '((a . 1) (b . 2) (c . 3))) 'b)))
+    (lookup (alist->map compare-symbols '((a . 1) (b . 2) (c . 3))) 'b)))
 
 
 (test lookup-notfound
   (assert-raises key-not-found-error?
-    (lookup (alist->map hash-symbol cmp-symbols '((a . 1) (b . 2) (c . 3))) 'd)))
+    (lookup (alist->map compare-symbols '((a . 1) (b . 2) (c . 3))) 'd)))
 
 
 (test lookup-default
   (assert-equal
     #f
-    (lookup (alist->map hash-symbol cmp-symbols '((a . #t) (b . #t))) 'c #f)))
+    (lookup (alist->map compare-symbols '((a . #t) (b . #t))) 'c #f)))
 
 
 (define transform-map
@@ -98,7 +87,7 @@
 
 
 (define (test-map . bindings)
-  (alist->map hash-symbol cmp-symbols bindings))
+  (alist->map compare-symbols bindings))
 
 
 (test merge
diff --git a/csc/hash-map.csc b/csc/hash-map.csc
index 5a604ad..064b4ae 100644
--- a/csc/hash-map.csc
+++ b/csc/hash-map.csc
@@ -1,17 +1,24 @@
 (define-library (csc hash-map)
   (export
     alist->map
+    compare-numbers
+    compare-strings
+    compare-symbols
+    delete
     hash-bytevector
     insert
     key-not-found-error?
     lookup
+    make-comparer
     make-map
-    delete
     map->alist
     map-for-each
     map?
     merge)
   (import (scheme base)
+          (only (csc loop)
+            loop
+            return)
           (only (csc match)
             define-match-record-type
             match)
@@ -198,8 +205,15 @@
       (root map-root))
 
 
-    (define (make-map hash cmp)
-      (construct-map hash cmp '()))
+    (define-record-type <comparer>
+      (make-comparer hash cmp)
+      comparer?
+      (hash comparer-hash)
+      (cmp comparer-cmp))
+
+
+    (define (make-map comparer)
+      (construct-map (comparer-hash comparer) (comparer-cmp comparer) '()))
 
 
     (define (shuffle n)
@@ -269,12 +283,11 @@
         alist))
 
 
-    (define (alist->map hash cmp alist)
-      (let loop ((alist alist)
-                 (m (make-map hash cmp)))
-        (if (null? alist)
-            m
-          (loop (cdr alist) (insert m (caar alist) (cdar alist))))))
+    (define (alist->map comparer alist)
+      (loop with m = (make-map comparer)
+            for elem in alist
+            do (set! m (insert m (car elem) (cdr elem)))
+            finally (return m)))
 
 
     (define (hash-bytevector b)
@@ -285,6 +298,32 @@
           (loop (+ 1 i) (+ (* hash #x100) (bytevector-u8-ref b i))))))
 
 
+    (define compare-symbols
+      (make-comparer
+        (lambda (s) (hash-bytevector (string->utf8 (symbol->string s))))
+        (lambda (s1 s2)
+          (cond
+            ((symbol=? s1 s2) 0)
+            ((string<? (symbol->string s1) (symbol->string s2)) -1)
+            (else 1)))))
+
+
+    (define compare-numbers
+      (make-comparer
+        (lambda (x) x)
+        (lambda (y x) (- y x))))
+
+
+    (define compare-strings
+      (make-comparer
+        (lambda (s) (hash-bytevector (string->utf8 s)))
+        (lambda (s1 s2)
+          (cond
+            ((string=? s1 s2) 0)
+            ((string<? (symbol->string s1) (symbol->string s2)) -1)
+            (else 1)))))
+
+
     (define (merge2 m1 m2)
       (let ((m1 m1))
         (map-for-each
diff --git a/csc/linker.csc b/csc/linker.csc
index 3327909..b840c15 100644
--- a/csc/linker.csc
+++ b/csc/linker.csc
@@ -4,8 +4,8 @@
           (only (csc encoding) encode)
           (only (csc format) sprintf)
           (only (csc hash-map)
-            hash-bytevector
             insert
+            compare-strings
             lookup
             make-map)
           (only (csc list)
@@ -37,19 +37,8 @@
             (_ #f)))
 
 
-    (define (hash-string s)
-      (hash-bytevector (string->utf8 s)))
-
-
-    (define (cmp-strings s1 s2)
-      (cond
-        ((string=? s1 s2) 0)
-        ((string<? s1 s2) -1)
-        (else 1)))
-
-
     (define (make-label-map program)
-      (let loop ((m (make-map hash-string cmp-strings))
+      (let loop ((m (make-map compare-strings))
                  (program program)
                  (i 0))
         (match program
diff --git a/csc/macros.csc b/csc/macros.csc
index 1edecd2..9afeea9 100644
--- a/csc/macros.csc
+++ b/csc/macros.csc
@@ -17,6 +17,7 @@
             insert
             key-not-found-error?
             lookup
+            make-comparer
             map-for-each
             merge)
           (only (csc ir1)
@@ -383,17 +384,20 @@
             finally (return (< (length m1) (length m2)))))
 
 
-    (define (cmp-identifiers i1 i2)
-      (cond
-        ((bound-identifier=? i1 i2) 0)
-        ((or (string<? (symbol->string (identifier-name i1)) (symbol->string (identifier-name i2)))
-             (marks<? (marks i1) (marks i2)))
-          -1)
-        (else 1)))
+    (define compare-identifiers
+      (make-comparer
+        hash-identifier
+        (lambda (i1 i2)
+          (cond
+            ((bound-identifier=? i1 i2) 0)
+            ((or (string<? (symbol->string (identifier-name i1)) (symbol->string (identifier-name i2)))
+                 (marks<? (marks i1) (marks i2)))
+              -1)
+            (else 1)))))
 
 
     (define (alist->substitutions l)
-      (alist->map hash-identifier cmp-identifiers l))
+      (alist->map compare-identifiers l))
 
 
     (define (is-underscore expression)