1;;; 2;;; collection.scm - collection generics 3;;; 4;;; Copyright (c) 2000-2020 Shiro Kawai <shiro@acm.org> 5;;; 6;;; Redistribution and use in source and binary forms, with or without 7;;; modification, are permitted provided that the following conditions 8;;; are met: 9;;; 10;;; 1. Redistributions of source code must retain the above copyright 11;;; notice, this list of conditions and the following disclaimer. 12;;; 13;;; 2. Redistributions in binary form must reproduce the above copyright 14;;; notice, this list of conditions and the following disclaimer in the 15;;; documentation and/or other materials provided with the distribution. 16;;; 17;;; 3. Neither the name of the authors nor the names of its contributors 18;;; may be used to endorse or promote products derived from this 19;;; software without specific prior written permission. 20;;; 21;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 27;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 28;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 29;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 30;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 31;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32;;; 33 34;; Defines generic operations over collection. A collection is 35;; a set of objects, possibly containing infinite objects. 36 37(define-module gauche.collection 38 (export call-with-iterator with-iterator call-with-iterators 39 call-with-builder with-builder 40 fold fold2 fold3 map map-to map-accum for-each 41 fold$ fold2$ fold3$ map$ for-each$ 42 find find-min find-max find-min&max 43 filter filter-to remove remove-to partition partition-to 44 size-of lazy-size-of coerce-to 45 group-collection) 46 ) 47(select-module gauche.collection) 48 49;; Avoid hairy dependency issues 50(autoload gauche.uvector 51 u8vector-length 52 s8vector-length 53 u16vector-length 54 s16vector-length 55 u32vector-length 56 s32vector-length 57 u64vector-length 58 s64vector-length 59 f16vector-length 60 f32vector-length 61 f64vector-length 62 c32vector-length 63 c64vector-length 64 c128vector-length) 65 66;; alternative. 67(define (make-queue) (let1 anchor (list #f) (cons anchor anchor))) 68(define (enqueue! q x) (set! (cddr q) (list x)) (set! (cdr q) (cddr q))) 69(define (dequeue! q) (if (null? (cdar q)) 70 (error "queue is empty" q) 71 (rlet1 v (cadar q) (set! (cdar q) (cddar q))))) 72(define (queue->list q) (cdar q)) 73 74;;------------------------------------------------- 75;; Call-with-iterator - the fundamental iterator 76;; 77 78(define-syntax with-iterator 79 (syntax-rules () 80 [(_ (coll end? next . opts) . body) 81 (call-with-iterator coll (^[end? next] . body) . opts)])) 82 83(define-method call-with-iterator ((coll <list>) proc 84 :key (start #f) :allow-other-keys) 85 (let1 p (if start (list-tail coll start) coll) 86 (proc (cut null? p) (^[] (pop! p))))) 87 88(define-syntax *vector-iter 89 (syntax-rules () 90 [(_ %length %ref coll proc start) 91 (let1 len (%length coll) 92 (proc (cut >= start len) 93 (^[] (rlet1 v (%ref coll start) (inc! start)))))])) 94 95(define-syntax define-vector-iterator 96 (er-macro-transformer 97 (^[f r c] 98 (let* ([type (cadr f)] 99 [%class (r (symbol-append '< type '>))] 100 [%length (r (symbol-append type '-length))] 101 [%ref (r (if (c (r type) (r'bitvector)) 102 'bitvector-ref/int 103 (symbol-append type '-ref)))]) 104 (quasirename r 105 `(define-method call-with-iterator ((coll ,%class) proc 106 ,':key (start 0) 107 ,':allow-other-keys) 108 (*vector-iter ,%length ,%ref coll proc start))))))) 109 110(define-vector-iterator vector) 111(define-vector-iterator u8vector) 112(define-vector-iterator s8vector) 113(define-vector-iterator u16vector) 114(define-vector-iterator s16vector) 115(define-vector-iterator u32vector) 116(define-vector-iterator s32vector) 117(define-vector-iterator u64vector) 118(define-vector-iterator s64vector) 119(define-vector-iterator f16vector) 120(define-vector-iterator f32vector) 121(define-vector-iterator f64vector) 122(define-vector-iterator c32vector) 123(define-vector-iterator c64vector) 124(define-vector-iterator c128vector) 125(define-vector-iterator bitvector) 126(define-vector-iterator weak-vector) 127 128(define-method call-with-iterator ((coll <string>) proc 129 :key (start #f) :allow-other-keys) 130 (let* ([s (open-input-string (if start (string-copy coll start) coll))] 131 [ch (read-char s)]) 132 (proc (cut eof-object? ch) 133 (^[] (rlet1 c ch 134 (set! ch (read-char s))))))) 135 136(define-method call-with-iterator ((coll <hash-table>) proc :allow-other-keys) 137 (let ([eof-marker (cons #f #f)] 138 [iter ((with-module gauche.internal %hash-table-iter) coll)]) 139 (receive (k v) (iter eof-marker) 140 (proc (cut eq? k eof-marker) 141 (^[] (begin0 (cons k v) 142 (set!-values (k v) (iter eof-marker)))))))) 143 144(define-method call-with-iterator ((coll <tree-map>) proc :allow-other-keys) 145 (let ([eof-marker (cons #f #f)] 146 [iter ((with-module gauche.internal %tree-map-iter) coll)]) 147 (receive (k v) (iter eof-marker #f) 148 (proc (cut eq? k eof-marker) 149 (^[] (begin0 (cons k v) 150 (set!-values (k v) (iter eof-marker #f)))))))) 151 152;; NB: Do not depend on srfi-14.scm. 153(define-method call-with-iterator ((coll <char-set>) proc :allow-other-keys) 154 (let* ([ranges ((with-module gauche.internal %char-set-ranges) coll)] 155 [cursor (if (null? ranges) #f (caar ranges))]) 156 (proc (^[] (not cursor)) 157 (^[] (rlet1 c (integer->char cursor) 158 (cond [(< cursor (cdar ranges)) (inc! cursor)] 159 [(null? (cdr ranges)) (set! cursor #f)] 160 [else (pop! ranges) (set! cursor (caar ranges))])))))) 161 162;; n-ary case aux. proc 163(define (call-with-iterators colls proc) 164 (let loop ([colls colls] 165 [eprocs '()] 166 [nprocs '()]) 167 (if (null? colls) 168 (proc (reverse! eprocs) (reverse! nprocs)) 169 (with-iterator ((car colls) end? next) 170 (loop (cdr colls) (cons end? eprocs) (cons next nprocs)))))) 171 172;;------------------------------------------------- 173;; Call-with-builder - the fundamental constructor 174;; 175 176(define-syntax with-builder 177 (syntax-rules () 178 [(_ (class add! get . opts) . body) 179 (call-with-builder class (^[add! get] . body) . opts)])) 180 181(define-method call-with-builder ((class <list-meta>) proc :allow-other-keys) 182 (let1 q (make-queue) 183 (proc (cut enqueue! q <>) (cut queue->list q)))) 184 185(define-method call-with-builder ((class <vector-meta>) proc 186 :key (size #f) :allow-other-keys) 187 (if size 188 (let ([v (make-vector size)] 189 [i 0]) 190 (proc (^[item] (when (< i size) 191 (vector-set! v i item) 192 (inc! i))) 193 (^[] v))) 194 (let1 q (make-queue) 195 (proc (cut enqueue! q <>) 196 (cut list->vector (queue->list q)))))) 197 198(define-syntax *vector-builder 199 (syntax-rules () 200 [(_ %make %set! %list-> class proc size) 201 (if size 202 (let ([v (%make size)] 203 [i 0]) 204 (proc (^[item] (when (< i size) 205 (%set! v i item) 206 (inc! i))) 207 (^[] v))) 208 (let1 q (make-queue) 209 (proc (cut enqueue! q <>) 210 (cut %list-> (queue->list q)))))])) 211 212;; NB: We don't have list->uvector in core yet, so builder definition is 213;; in gauche.uvector. It should be here, though. 214 215(define-method call-with-builder ((class <vector-meta>) proc 216 :key (size #f) :allow-other-keys) 217 (*vector-builder make-vector vector-set! list->vector class proc size)) 218 219(define-method call-with-builder ((class <bitvector-meta>) proc 220 :key (size #f) :allow-other-keys) 221 (*vector-builder make-bitvector bitvector-set! list->bitvector 222 class proc size)) 223 224(define-method call-with-builder ((class <weak-vector-meta>) proc 225 :key (size #f) :allow-other-keys) 226 (*vector-builder make-weak-vector weak-vector-set! %list->weak-vector 227 class proc size)) 228 229(define (%list->weak-vector lis) 230 (rlet1 v (make-weak-vector (length lis)) 231 ;; for-each-with-index is in gauche.sequence, so we roll on our own 232 (do ([lis lis (cdr lis)] 233 [i 0 (+ i 1)]) 234 [(null? lis)] 235 (weak-vector-set! v i (car lis))))) 236 237(define-method call-with-builder ((class <string-meta>) proc :allow-other-keys) 238 (let1 s (open-output-string) 239 (proc (^[item] 240 (unless (char? item) 241 (error "character required to build a string, but got" item)) 242 (write-char item s)) 243 (^[] (get-output-string s))))) 244 245(define-method call-with-builder ((class <hash-table-meta>) proc 246 :key (comparator #f) (type #f) 247 :allow-other-keys) 248 (let1 h (make-hash-table (or type comparator 'eq?)) 249 (proc (^[item] 250 (unless (pair? item) 251 (error "pair required to build a hashtable, but got" item)) 252 (hash-table-put! h (car item) (cdr item))) 253 (^[] h)))) 254 255(define-method call-with-builder ((class <tree-map-meta>) proc 256 :key (comparator default-comparator) 257 (key=? #f) (key<? #f) 258 :allow-other-keys) 259 (let1 tree (if (and key=? key<?) 260 (make-tree-map key=? key<?) 261 (make-tree-map comparator)) 262 (proc (^[item] 263 (unless (pair? item) 264 (error "pair required to build a tree-map, but got" item)) 265 (tree-map-put! tree (car item) (cdr item))) 266 (^[] tree)))) 267 268;; NB: size key is unused 269(define-method call-with-builder ((class <char-set-meta>) proc 270 :key (size #f) :allow-other-keys) 271 (let1 cs (char-set) 272 (proc (^c (unless (char? c) 273 (error "character required to build a char-set, but got" c)) 274 ((with-module gauche.internal %char-set-add-chars!) cs (list c))) 275 (^[] cs)))) 276 277 278 279;; utility. return minimum size of collections if it's easily known, or #f. 280(define (maybe-minimum-size col more) 281 (let1 size (and-let* ([siz (lazy-size-of col)] 282 [ (integer? siz) ]) 283 siz) 284 (if (or (null? more) (not size)) 285 size ;; short path 286 (let loop ([cols more] 287 [r size]) 288 (if (null? cols) 289 r 290 (let1 size (lazy-size-of (car cols)) 291 (and (integer? size) 292 (loop (cdr cols) (min r size))))))))) 293 294;;---------------------------------------------------- 295;; Derived operations 296;; 297 298;; fold ------------------------------------------------- 299 300(define-syntax define-fold-k 301 (syntax-rules () 302 [(gen-fold-k name (seed ...)) 303 (define-method name (proc seed ... (coll <collection>) . more) 304 (if (null? more) 305 (with-iterator (coll end? next) 306 (let loop ((seed seed) ...) 307 (if (end?) 308 (values seed ...) 309 (receive (seed ...) (proc (next) seed ...) 310 (loop seed ...))))) 311 (call-with-iterators 312 (cons coll more) 313 (^[ends? nexts] 314 (let loop ((seed seed) ...) 315 (if (any (cut <>) ends?) 316 (values seed ...) 317 (receive (seed ...) 318 (apply proc (fold-right (^[p r] (cons (p) r)) 319 (list seed ...) 320 nexts)) 321 (loop seed ...)))))) 322 ))])) 323 324;; generic way. This shadows builtin fold. 325(define-fold-k fold (knil)) 326 327;; for list arguments, builtin fold is faster. 328(define-method fold (proc knil (coll <list>)) 329 ((with-module gauche fold) proc knil coll)) 330 331(define-method fold (proc knil (coll <list>) (coll2 <list>)) 332 ((with-module gauche fold) proc knil coll coll2)) 333 334;; 2- and 3- seed values 335(define-fold-k fold2 (knil1 knil2)) 336(define-fold-k fold3 (knil1 knil2 knil3)) 337 338;; partial applied version 339(define fold$ 340 (case-lambda 341 ([proc] (^[knil . lists] (apply fold proc knil lists))) 342 ([proc knil] (^ lists (apply fold proc knil lists))))) 343(define (fold2$ proc knil1 knil2) 344 (^ lists (apply fold2 proc knil1 knil2 lists))) 345(define (fold3$ proc knil1 knil2 knil3) 346 (^ lists (apply fold3 proc knil1 knil2 knil3 lists))) 347 348;; map -------------------------------------------------- 349 350;; generic way. this shadows builtin map. 351(define-method map (proc (coll <collection>) . more) 352 (if (null? more) 353 (with-iterator (coll end? next) 354 (do ([q (make-queue)]) 355 [(end?) (queue->list q)] 356 (enqueue! q (proc (next))))) 357 (let1 %map (with-module gauche map) 358 (call-with-iterators 359 (cons coll more) 360 (^[ends? nexts] 361 (do ([q (make-queue)]) 362 [(any (cut <>) ends?) 363 (queue->list q)] 364 (enqueue! q (apply proc (%map (cut <>) nexts)))))) 365 ))) 366 367;; for list arguments, built-in map is much faster. 368(define-method map (proc (coll <list>) . more) 369 (let1 %map (with-module gauche map) 370 (if (null? more) 371 (%map proc coll) 372 (if (every pair? more) 373 (apply %map proc coll more) 374 (next-method))))) 375 376;; redefine map$ to use generic version of map 377(define ((map$ proc) . args) (apply map proc args)) 378 379;; map-to ----------------------------------------------- 380 381;; generic way. 382(define-method map-to ((class <class>) proc (coll <collection>) . more) 383 (if (null? more) 384 (with-builder (class add! get :size (size-of coll)) 385 (with-iterator (coll end? next) 386 (do () 387 [(end?) (get)] 388 (add! (proc (next)))))) 389 (with-builder (class add! get :size (maybe-minimum-size coll more)) 390 (call-with-iterators 391 (cons coll more) 392 (^[ends? nexts] 393 (do () 394 [(any (cut <>) ends?) (get)] 395 (add! (apply proc (map (cut <>) nexts))))))))) 396 397;; map-to <list> is equivalent to map. 398(define-method map-to ((class <list-meta>) proc coll . more) 399 (apply map proc coll more)) 400 401;; map-accum -------------------------------------------- 402 403;; Like Haskell's mapAccumL, but the order of args are different. 404;; 1-ary case: ((elt, seed) -> (res, seed)), seed, [elt] -> ([res], seed) 405 406(define-method map-accum (proc knil (coll <collection>) . more) 407 (if (null? more) 408 (receive (res knil) 409 (fold2 (^[elt lis knil] 410 (receive (res knil) (proc elt knil) 411 (values (cons res lis) knil))) 412 '() knil coll) 413 (values (reverse! res) knil)) 414 (call-with-iterators 415 (cons coll more) 416 (^[ends? nexts] 417 (let loop ([lis '()] [knil knil]) 418 (if (any (cut <>) ends?) 419 (values (reverse! lis) knil) 420 (receive (res knil) 421 (apply proc (fold-right (^[p r] (cons (p) r)) 422 (list knil) 423 nexts)) 424 (loop (cons res lis) knil)))))) 425 )) 426 427;; for-each --------------------------------------------- 428 429;; generic way. this shadows builtin for-each. 430(define-method for-each (proc (coll <collection>) . more) 431 (if (null? more) 432 (with-iterator (coll end? next) 433 (until (end?) (proc (next)))) 434 (let1 %map (with-module gauche map) 435 (call-with-iterators 436 (cons coll more) 437 (^[ends? nexts] 438 (until (any (cut <>) ends?) 439 (apply proc (%map (cut <>) nexts)))))))) 440 441;; for list arguments, built-in for-each is much faster. 442(define-method for-each (proc (coll <list>) . more) 443 (let1 %for-each (with-module gauche for-each) 444 (if (null? more) 445 (%for-each proc coll) 446 (if (every pair? more) 447 (apply %for-each proc coll more) 448 (next-method))))) 449 450;; redefine for-each$ to use generic version of for-each 451(define ((for-each$ proc) . args) (apply for-each proc args)) 452 453;; size-of ---------------------------------------------- 454 455;; generic way 456(define-method size-of ((coll <collection>)) 457 (fold (^[e r] (+ r 1)) 0 coll)) 458 459(define-method lazy-size-of ((coll <collection>)) 460 (delay (size-of coll))) 461 462;; shortcut 463;; NB: For uvectors, gauche.uvector defines more specific method for each 464;; concrete uvector types. This is a fallback when the user only 465;; loads gauche.collection. 466(define-method size-of ((coll <list>)) (length coll)) 467(define-method size-of ((coll <vector>)) (vector-length coll)) 468(define-method size-of ((coll <weak-vector>)) (weak-vector-length coll)) 469(define-method size-of ((coll <string>)) (string-length coll)) 470(define-method size-of ((coll <char-set>)) (char-set-size coll)) 471(define-method size-of ((coll <uvector>)) (uvector-length coll)) 472(define-method size-of ((coll <bitvector>)) (bitvector-length coll)) 473 474(define-method lazy-size-of ((coll <list>)) (length coll)) 475(define-method lazy-size-of ((coll <vector>)) (vector-length coll)) 476(define-method lazy-size-of ((coll <weak-vector>)) (weak-vector-length coll)) 477(define-method lazy-size-of ((coll <string>)) (string-length coll)) 478(define-method lazy-size-of ((coll <char-set>)) (char-set-size coll)) 479(define-method lazy-size-of ((coll <uvector>)) (uvector-length coll)) 480(define-method lazy-size-of ((coll <bitvector>)) (bitvector-length coll)) 481 482;; find ------------------------------------------------- 483 484;; generic way 485(define-method find (pred (coll <collection>)) 486 (with-iterator (coll end? next) 487 (let loop () 488 (if (end?) 489 #f 490 (let1 e (next) 491 (if (pred e) e (loop))))))) 492 493;; shortcut 494(define-method find (pred (coll <list>)) 495 ((with-module gauche find) pred coll)) 496 497;; find-min, find-max, find-min&max --------------------- 498 499(define-method find-min ((coll <collection>) 500 :key (key identity) 501 (compare <) 502 (default #f)) 503 (%find-minmax-1 coll key compare default)) 504 505(define-method find-max ((coll <collection>) 506 :key (key identity) 507 (compare <) 508 (default #f)) 509 (%find-minmax-1 coll key (complement compare) default)) 510 511(define (%find-minmax-1 coll key compare default) 512 (with-iterator (coll end? next) 513 (if (end?) 514 default 515 (let1 elt (next) 516 (let loop ([val (key elt)] 517 [elt elt]) 518 (if (end?) 519 elt 520 (let* ([e (next)] 521 [v (key e)]) 522 (if (compare v val) 523 (loop v e) 524 (loop val elt))))))))) 525 526(define-method find-min&max ((coll <collection>) 527 :key (key identity) 528 (compare <) 529 (default #f) 530 (default-min default) 531 (default-max default)) 532 (with-iterator (coll end? next) 533 (if (end?) 534 (values default-min default-max) 535 (let1 elt (next) 536 (let loop ([minval (key elt)] 537 [minelt elt] 538 [maxval (key elt)] 539 [maxelt elt]) 540 (if (end?) 541 (values minelt maxelt) 542 (let* ([e (next)] 543 [v (key e)]) 544 (cond [(compare v minval) (loop v e maxval maxelt)] 545 [(compare maxval v) (loop minval minelt v e)] 546 [else (loop minval minelt maxval maxelt)])))))))) 547 548;; filter ----------------------------------------------- 549 550;; generic way 551(define-method filter (pred (coll <collection>)) 552 (let1 q (make-queue) 553 (with-iterator (coll end? next) 554 (until (end?) (let1 e (next) (when (pred e) (enqueue! q e)))) 555 (queue->list q)))) 556 557(define-method filter-to ((class <class>) pred (coll <collection>)) 558 (with-builder (class add! get) 559 (with-iterator (coll end? next) 560 (do () 561 [(end?) (get)] 562 (let1 e (next) (when (pred e) (add! e))))))) 563 564;; shortcut 565(define-method filter (pred (coll <list>)) 566 ((with-module gauche filter) pred coll)) 567 568(define-method filter-to ((class <list-meta>) pred coll) 569 (filter pred coll)) 570 571;; remove ----------------------------------------------- 572 573;; generic way 574(define-method remove (pred (coll <collection>)) 575 (let1 q (make-queue) 576 (with-iterator (coll end? next) 577 (until (end?) (let1 e (next) (unless (pred e) (enqueue! q e)))) 578 (queue->list q)))) 579 580(define-method remove-to ((class <class>) pred (coll <collection>)) 581 (with-builder (class add! get) 582 (with-iterator (coll end? next) 583 (do () 584 [(end?) (get)] 585 (let1 e (next) (unless (pred e) (add! e))))))) 586 587;; shortcut 588(define-method remove (pred (coll <list>)) 589 ((with-module gauche remove) pred coll)) 590 591(define-method remove-to ((class <list-meta>) pred coll) 592 (remove pred coll)) 593 594;; partition --------------------------------------------- 595 596;; generic way 597(define-method partition (pred (coll <collection>)) 598 (with-iterator (coll end? next) 599 (let loop ([y '()] [n '()]) 600 (if (end?) 601 (values (reverse y) (reverse n)) 602 (let1 e (next) 603 (if (pred e) 604 (loop (cons e y) n) 605 (loop y (cons e n)))))))) 606 607(define-method partition-to ((class <class>) pred (coll <collection>)) 608 (with-builder (class add0! get0) 609 (with-builder (class add1! get1) 610 (with-iterator (coll end? next) 611 (do () 612 [(end?) (values (get0) (get1))] 613 (let1 e (next) 614 (if (pred e) (add0! e) (add1! e)))))))) 615 616;; shortcut 617(define-method partition (pred (coll <list>)) 618 ((with-module gauche partition) pred coll)) 619 620(define-method partition-to ((class <list-meta>) pred coll) 621 (partition pred coll)) 622 623;; coercion --------------------------------------------- 624 625(define-method coerce-to ((class <class>) (coll <collection>)) 626 (with-builder (class add! get :size (size-of coll)) 627 (with-iterator (coll end? next) 628 (do () 629 [(end?) (get)] 630 (add! (next)))))) 631 632;; shortcut 633(define-method coerce-to ((class <list-meta>) (coll <list>)) 634 (list-copy coll)) 635(define-method coerce-to ((class <list-meta>) (coll <vector>)) 636 (vector->list coll)) 637(define-method coerce-to ((class <list-meta>) (coll <string>)) 638 (string->list coll)) 639(define-method coerce-to ((class <vector-meta>) (coll <list>)) 640 (list->vector coll)) 641(define-method coerce-to ((class <string-meta>) (coll <list>)) 642 (list->string coll)) 643 644;; group-collection--------------------------------------- 645;; gather elements with the same key value. 646;; cf. group-sequence in gauche.sequence 647 648(define-method group-collection ((col <collection>) 649 :key ((:key key-proc) identity) 650 ((:test test-proc) eqv?)) 651 (fold (^[b r] (cons (reverse! (cdr b)) r)) 652 '() 653 (fold (^[elt buckets] 654 (let1 key (key-proc elt) 655 (cond [(assoc key buckets test-proc) 656 => (^p (push! (cdr p) elt) buckets)] 657 [else (cons (list key elt) buckets)]))) 658 '() 659 col))) 660 661