diff options
| -rw-r--r-- | csc/hash-map-test.csc | 13 | ||||
| -rw-r--r-- | csc/hash-map.csc | 61 | ||||
| -rw-r--r-- | csc/linker.csc | 9 |
3 files changed, 48 insertions, 35 deletions
diff --git a/csc/hash-map-test.csc b/csc/hash-map-test.csc index 353e6b4..3e26570 100644 --- a/csc/hash-map-test.csc +++ b/csc/hash-map-test.csc @@ -15,8 +15,15 @@ (string<? (symbol->string s1) (symbol->string s2))) +(define (cmp-symbols s1 s2) + (cond + ((symbol<? s1 s2) -1) + ((symbol=? s1 s2) 0) + (else 1))) + + (define (alist->map->alist l) - (map->alist (alist->map hash-symbol symbol<? l))) + (map->alist (alist->map hash-symbol cmp-symbols l))) (define (sort-alist l) @@ -70,9 +77,9 @@ (test lookup (assert-equal 2 - (lookup (alist->map hash-symbol symbol<? '((a . 1) (b . 2) (c . 3))) 'b))) + (lookup (alist->map hash-symbol cmp-symbols '((a . 1) (b . 2) (c . 3))) 'b))) (test lookup-notfound (assert-raises key-not-found-error? - (lookup (alist->map hash-symbol symbol<? '((a . 1) (b . 2) (c . 3))) 'd))) + (lookup (alist->map hash-symbol cmp-symbols '((a . 1) (b . 2) (c . 3))) 'd))) diff --git a/csc/hash-map.csc b/csc/hash-map.csc index 01d4158..2862e84 100644 --- a/csc/hash-map.csc +++ b/csc/hash-map.csc @@ -21,15 +21,14 @@ (hash key-hash-hash)) - (define (key-hash<? k1 k2 key<?) + (define (key-hash<? k1 k2 cmp) (cond ((< (key-hash-hash k1) (key-hash-hash k2)) #t) ((> (key-hash-hash k1) (key-hash-hash k2)) #f) - ((key<? (key-hash-value k1) (key-hash-value k2)) #t) - (else #f))) + (else (< (cmp (key-hash-value k1) (key-hash-value k2)) 0)))) - (define (key-hash=? k1 k2) - (and (= (key-hash-hash k1) (key-hash-hash k2)) (eqv? (key-hash-value k1) (key-hash-value k2)))) + (define (key-hash=? k1 k2 cmp) + (and (= (key-hash-hash k1) (key-hash-hash k2)) (= 0 (cmp (key-hash-value k1) (key-hash-value k2))))) (define-record-type <node> @@ -162,31 +161,31 @@ (else m)))) - (define (insert-node m k v key<?) + (define (insert-node m k v cmp) (cond ((null? m) (make-node 'red k v '() '())) - ((key-hash<? k (node-key m) key<?) + ((key-hash<? k (node-key m) cmp) (rebalance-left (make-node (node-color m) (node-key m) (node-value m) - (insert-node (node-left m) k v key<?) + (insert-node (node-left m) k v cmp) (node-right m)))) - ((key-hash=? k (node-key m)) (make-node (node-color m) k v (node-left m) (node-right m))) + ((key-hash=? k (node-key m) cmp) (make-node (node-color m) k v (node-left m) (node-right m))) (else (rebalance-right (make-node (node-color m) (node-key m) (node-value m) (node-left m) - (insert-node (node-right m) k v key<?)))))) + (insert-node (node-right m) k v cmp)))))) - (define-record-type <hash-map> - (construct-hash-map hash key<? root) - hash-map? - (hash hash-map-raw-hash) - (key<? hash-map-key<?) - (root hash-map-root)) + (define-record-type <map> + (construct-map hash cmp root) + map? + (hash map-raw-hash) + (cmp map-cmp) + (root map-root)) - (define (make-map hash key<?) - (construct-hash-map hash key<? '())) + (define (make-map hash cmp) + (construct-map hash cmp '())) (define (shuffle n) @@ -195,16 +194,16 @@ #x10000000000000000)) - (define (hash-map-hash m) + (define (map-hash m) (lambda (k) - (shuffle ((hash-map-raw-hash m) k)))) + (shuffle ((map-raw-hash m) k)))) (define (insert m k v) - (let ((res (insert-node (hash-map-root m) (make-key-hash k ((hash-map-hash m) k)) v (hash-map-key<? m)))) - (construct-hash-map - (hash-map-raw-hash m) - (hash-map-key<? m) + (let ((res (insert-node (map-root m) (make-key-hash k ((map-hash m) k)) v (map-cmp m)))) + (construct-map + (map-raw-hash m) + (map-cmp m) (make-node 'black (node-key res) (node-value res) (node-left res) (node-right res))))) @@ -214,14 +213,14 @@ (define (lookup m k) - (letrec ((k* (make-key-hash k ((hash-map-hash m) k))) + (letrec ((k* (make-key-hash k ((map-hash m) k))) (lookup (lambda (n) (cond ((null? n) (raise (make-key-not-found-error))) - ((key-hash<? k* (node-key n) (hash-map-key<? m)) (lookup (node-left n))) - ((key-hash=? k* (node-key n)) (node-value n)) + ((key-hash<? k* (node-key n) (map-cmp m)) (lookup (node-left n))) + ((key-hash=? k* (node-key n) (map-cmp m)) (node-value n)) (else (lookup (node-right n))))))) - (lookup (hash-map-root m)))) + (lookup (map-root m)))) (define (for-each f m) @@ -231,7 +230,7 @@ (node-foreach (node-left n)) (f (key-hash-value (node-key n)) (node-value n)) (node-foreach (node-right n)))))) - (node-foreach (hash-map-root m)))) + (node-foreach (map-root m)))) (define (map->alist m) @@ -243,9 +242,9 @@ alist)) - (define (alist->map hash key<? alist) + (define (alist->map hash cmp alist) (let loop ((alist alist) - (m (make-map hash key<?))) + (m (make-map hash cmp))) (if (null? alist) m (loop (cdr alist) (insert m (caar alist) (cdar alist)))))) diff --git a/csc/linker.csc b/csc/linker.csc index 852ee13..b3f2a5d 100644 --- a/csc/linker.csc +++ b/csc/linker.csc @@ -41,8 +41,15 @@ (hash-bytevector (string->utf8 s))) + (define (cmp-strings s1 s2) + (cond + ((string<? s1 s2) -1) + ((string=? s1 s2) 0) + (else 1))) + + (define (make-label-map program) - (let loop ((m (make-map hash-string string<?)) + (let loop ((m (make-map hash-string cmp-strings)) (program program) (i 0)) (match program |