diff options
Diffstat (limited to 'csc')
| -rw-r--r-- | csc/cps.csc | 9 | ||||
| -rw-r--r-- | csc/hash-map-test.csc | 21 | ||||
| -rw-r--r-- | csc/hash-map.csc | 57 | ||||
| -rw-r--r-- | csc/linker.csc | 15 | ||||
| -rw-r--r-- | csc/macros.csc | 20 |
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) |