diff options
| author | 2022-02-15 14:13:27 +0200 | |
|---|---|---|
| committer | 2022-02-15 14:13:27 +0200 | |
| commit | fd3fcee4477de39c74ec4c88964d671bf43fd071 (patch) | |
| tree | c71eaea1223060db846dcd40e34ae29c5a4153e5 | |
| parent | Merge branch 'master' of https://github.com/johnwcowan/srfi-225 (diff) | |
update implementation
| -rw-r--r-- | srfi-225-test.scm | 203 | ||||
| -rw-r--r-- | srfi-225.html | 2 | ||||
| -rw-r--r-- | srfi/225.sld | 82 | ||||
| -rw-r--r-- | srfi/alist-impl.scm | 12 | ||||
| -rw-r--r-- | srfi/default-impl.scm | 169 | ||||
| -rw-r--r-- | srfi/externals.scm | 41 | ||||
| -rw-r--r-- | srfi/indexes.scm | 12 | ||||
| -rw-r--r-- | srfi/srfi-125-impl.scm | 6 | ||||
| -rw-r--r-- | srfi/srfi-126-impl.scm | 12 | ||||
| -rw-r--r-- | srfi/srfi-146-hash-impl.scm | 9 | ||||
| -rw-r--r-- | srfi/srfi-146-impl.scm | 9 | ||||
| -rw-r--r-- | srfi/srfi-69-impl.scm | 10 |
12 files changed, 238 insertions, 329 deletions
diff --git a/srfi-225-test.scm b/srfi-225-test.scm index d4d601b..c36b062 100644 --- a/srfi-225-test.scm +++ b/srfi-225-test.scm @@ -75,6 +75,9 @@ (call/cc (lambda (cont) (with-exception-handler (lambda (err) + (when expect-success + (display err) + (newline)) (unless expect-success (cont #t))) (lambda () @@ -717,140 +720,78 @@ (2 . b) (3 . c) (4 . d))))) - '(1 2 3 4))) - - (test-group - "dict-for-each<" - (test-for-each (let* ((cmp (dict-comparator dto (alist->dict '()))) - (ordering (and cmp (comparator-ordered? cmp)))) - ordering) - (lambda (proc) - (dict-for-each< dto - proc - (alist->dict '((1 . a) - (2 . b) - (3 . c) - (4 . d))) - 3)) - '(1 2))) - - (test-group - "dict-for-each<=" - (test-for-each (let* ((cmp (dict-comparator dto (alist->dict '()))) - (ordering (and cmp (comparator-ordered? cmp)))) - ordering) - (lambda (proc) - (dict-for-each<= dto - proc - (alist->dict '((1 . a) - (2 . b) - (3 . c) - (4 . d))) - 3)) - '(1 2 3))) - - (test-group - "dict-for-each>" + '(1 2 3 4)) + (test-for-each (let* ((cmp (dict-comparator dto (alist->dict '()))) (ordering (and cmp (comparator-ordered? cmp)))) ordering) - (lambda (proc) - (dict-for-each> dto - proc - (alist->dict '((1 . a) - (2 . b) - (3 . c) - (4 . d))) - 2)) - '(3 4))) - - (test-group - "dict-for-each>=" - (test-for-each (let* ((cmp (dict-comparator dto (alist->dict '()))) - (ordering (and cmp (comparator-ordered? cmp)))) - ordering) - (lambda (proc) - (dict-for-each>= dto - proc - (alist->dict '((1 . a) - (2 . b) - (3 . c) - (4 . d))) - 2)) - '(2 3 4))) + (lambda (proc) + (dict-for-each dto + proc + (alist->dict '((1 . a) + (2 . b) + (3 . c) + (4 . d))) + 2)) + '(2 3 4)) - (test-group - "dict-for-each-in-open-interval" - (test-for-each (let* ((cmp (dict-comparator dto (alist->dict '()))) - (ordering (and cmp (comparator-ordered? cmp)))) - ordering) - (lambda (proc) - (dict-for-each-in-open-interval dto - proc - (alist->dict '((1 . a) - (2 . b) - (3 . c) - (4 . d))) - 1 4)) - '(2 3))) - - (test-group - "dict-for-each-in-closed-interval" (test-for-each (let* ((cmp (dict-comparator dto (alist->dict '()))) (ordering (and cmp (comparator-ordered? cmp)))) ordering) - (lambda (proc) - (dict-for-each-in-closed-interval dto - proc - (alist->dict '((1 . a) - (2 . b) - (3 . c) - (4 . d))) - 1 4)) - '(1 2 3 4))) + (lambda (proc) + (dict-for-each dto + proc + (alist->dict '((1 . a) + (2 . b) + (3 . c) + (4 . d))) + 2 + 3)) + '(2 3))) + + (test-group + "dict->generator" + (test-for-each #t + (lambda (proc) + (generator-for-each + (lambda (entry) + (proc (car entry) (cdr entry))) + (dict->generator dto (alist->dict '((1 . a) + (2 . b) + (3 . c) + (4 . d)))))) + '(1 2 3 4)) - (test-group - "dict-for-each-in-open-closed-interval" (test-for-each (let* ((cmp (dict-comparator dto (alist->dict '()))) (ordering (and cmp (comparator-ordered? cmp)))) ordering) - (lambda (proc) - (dict-for-each-in-open-closed-interval dto - proc - (alist->dict '((1 . a) - (2 . b) - (3 . c) - (4 . d))) - 1 4)) - '(2 3 4))) + (lambda (proc) + (generator-for-each + (lambda (entry) + (proc (car entry) (cdr entry))) + (dict->generator dto (alist->dict '((1 . a) + (2 . b) + (3 . c) + (4 . d))) + 2))) + '(2 3 4)) - (test-group - "dict-for-each-in-closed-open-interval" (test-for-each (let* ((cmp (dict-comparator dto (alist->dict '()))) (ordering (and cmp (comparator-ordered? cmp)))) ordering) - (lambda (proc) - (dict-for-each-in-closed-open-interval dto - proc - (alist->dict '((1 . a) - (2 . b) - (3 . c) - (4 . d))) - 1 4)) - '(1 2 3))) - - (test-group - "make-dict-generator" - (test-for-each #t - (lambda (proc) - (generator-for-each - (lambda (entry) - (proc (car entry) (cdr entry))) - (make-dict-generator dto (alist->dict '((1 . a) - (2 . b) - (3 . c)))))) - '(1 2 3))) + (lambda (proc) + (generator-for-each + (lambda (entry) + (proc (car entry) (cdr entry))) + (dict->generator dto (alist->dict '((1 . a) + (2 . b) + (3 . c) + (4 . d))) + 2 3))) + '(2 3))) + (when mutable? + (test-skip 1)) (test-group "dict-set-accumulator" (define acc (dict-set-accumulator dto (alist->dict '()))) @@ -858,7 +799,19 @@ (acc (cons 2 'b)) (acc (cons 2 'c)) (test-assert (dict=? dto equal? (acc (eof-object)) (alist->dict '((1 . a) (2 . c)))))) + + (unless mutable? + (test-skip 1)) + (test-group + "dict-set!-accumulator" + (define acc (dict-set!-accumulator dto (alist->dict '()))) + (acc (cons 1 'a)) + (acc (cons 2 'b)) + (acc (cons 2 'c)) + (test-assert (dict=? dto equal? (acc (eof-object)) (alist->dict '((1 . a) (2 . c)))))) + (when mutable? + (test-skip 1)) (test-group "dict-adjoin-accumulator" (define acc (dict-adjoin-accumulator dto (alist->dict '()))) @@ -866,6 +819,16 @@ (acc (cons 2 'b)) (acc (cons 2 'c)) (test-assert (dict=? dto equal? (acc (eof-object)) (alist->dict '((1 . a) (2 . b)))))) + + (unless mutable? + (test-skip 1)) + (test-group + "dict-adjoin!-accumulator" + (define acc (dict-adjoin!-accumulator dto (alist->dict '()))) + (acc (cons 1 'a)) + (acc (cons 2 'b)) + (acc (cons 2 'c)) + (test-assert (dict=? dto equal? (acc (eof-object)) (alist->dict '((1 . a) (2 . b)))))) ;; check all procs were called (for-each @@ -883,10 +846,10 @@ (define minimal-alist-dto (make-dto dictionary?-id (dto-ref alist-dto dictionary?-id) - dict-mutable?-id (dto-ref alist-dto dict-mutable?-id) + dict-pure?-id (dto-ref alist-dto dict-pure?-id) dict-size-id (dto-ref alist-dto dict-size-id) dict-find-update-id (dto-ref alist-dto dict-find-update-id) - dict-for-each-id (dto-ref alist-dto dict-for-each-id) + dict-map-id (dto-ref alist-dto dict-map-id) dict-comparator-id (dto-ref alist-dto dict-comparator-id))) (do-test minimal-alist-dto diff --git a/srfi-225.html b/srfi-225.html index 48fed8b..0d85a83 100644 --- a/srfi-225.html +++ b/srfi-225.html @@ -384,8 +384,6 @@ one for each of the four procedures: </pre></blockquote> <p><code>(dict->alist</code> <em>dto dict</em><code>)</code></p> <p>Returns an alist whose keys and values are the keys and values of <em>dict</em>.</p> -<code>dict-filter</code>, <code>dict-remove</code>, -and <code>dict-find-update</code>. </p> <p><code>(dict-comparator</code> <em>dto dict</em><code>)</code></p> <p>Return a comparator representing the type predicate, equality predicate, diff --git a/srfi/225.sld b/srfi/225.sld index 94699e7..b16f994 100644 --- a/srfi/225.sld +++ b/srfi/225.sld @@ -18,7 +18,7 @@ dict-empty? dict-contains? dict=? - dict-mutable? + dict-pure? ;; lookup dict-ref @@ -67,19 +67,11 @@ ;; iteration dict-for-each - dict-for-each< - dict-for-each<= - dict-for-each> - dict-for-each>= - dict-for-each-in-open-interval - dict-for-each-in-closed-interval - dict-for-each-in-open-closed-interval - dict-for-each-in-closed-open-interval - - ;; generator procedures - make-dict-generator + dict->generator dict-set-accumulator + dict-set!-accumulator dict-adjoin-accumulator + dict-adjoin!-accumulator ;; dictionary type descriptors dto? @@ -95,49 +87,47 @@ dictionary-irritants ;; proc indeces + + ;; required dictionary?-id - dict-empty?-id - dict-contains?-id - dict=?-id - dict-mutable?-id - dict-ref-id - dict-ref/default-id - dict-set-id - dict-adjoin-id - dict-delete-id - dict-delete-all-id - dict-replace-id - dict-intern-id - dict-update-id - dict-update/default-id - dict-pop-id + dict-find-update-id + dict-comparator-id dict-map-id - dict-filter-id + dict-pure?-id dict-remove-id - dict-find-update-id dict-size-id - dict-count-id + + ;; extra + dict->alist-id + dict-adjoin-accumulator-id + dict-adjoin-id dict-any-id - dict-every-id - dict-keys-id - dict-values-id + dict-contains?-id + dict-count-id + dict-delete-all-id + dict-delete-id + dict-empty?-id dict-entries-id + dict-every-id + dict-filter-id dict-fold-id - dict-map->list-id - dict->alist-id - dict-comparator-id dict-for-each-id - dict-for-each<-id - dict-for-each<=-id - dict-for-each>-id - dict-for-each>=-id - dict-for-each-in-open-interval-id - dict-for-each-in-closed-interval-id - dict-for-each-in-open-closed-interval-id - dict-for-each-in-closed-open-interval-id - make-dict-generator-id + dict-intern-id + dict-keys-id + dict-map->list-id + dict-map-id + dict-pop-id + dict-ref-id + dict-ref/default-id + dict-remove-id + dict-replace-id dict-set-accumulator-id - dict-adjoin-accumulator-id + dict-set-id + dict-update-id + dict-update/default-id + dict-values-id + dict=?-id + dict->generator-id ;; basic DTOs alist-eqv-dto diff --git a/srfi/alist-impl.scm b/srfi/alist-impl.scm index 19d42b6..80b449d 100644 --- a/srfi/alist-impl.scm +++ b/srfi/alist-impl.scm @@ -5,8 +5,8 @@ (or (null? l) (pair? (car l))))) - (define (alist-mutable? dto alist) - #f) + (define (alist-pure? dto alist) + #t) (define (alist-map dto proc alist) (map @@ -62,11 +62,6 @@ (define (alist-size dto alist) (length alist)) - (define (alist-foreach dto proc alist) - (define (proc* e) - (proc (car e) (cdr e))) - (for-each proc* alist)) - (define (alist->alist dto alist) alist) @@ -75,12 +70,11 @@ (make-dto dictionary?-id alist? - dict-mutable?-id alist-mutable? + dict-pure?-id alist-pure? dict-map-id alist-map dict-filter-id alist-filter dict-find-update-id alist-find-update dict-size-id alist-size - dict-for-each-id alist-foreach dict->alist-id alist->alist dict-comparator-id alist-comparator)) diff --git a/srfi/default-impl.scm b/srfi/default-impl.scm index 53f1398..e2ff29d 100644 --- a/srfi/default-impl.scm +++ b/srfi/default-impl.scm @@ -9,34 +9,34 @@ (lambda (dto . args) (raise (dictionary-error (string-append name " not implemented") dto)))) (define default-dictionary? (not-implemented "dictionary?")) - (define default-dict-mutable? (not-implemented "dict-mutable?")) + (define default-dict-pure? (not-implemented "dict-pure?")) (define default-dict-size (not-implemented "dict-size")) (define default-dict-find-update (not-implemented "dict-find-update")) (define (dict-find-update* dto dict key fail success) - (if (dict-mutable? dto dict) - (dict-find-update! dto dict key fail success) - (dict-find-update dto dict key fail success))) + (if (dict-pure? dto dict) + (dict-find-update dto dict key fail success) + (dict-find-update! dto dict key fail success))) (define (dict-delete-all* dto dict keys) - (if (dict-mutable? dto dict) - (dict-delete-all! dto dict keys) - (dict-delete-all dto dict keys))) + (if (dict-pure? dto dict) + (dict-delete-all dto dict keys) + (dict-delete-all! dto dict keys))) (define (dict-update* dto dict key updater fail success) - (if (dict-mutable? dto dict) - (dict-update! dto dict key updater fail success) - (dict-update dto dict key updater fail success))) + (if (dict-pure? dto dict) + (dict-update dto dict key updater fail success) + (dict-update! dto dict key updater fail success))) (define (dict-filter* dto pred dictionary) - (if (dict-mutable? dto dictionary) - (dict-filter! dto pred dictionary) - (dict-filter dto pred dictionary))) + (if (dict-pure? dto dictionary) + (dict-filter dto pred dictionary) + (dict-filter! dto pred dictionary))) (define (dict-replace* dto dict key val) - (if (dict-mutable? dto dict) - (dict-replace! dto dict key val) - (dict-replace dto dict key val))) + (if (dict-pure? dto dict) + (dict-replace dto dict key val) + (dict-replace! dto dict key val))) (define (default-dict-empty? dto dictionary) (= 0 (dict-size dto dictionary))) @@ -158,16 +158,7 @@ (error "popped empty dictionary") (do-pop))) - (define (default-dict-map dto mapper dictionary) - (define keys (dict-keys dto dictionary)) - (let loop ((keys keys) - (dict dictionary)) - (if (null? keys) - dict - (let* ((key (car keys)) - (val (mapper key (dict-ref dto dict key)))) - (loop (cdr keys) - (dict-replace* dto dict key val)))))) + (define default-dict-map (not-implemented "dict-map")) (define (default-dict-filter dto pred dictionary) (define keys (dict-keys dto dictionary)) @@ -267,74 +258,56 @@ (define default-dict-comparator (not-implemented "dict-comparator")) - (define default-dict-for-each (not-implemented "dict-for-each")) - - (define (default-dict-for-each/filtered dto pred proc dict) - (dict-for-each dto - (lambda (key value) - (when (pred key) - (proc key value))) - dict)) - - (define (default-dict-for-each< dto proc dict key) - (define cmp (dict-comparator dto dict)) - (define (pred k) - (<? cmp k key)) - (default-dict-for-each/filtered dto pred proc dict)) - - (define (default-dict-for-each<= dto proc dict key) - (define cmp (dict-comparator dto dict)) - (define (pred k) - (<=? cmp k key)) - (default-dict-for-each/filtered dto pred proc dict)) - - (define (default-dict-for-each> dto proc dict key) - (define cmp (dict-comparator dto dict)) - (define (pred k) - (>? cmp k key)) - (default-dict-for-each/filtered dto pred proc dict)) - - (define (default-dict-for-each>= dto proc dict key) - (define cmp (dict-comparator dto dict)) - (define (pred k) - (>=? cmp k key)) - (default-dict-for-each/filtered dto pred proc dict)) - - (define (default-dict-for-each-in-open-interval dto proc dict key1 key2) + (define (default-dict-for-each dto proc dict start end) + (define (any . _) #t) (define cmp (dict-comparator dto dict)) - (define (pred k) - (<? cmp key1 k key2)) - (default-dict-for-each/filtered dto pred proc dict)) - - (define (default-dict-for-each-in-closed-interval dto proc dict key1 key2) - (define cmp (dict-comparator dto dict)) - (define (pred k) - (<=? cmp key1 k key2)) - (default-dict-for-each/filtered dto pred proc dict)) - - (define (default-dict-for-each-in-open-closed-interval dto proc dict key1 key2) - (define cmp (dict-comparator dto dict)) - (define (pred k) - (and (<? cmp key1 k) - (<=? cmp k key2))) - (default-dict-for-each/filtered dto pred proc dict)) - - (define (default-dict-for-each-in-closed-open-interval dto proc dict key1 key2) + (define lower + (if start + (lambda (el) (>=? cmp el start)) + any)) + (define upper + (if end + (lambda (el) (<=? cmp el end)) + any)) + (define (accept el) + (and (upper el) (lower el))) + (define map-proc + (if (dict-pure? dto dict) + dict-map + dict-map!)) + + (map-proc + dto + (lambda (key value) + (when (accept key) + (proc key value)) + value) + dict)) + + (define (default-dict->generator dto dict start end) + + (define (any . _) #t) (define cmp (dict-comparator dto dict)) - (define (pred k) - (and (<=? cmp key1 k) - (<? cmp k key2))) - (default-dict-for-each/filtered dto pred proc dict)) - - (define (default-make-dict-generator dto dict) + (define lower + (if start + (lambda (el) (>=? cmp el start)) + any)) + (define upper + (if end + (lambda (el) (<=? cmp el end)) + any)) + (define (accept el) + (and (upper el) (lower el))) ;; proc that takes yield value and yield continuation when yield is called ;; shouldn't return (define yield-handler #f) (define (yield value) - (call/cc (lambda (yield-cont) - (yield-handler value yield-cont)))) + (when (or (eof-object? value) + (accept (car value))) + (call/cc (lambda (yield-cont) + (yield-handler value yield-cont))) )) (define (generate) (dict-for-each dto @@ -379,14 +352,14 @@ (set! dict (acc-proc dto dict (car arg) (cdr arg)))))) (define (default-dict-set-accumulator dto dict) - (if (dict-mutable? dto dict) - (default-dict-accumulator dto dict dict-set!) - (default-dict-accumulator dto dict dict-set))) + (if (dict-pure? dto dict) + (default-dict-accumulator dto dict dict-set) + (default-dict-accumulator dto dict dict-set!))) (define (default-dict-adjoin-accumulator dto dict) - (if (dict-mutable? dto dict) - (default-dict-accumulator dto dict dict-adjoin!) - (default-dict-accumulator dto dict dict-adjoin))) + (if (dict-pure? dto dict) + (default-dict-accumulator dto dict dict-adjoin) + (default-dict-accumulator dto dict dict-adjoin!))) (let () (define null-dto (make-dto-private (make-vector dict-procedures-count #f))) @@ -397,7 +370,7 @@ dict-empty?-id default-dict-empty? dict-contains?-id default-dict-contains? dict=?-id default-dict=? - dict-mutable?-id default-dict-mutable? + dict-pure?-id default-dict-pure? dict-ref-id default-dict-ref dict-ref/default-id default-dict-ref/default dict-set-id default-dict-set @@ -426,17 +399,9 @@ dict-comparator-id default-dict-comparator dict-for-each-id default-dict-for-each - dict-for-each<-id default-dict-for-each< - dict-for-each<=-id default-dict-for-each<= - dict-for-each>-id default-dict-for-each> - dict-for-each>=-id default-dict-for-each>= - dict-for-each-in-open-interval-id default-dict-for-each-in-open-interval - dict-for-each-in-closed-interval-id default-dict-for-each-in-closed-interval - dict-for-each-in-open-closed-interval-id default-dict-for-each-in-open-closed-interval - dict-for-each-in-closed-open-interval-id default-dict-for-each-in-closed-open-interval ;; generator procedures - make-dict-generator-id default-make-dict-generator + dict->generator-id default-dict->generator dict-set-accumulator-id default-dict-set-accumulator dict-adjoin-accumulator-id default-dict-adjoin-accumulator)) diff --git a/srfi/externals.scm b/srfi/externals.scm index ce24b19..d08f4a4 100644 --- a/srfi/externals.scm +++ b/srfi/externals.scm @@ -35,11 +35,11 @@ (begin (define (proc-mutable dto dict . args) (assume (dto? dto)) - (assume ((dto-ref-stx dto dict-mutable?-id) dto dict) index) + (assume (not ((dto-ref-stx dto dict-pure?-id) dto dict)) index) (apply (dto-ref-stx dto index) dto dict args)) (define (proc-immutable dto dict . args) (assume (dto? dto)) - (assume (not ((dto-ref-stx dto dict-mutable?-id) dto dict)) index) + (assume ((dto-ref-stx dto dict-pure?-id) dto dict) index) (apply (dto-ref-stx dto index) dto dict args)))))) ;; define mutable and immutable versions of a procedure (such as dict-set! and dict-set) @@ -51,17 +51,17 @@ (begin (define (proc-mutable dto proc dict) (assume (dto? dto)) - (assume ((dto-ref-stx dto dict-mutable?-id) dto dict) index) + (assume (not ((dto-ref-stx dto dict-pure?-id) dto dict)) index) ((dto-ref-stx dto index) dto proc dict)) (define (proc-immutable dto proc dict) (assume (dto? dto)) - (assume (not ((dto-ref-stx dto dict-mutable?-id) dto dict)) index) + (assume ((dto-ref-stx dto dict-pure?-id) dto dict) index) ((dto-ref-stx dto index) dto proc dict)))))) (define/dict-proc dictionary? dictionary?-id) (define/dict-proc dict-empty? dict-empty?-id) (define/dict-proc dict-contains? dict-contains?-id) -(define/dict-proc dict-mutable? dict-mutable?-id) +(define/dict-proc dict-pure? dict-pure?-id) (define/dict-proc dict=? dict=?-id) (define dict-ref @@ -98,7 +98,7 @@ ((dto dict key updater failure success) (assume (dto? dto)) - (assume (not ((dto-ref-stx dto dict-mutable?-id) dto dict))) + (assume ((dto-ref-stx dto dict-pure?-id) dto dict)) ((dto-ref-stx dto dict-update-id) dto dict key updater failure success)))) (define dict-update! @@ -113,7 +113,7 @@ ((dto dict key updater failure success) (assume (dto? dto)) - (assume ((dto-ref-stx dto dict-mutable?-id) dto dict)) + (assume (not ((dto-ref-stx dto dict-pure?-id) dto dict))) ((dto-ref-stx dto dict-update-id) dto dict key updater failure success)))) (define/dict-proc-pair dict-update/default dict-update/default! dict-update/default-id) @@ -133,18 +133,21 @@ (define/dict-proc dict-map->list dict-map->list-id) (define/dict-proc dict->alist dict->alist-id) (define/dict-proc dict-comparator dict-comparator-id) -(define/dict-proc dict-for-each dict-for-each-id) -(define/dict-proc dict-for-each< dict-for-each<-id) -(define/dict-proc dict-for-each<= dict-for-each<=-id) -(define/dict-proc dict-for-each> dict-for-each>-id) -(define/dict-proc dict-for-each>= dict-for-each>=-id) -(define/dict-proc dict-for-each-in-open-interval dict-for-each-in-open-interval-id) -(define/dict-proc dict-for-each-in-closed-interval dict-for-each-in-closed-interval-id) -(define/dict-proc dict-for-each-in-open-closed-interval dict-for-each-in-open-closed-interval-id) -(define/dict-proc dict-for-each-in-closed-open-interval dict-for-each-in-closed-open-interval-id) -(define/dict-proc make-dict-generator make-dict-generator-id) -(define/dict-proc dict-set-accumulator dict-set-accumulator-id) -(define/dict-proc dict-adjoin-accumulator dict-adjoin-accumulator-id) + +(define dict-for-each + (case-lambda + ((dto proc dict) (dict-for-each dto proc dict #f #f)) + ((dto proc dict start) (dict-for-each dto proc dict start #f)) + ((dto proc dict start end) ((dto-ref-stx dto dict-for-each-id) dto proc dict start end)))) + +(define dict->generator + (case-lambda + ((dto dict) (dict->generator dto dict #f #f)) + ((dto dict start) (dict->generator dto dict start #f)) + ((dto dict start end) ((dto-ref-stx dto dict->generator-id) dto dict start end)))) + +(define/dict-proc-pair dict-set-accumulator dict-set!-accumulator dict-set-accumulator-id) +(define/dict-proc-pair dict-adjoin-accumulator dict-adjoin!-accumulator dict-adjoin-accumulator-id) (define (dto-ref dto procindex) (dto-ref-stx dto procindex)) diff --git a/srfi/indexes.scm b/srfi/indexes.scm index 2121558..f6a178f 100644 --- a/srfi/indexes.scm +++ b/srfi/indexes.scm @@ -9,7 +9,7 @@ (define dict-empty?-id (proc-id-inc)) (define dict-contains?-id (proc-id-inc)) (define dict=?-id (proc-id-inc)) -(define dict-mutable?-id (proc-id-inc)) +(define dict-pure?-id (proc-id-inc)) (define dict-ref-id (proc-id-inc)) (define dict-ref/default-id (proc-id-inc)) (define dict-set-id (proc-id-inc)) @@ -37,15 +37,7 @@ (define dict->alist-id (proc-id-inc)) (define dict-comparator-id (proc-id-inc)) (define dict-for-each-id (proc-id-inc)) -(define dict-for-each<-id (proc-id-inc)) -(define dict-for-each<=-id (proc-id-inc)) -(define dict-for-each>-id (proc-id-inc)) -(define dict-for-each>=-id (proc-id-inc)) -(define dict-for-each-in-open-interval-id (proc-id-inc)) -(define dict-for-each-in-closed-interval-id (proc-id-inc)) -(define dict-for-each-in-open-closed-interval-id (proc-id-inc)) -(define dict-for-each-in-closed-open-interval-id (proc-id-inc)) -(define make-dict-generator-id (proc-id-inc)) +(define dict->generator-id (proc-id-inc)) (define dict-set-accumulator-id (proc-id-inc)) (define dict-adjoin-accumulator-id (proc-id-inc)) (define dict-procedures-count (proc-id-inc)) ;; only used for tracking backing vector size diff --git a/srfi/srfi-125-impl.scm b/srfi/srfi-125-impl.scm index bbc5543..a63aba9 100644 --- a/srfi/srfi-125-impl.scm +++ b/srfi/srfi-125-impl.scm @@ -13,8 +13,8 @@ (let ((table (t125-hash-table-copy table #f))) final-expr)))))) - (define (t125-hash-table-mutable?* dto table) - (t125-hash-table-mutable? table)) + (define (t125-hash-table-pure?* dto table) + (not (t125-hash-table-mutable? table))) (define (t125-hash-table-set* dto table . obj) (guard-immutable table @@ -151,7 +151,7 @@ (make-dto dictionary?-id t125-hash-table?* - dict-mutable?-id t125-hash-table-mutable?* + dict-pure?-id t125-hash-table-pure?* dict-empty?-id t125-hash-table-empty?* dict-contains?-id t125-hash-table-contains?* dict-ref-id t125-hash-table-ref* diff --git a/srfi/srfi-126-impl.scm b/srfi/srfi-126-impl.scm index e1f62f1..815b9cf 100644 --- a/srfi/srfi-126-impl.scm +++ b/srfi/srfi-126-impl.scm @@ -12,10 +12,13 @@ body ... (let ((table (t126-hashtable-copy table #f))) final-expr)))))) - + (define (prep-dto-arg proc) (lambda (dto . args) (apply proc args))) + + (define (t126-hashtable-pure?* dto table) + (not (t126-hashtable-mutable? table))) (define (t126-hashtable-ref* dto table key fail success) (define-values (value found?) (t126-hashtable-lookup table key)) @@ -108,10 +111,6 @@ (handle-fail) (handle-success found))) - (define (t126-hashtable-for-each* dto proc table) - (t126-hashtable-walk table proc) - table) - (define (t126-hashtable-map->lset* dto proc table) (t126-hashtable-map->lset table proc)) @@ -134,7 +133,7 @@ (make-dto dictionary?-id (prep-dto-arg t126-hashtable?) - dict-mutable?-id (prep-dto-arg t126-hashtable-mutable?) + dict-pure?-id t126-hashtable-pure?* dict-empty?-id (prep-dto-arg t126-hashtable-empty?) dict-contains?-id (prep-dto-arg t126-hashtable-contains?) dict-ref-id t126-hashtable-ref* @@ -149,7 +148,6 @@ dict-remove-id t126-hashtable-remove* dict-find-update-id t126-hashtable-find-update* dict-size-id (prep-dto-arg t126-hashtable-size) - dict-for-each-id t126-hashtable-for-each* dict-keys-id t126-hashtable-keys* dict-values-id t126-hashtable-values* dict-entries-id t126-hashtable-entries* diff --git a/srfi/srfi-146-hash-impl.scm b/srfi/srfi-146-hash-impl.scm index 822fe7f..609fce9 100644 --- a/srfi/srfi-146-hash-impl.scm +++ b/srfi/srfi-146-hash-impl.scm @@ -4,6 +4,11 @@ (define (prep-dto-arg proc) (lambda (dto . args) (apply proc args))) + + (define (hashmap-map* dto proc dict) + (hashmap-map (lambda (key value) + (values key (proc key value))) + (dict-comparator dto dict) dict)) (define (hashmap-find-update* dto dict key failure success) (call/cc @@ -38,7 +43,8 @@ (make-dto dictionary?-id (prep-dto-arg hashmap?) - dict-mutable?-id (lambda _ #f) + dict-pure?-id (lambda _ #t) + dict-map-id hashmap-map* dict-empty?-id (prep-dto-arg hashmap-empty?) dict-contains?-id (prep-dto-arg hashmap-contains?) dict-ref-id (prep-dto-arg hashmap-ref) @@ -56,7 +62,6 @@ dict-remove-id (prep-dto-arg hashmap-remove) dict-find-update-id hashmap-find-update* dict-size-id (prep-dto-arg hashmap-size) - dict-for-each-id (prep-dto-arg hashmap-for-each) dict-count-id (prep-dto-arg hashmap-count) dict-keys-id (prep-dto-arg hashmap-keys) dict-values-id (prep-dto-arg hashmap-values) diff --git a/srfi/srfi-146-impl.scm b/srfi/srfi-146-impl.scm index ad6b629..c6280ba 100644 --- a/srfi/srfi-146-impl.scm +++ b/srfi/srfi-146-impl.scm @@ -4,6 +4,11 @@ (define (prep-dto-arg proc) (lambda (dto . args) (apply proc args))) + + (define (mapping-map* dto proc dict) + (mapping-map (lambda (key value) + (values key (proc key value))) + (dict-comparator dto dict) dict)) (define (mapping-find-update* dto dict key failure success) (call/cc @@ -38,7 +43,8 @@ (make-dto dictionary?-id (prep-dto-arg mapping?) - dict-mutable?-id (lambda _ #f) + dict-pure?-id (lambda _ #t) + dict-map-id mapping-map* dict-empty?-id (prep-dto-arg mapping-empty?) dict-contains?-id (prep-dto-arg mapping-contains?) dict-ref-id (prep-dto-arg mapping-ref) @@ -56,7 +62,6 @@ dict-remove-id (prep-dto-arg mapping-remove) dict-find-update-id mapping-find-update* dict-size-id (prep-dto-arg mapping-size) - dict-for-each-id (prep-dto-arg mapping-for-each) dict-count-id (prep-dto-arg mapping-count) dict-keys-id (prep-dto-arg mapping-keys) dict-values-id (prep-dto-arg mapping-values) diff --git a/srfi/srfi-69-impl.scm b/srfi/srfi-69-impl.scm index c61036e..dfa9b76 100644 --- a/srfi/srfi-69-impl.scm +++ b/srfi/srfi-69-impl.scm @@ -5,8 +5,8 @@ (lambda (dto . args) (apply proc args))) - (define (t69-hash-table-mutable?* dto table) - #t) + (define (t69-hash-table-pure?* dto table) + #f) (define (t69-hash-table-ref* dto table key fail success) (define default (cons #f #f)) @@ -34,9 +34,6 @@ keys) table) - (define (t69-hash-table-foreach* dto proc table) - (t69-hash-table-walk table proc)) - (define (t69-hash-table-map!* dto proc table) (t69-hash-table-walk table (lambda (key value) (t69-hash-table-set! table key (proc key value)))) @@ -86,7 +83,7 @@ (make-dto dictionary?-id (prep-dto-arg t69-hash-table?) - dict-mutable?-id t69-hash-table-mutable?* + dict-pure?-id t69-hash-table-pure?* dict-ref-id t69-hash-table-ref* dict-ref/default-id (prep-dto-arg t69-hash-table-ref/default) dict-set-id t69-hash-table-set!* @@ -98,7 +95,6 @@ dict-values-id (prep-dto-arg t69-hash-table-values) dict-map-id t69-hash-table-map!* dict-filter-id t69-hash-table-filter!* - dict-for-each-id t69-hash-table-foreach* dict-fold-id t69-hash-table-fold* dict->alist-id (prep-dto-arg t69-hash-table->alist) dict-find-update-id t69-hash-table-find-update!* |
