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