1;;;
2;;; liblist.scm - builtin list procedures
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(select-module gauche.internal)
35
36(inline-stub
37 (declcode (.include <gauche/vminsn.h>)))
38
39;;
40;; R5RS Standard procs
41;;
42
43(select-module scheme)
44(define-cproc pair? (obj) ::<boolean> :fast-flonum :constant
45  (inliner PAIRP) SCM_PAIRP)
46(define-cproc cons (obj1 obj2) (inliner CONS) Scm_Cons)
47(define-cproc car (obj::<pair>) :constant
48  (inliner CAR) (setter set-car!) SCM_CAR)
49(define-cproc cdr (obj::<pair>) :constant
50  (inliner CDR) (setter set-cdr!) SCM_CDR)
51(define-cproc set-car! (obj value) ::<void> Scm_SetCar)
52(define-cproc set-cdr! (obj value) ::<void> Scm_SetCdr)
53
54(inline-stub
55 "#define CXR_SETTER(PRE, pre, tail) \
56  ScmObj cell = Scm_C##tail##r(obj); \
57  if (!SCM_PAIRP(cell)) \
58    Scm_Error(\"can't set c\" #pre #tail \"r of %S\", obj); \
59  SCM_SET_C##PRE##R(cell, value);
60"
61 )
62(define-cproc caar (obj) :fast-flonum :constant
63  (inliner CAAR) (setter (obj value) ::<void> (CXR_SETTER A a a)) Scm_Caar)
64(define-cproc cadr (obj) :fast-flonum :constant
65  (inliner CADR) (setter (obj value) ::<void> (CXR_SETTER A a d)) Scm_Cadr)
66(define-cproc cdar (obj) :fast-flonum :constant
67  (inliner CDAR) (setter (obj value) ::<void> (CXR_SETTER D d a)) Scm_Cdar)
68(define-cproc cddr (obj) :fast-flonum :constant
69  (inliner CDDR) (setter (obj value) ::<void> (CXR_SETTER D d d)) Scm_Cddr)
70
71;; NB: we avoid using getter-with-setter here, since
72;;   - The current compiler doesn't take advantage of locked setters
73;;   - Using getter-with-setter loses the inferred closure name
74;; But this may change in future, of course.
75(select-module gauche)
76(define-syntax %define-cxr
77  (syntax-rules ()
78    ((_ name a b)
79     (begin
80       (define-inline (name x) (a (b x)))
81       (define-in-module scheme name name)
82       (set! (setter name) (^[x v] (set! (a (b x)) v)))
83       ))))
84
85(%define-cxr caaar  car  caar)
86(%define-cxr caadr  car  cadr)
87(%define-cxr cadar  car  cdar)
88(%define-cxr caddr  car  cddr)
89(%define-cxr cdaar  cdr  caar)
90(%define-cxr cdadr  cdr  cadr)
91(%define-cxr cddar  cdr  cdar)
92(%define-cxr cdddr  cdr  cddr)
93(%define-cxr caaaar caar caar)
94(%define-cxr caaadr caar cadr)
95(%define-cxr caadar caar cdar)
96(%define-cxr caaddr caar cddr)
97(%define-cxr cadaar cadr caar)
98(%define-cxr cadadr cadr cadr)
99(%define-cxr caddar cadr cdar)
100(%define-cxr cadddr cadr cddr)
101(%define-cxr cdaaar cdar caar)
102(%define-cxr cdaadr cdar cadr)
103(%define-cxr cdadar cdar cdar)
104(%define-cxr cdaddr cdar cddr)
105(%define-cxr cddaar cddr caar)
106(%define-cxr cddadr cddr cadr)
107(%define-cxr cdddar cddr cdar)
108(%define-cxr cddddr cddr cddr)
109
110;; primitives for immutable pars
111(define-cproc ipair? (obj) ::<boolean> Scm_ImmutablePairP)
112(define-cproc ipair (car cdr) Scm_MakeImmutablePair)
113(define-cproc ilist (:rest args)
114  (if (SCM_NULLP args)
115    (return SCM_NIL)
116    (let* ([h SCM_NIL] [t SCM_NIL])
117      (dopairs (cp args)
118        (if (SCM_NULLP t)
119          (set! h (Scm_MakeImmutablePair (SCM_CAR cp) SCM_NIL)
120                t h)
121          (let* ([p (Scm_MakeImmutablePair (SCM_CAR cp) SCM_NIL)])
122            (SCM_SET_CDR_UNCHECKED t p)
123            (set! t p))))
124      (return h))))
125
126(select-module scheme)
127(define-cproc null? (obj) ::<boolean> :fast-flonum :constant
128  (inliner NULLP) SCM_NULLP)
129(define-cproc list? (obj) ::<boolean> :fast-flonum :constant
130  SCM_PROPER_LIST_P)
131(define-cproc list (:rest args) (inliner LIST) (return args))
132
133(define-cproc length (list) ::<long> :constant (inliner LENGTH)
134  (let* ([len::long (Scm_Length list)])
135    (when (< len 0) (Scm_Error "bad list: %S" list))
136    (return len)))
137
138(select-module gauche)
139(define-cproc length<=? (list k::<integer>) ::<boolean> :constant
140  (if (SCM_INTP k)
141    (let* ([n::ScmSmallInt (SCM_INT_VALUE k)])
142      (dolist [_ list] (when (<= (post-- n) 0) (return FALSE)))
143      (return (<= 0 n)))
144    ;; k is bignum. it is impossible to have that long list, but list
145    ;; can be circular, so we need to scan list entirely anyway.
146    (if (< (Scm_Sign k) 0)
147      (return FALSE)
148      (let* ([ln::ScmSmallInt (Scm_Length list)])
149        (return (>= ln 0))))))
150(define-cproc length=? (list k::<integer>) ::<boolean> :constant
151  (if (SCM_INTP k)
152    (let* ([n::ScmSmallInt (SCM_INT_VALUE k)])
153      (dolist [_ list] (when (<= (post-- n) 0) (return FALSE)))
154      (return (== 0 n)))
155    (return FALSE)))
156(define (length<? list k) (length<=? list (- k 1)))
157(define (length>? list k) (not (length<=? list k)))
158(define (length>=? list k) (not (length<? list k)))
159
160(select-module scheme)
161(define-cproc append (:rest lists) (inliner APPEND) Scm_Append)
162(define-cproc reverse (list::<list> :optional (tail ())) Scm_Reverse2)
163
164(define-cproc list-tail (list k::<fixnum> :optional fallback) :constant
165  Scm_ListTail)
166;;We need to define list-set! as cproc in order to use it in the setter clause
167;;of list-ref.  This limitation of cgen.stub should be removed in future.
168;;(define (list-set! lis k v) (set-car! (list-tail lis k) v))
169(define-cproc list-set! (lis k::<fixnum> v) ::<void>
170  (let* ([p (Scm_ListTail lis k SCM_FALSE)])
171    (if (SCM_PAIRP p)
172      (Scm_SetCar p v)
173      (Scm_Error "list-set!: index out of bound: %d" k))))
174(define-cproc list-ref (list k::<fixnum> :optional fallback) :constant
175  (setter list-set!)
176  Scm_ListRef)
177
178(define-cproc memq (obj list::<list>) :constant (inliner MEMQ) Scm_Memq)
179(define-cproc memv (obj list::<list>) :constant (inliner MEMV) Scm_Memv)
180
181(define-cproc assq (obj alist::<list>) :constant (inliner ASSQ) Scm_Assq)
182(define-cproc assv (obj alist::<list>) :constant (inliner ASSV) Scm_Assv)
183
184(select-module gauche.internal)
185;; Actual member and assoc is defined blow.
186(define-cproc %member (obj list::<list>)
187  (return (Scm_Member obj list SCM_CMP_EQUAL)))
188(define-cproc %assoc (obj alist::<list>)
189  (return (Scm_Assoc obj alist SCM_CMP_EQUAL)))
190
191;;
192;; Some extra procedures
193;;
194
195(select-module gauche)
196(define-cproc length+ (list) :constant ;; srfi-1
197  (let* ([i::int (Scm_Length list)])
198    (if (< i 0) (return SCM_FALSE) (return (Scm_MakeInteger i)))))
199
200(define-cproc proper-list? (obj)   ::<boolean> :constant SCM_PROPER_LIST_P)
201(define-cproc dotted-list? (obj)   ::<boolean> :constant SCM_DOTTED_LIST_P)
202(define-cproc circular-list? (obj) ::<boolean> :constant SCM_CIRCULAR_LIST_P)
203(define-cproc make-list (len::<fixnum> :optional (fill #f)) Scm_MakeList)
204(define-cproc acons (caa cda cd) Scm_Acons)
205(define-cproc last-pair (list) :constant Scm_LastPair)
206(define-cproc list-copy (list) Scm_CopyList)
207
208(define-cproc list* (arg :rest args)
209  (inliner LIST-STAR)
210  (if (SCM_NULLP args)
211    (return arg)
212    (let* ([head (SCM_LIST1 arg)] [tail head])
213      (dopairs [cp args]
214        (unless (SCM_PAIRP (SCM_CDR cp))
215          (SCM_SET_CDR_UNCHECKED tail (SCM_CAR cp))
216          (break))
217        (SCM_APPEND1 head tail (SCM_CAR cp)))
218      (return head))))
219
220(define-cproc append! (:rest list)
221  (let* ([h '()] [t '()])
222    (dopairs [cp list]
223      (when (SCM_NULLP (SCM_CDR cp))
224        (if (SCM_NULLP h)
225          (set! h (SCM_CAR cp))
226          (Scm_SetCdr t (SCM_CAR cp)))
227        (break))
228      (SCM_APPEND h t (SCM_CAR cp))
229      (unless (or (SCM_NULLP t) (SCM_NULLP (SCM_CDR t)))
230        (Scm_Error "proper list required, but got %S" (SCM_CAR cp))))
231    (return h)))
232
233(define-cproc reverse! (list :optional (tail ())) Scm_Reverse2X)
234
235(define-cproc monotonic-merge (sequences::<list>) Scm_MonotonicMerge1)
236
237(select-module gauche.internal)
238(define-in-module scheme (map proc lis . more)
239  (if (null? more)
240    (let loop ([xs lis] [r '()])
241      (cond [(pair? xs) (loop (cdr xs) (cons (proc (car xs)) r))]
242            [(null? xs) (reverse r)]
243            [else (error "improper list not allowed:" lis)]))
244    (let loop ([xss (cons lis more)] [r '()])
245      (receive (cars cdrs) (%zip-nary-args xss)
246        (if (not cars)
247          (reverse r)
248          (loop cdrs (cons (apply proc cars) r)))))))
249
250(define-in-module scheme (for-each proc lis . more)
251  (if (null? more)
252    (let loop ([xs lis])
253      (cond [(pair? xs) (proc (car xs)) (loop (cdr xs))]
254            [(null? xs) (undefined)]
255            [else (error "improper list not allowed:" lis)]))
256    (let loop ([xss (cons lis more)])
257      (receive (cars cdrs) (%zip-nary-args xss)
258        (unless (not cars)
259          (apply proc cars)
260          (loop cdrs))))))
261
262(select-module gauche)
263(define-inline (null-list? l)           ;srfi-1
264  (cond [(null? l)]
265        [(pair? l) #f]
266        [else (error "argument must be a list, but got:" l)]))
267
268(define-inline cons* list*)             ;srfi-1
269
270(define (last lis) (car (last-pair lis))) ;srfi-1
271
272(define (iota count :optional (start 0) (step 1)) ;srfi-1
273  (unless (and (integer? count) (>= count 0))
274    (error "count must be nonnegative integer: " count))
275  (if (and (exact? start) (exact? step))
276    ;; we allow inexact integer as 'count', for the consistency of
277    ;; giota and liota in which we can also accept +inf.0 as count.
278    (let1 count (exact count)
279      (do ([c count (- c 1)]
280           [v (+ start (* (- count 1) step)) (- v step)]
281           [r '() (cons v r)])
282          [(<= c 0) r]))
283    ;; for inexact numbers, we use multiplication to avoid error accumulation.
284    (do ([c count (- c 1)]
285         [r '() (cons (+ start (*. (- c 1) step)) r)])
286        [(<= c 0) r])))
287
288(select-module gauche.internal)
289(inline-stub
290 ;; translate cmpmode argument
291 (define-cfn getcmpmode (opt) ::int :static
292   (cond
293    [(or (SCM_UNBOUNDP opt) (SCM_EQ opt 'equal?)) (return SCM_CMP_EQUAL)]
294    [(SCM_EQ opt 'eq?) (return SCM_CMP_EQ)]
295    [(SCM_EQ opt 'eqv?) (return SCM_CMP_EQV)]
296    [else (Scm_Error "unrecognized compare mode: %S" opt) (return 0)]))
297 )
298
299(define-cproc %delete (obj list::<list> :optional cmpmode)
300  (return (Scm_Delete obj list (getcmpmode cmpmode))))
301(define-cproc %delete! (obj list::<list> :optional cmpmode)
302  (return (Scm_DeleteX obj list (getcmpmode cmpmode))))
303(define-cproc %delete-duplicates (list::<list> :optional cmpmode)
304  (return (Scm_DeleteDuplicates list (getcmpmode cmpmode))))
305(define-cproc %delete-duplicates! (list::<list> :optional cmpmode)
306  (return (Scm_DeleteDuplicatesX list (getcmpmode cmpmode))))
307(define-cproc %alist-delete (elt list::<list> :optional cmpmode)
308  (return (Scm_AssocDelete elt list (getcmpmode cmpmode))))
309(define-cproc %alist-delete! (elt list::<list> :optional cmpmode)
310  (return (Scm_AssocDeleteX elt list (getcmpmode cmpmode))))
311
312(define-in-module gauche.internal (%zip-nary-args arglists . seed)
313  (let loop ([as arglists]
314             [cars '()]
315             [cdrs '()])
316    (cond [(null? as)
317           (values (reverse! (if (null? seed) cars (cons (car seed) cars)))
318                   (reverse! cdrs))]
319          [(null? (car as)) (values #f #f)] ;;exhausted
320          [(pair? (car as))
321           (loop (cdr as) (cons (caar as) cars) (cons (cdar as) cdrs))]
322          [else
323           (error "argument lists contained an improper list ending with:"
324                  (car as))])))
325
326;; In the common case, these procs uses Gauche native, even not loading
327;; the generic filter routine.
328(define-syntax %case-by-cmp
329  (syntax-rules ()
330    [(_ args = eq-case eqv-case equal-case default-case)
331     (let1 = (if (pair? args) (car args) equal?)
332       (cond [(eq? = eq?)    eq-case]
333             [(eq? = eqv?)   eqv-case]
334             [(eq? = equal?) equal-case]
335             [else default-case]))]))
336
337(define-in-module gauche (delete x lis . args)
338  (%case-by-cmp args =
339                (%delete x lis 'eq?)
340                (%delete x lis 'eqv?)
341                (%delete x lis 'equal?)
342                (filter (^y (not (= x y))) lis)))
343
344(define-in-module gauche (delete! x lis . args)
345  (%case-by-cmp args =
346                (%delete! x lis 'eq?)
347                (%delete! x lis 'eqv?)
348                (%delete! x lis 'equal?)
349                (filter! (^y (not (= x y))) lis)))
350
351(define-in-module scheme (member x lis . args)
352  (%case-by-cmp args =
353                (memq x lis)
354                (memv x lis)
355                (%member x lis)
356                (find-tail (^y (= x y)) lis)))
357
358(define-in-module gauche (delete-duplicates lis . args)
359  (%case-by-cmp args =
360                (%delete-duplicates lis 'eq?)
361                (%delete-duplicates lis 'eqv?)
362                (%delete-duplicates lis 'equal?)
363                (let recur ([lis lis])
364                  (if (null-list? lis) lis
365                      (let* ([x (car lis)]
366                             [tail (cdr lis)]
367                             [new-tail (recur (delete x tail =))])
368                        (if (eq? tail new-tail) lis (cons x new-tail)))))))
369
370(define-in-module gauche (delete-duplicates! lis . args)
371  (%case-by-cmp args =
372                (%delete-duplicates! lis 'eq?)
373                (%delete-duplicates! lis 'eqv?)
374                (%delete-duplicates! lis 'equal?)
375                (let recur ((lis lis))
376                  (if (null-list? lis) lis
377                      (let* ((x (car lis))
378                             (tail (cdr lis))
379                             (new-tail (recur (delete! x tail =))))
380                        (if (eq? tail new-tail) lis (cons x new-tail)))))))
381
382;;
383;; Higher-order stuff
384;;
385
386(select-module gauche)
387
388(define (any pred lis . more)
389  (if (null? more)
390    (and (not (null-list? lis))
391         (let loop ((head (car lis)) (tail (cdr lis)))
392           (cond [(null-list? tail) (pred head)] ; tail call
393                 [(pred head)]
394                 [else (loop (car tail) (cdr tail))])))
395    (let loop ([liss (cons lis more)])
396      (receive (cars cdrs) ((with-module gauche.internal %zip-nary-args) liss)
397        (cond [(not cars) #f]
398              [(apply pred cars)]
399              [else (loop cdrs)])))))
400
401(define (every pred lis . more)
402  (if (null? more)
403    (or (null-list? lis)
404        (let loop ([head (car lis)] [tail (cdr lis)])
405          (cond [(null-list? tail) (pred head)] ; tail call
406                [(not (pred head)) #f]
407                [else (loop (car tail) (cdr tail))])))
408    (receive (heads tails)
409        ((with-module gauche.internal %zip-nary-args) (cons lis more))
410      (or (not heads)
411          (let loop ([heads heads] [tails tails])
412            (receive (next-heads next-tails)
413                ((with-module gauche.internal %zip-nary-args) tails)
414              (if next-heads
415                  (and (apply pred heads)
416                       (loop next-heads next-tails))
417                  (apply pred heads))))))))
418
419(define (filter pred lis)
420  (let loop ([lis lis] [r '()])
421    (cond [(null-list? lis) (reverse r)]
422          [(pred (car lis)) (loop (cdr lis) (cons (car lis) r))]
423          [else (loop (cdr lis) r)])))
424
425(define (filter! pred lis)
426  (define (keep! prev lis)
427    (when (pair? lis)
428      (if (pred (car lis))
429        (keep! lis (cdr lis))
430        (skip! prev (cdr lis)))))
431  (define (skip! prev lis)
432    (let loop ([lis lis])
433      (cond [(not (pair? lis)) (set-cdr! prev lis)]
434            [(pred (car lis)) (set-cdr! prev lis) (keep! lis (cdr lis))]
435            [else (loop (cdr lis))])))
436  (let restart ([ans lis])
437    (cond [(null-list? ans) ans]
438          [(not (pred (car ans))) (restart (cdr ans))]
439          [else (keep! ans (cdr ans)) ans])))
440
441(define (remove  pred l) (filter  (^x (not (pred x))) l))
442(define (remove! pred l) (filter! (^x (not (pred x))) l))
443
444(define (filter-map fn lis . more)
445  (if (null? more)
446    (let loop ([lis lis] [r '()])
447      (cond [(null-list? lis) (reverse r)]
448            [(fn (car lis)) => (^x (loop (cdr lis) (cons x r)))]
449            [else (loop (cdr lis) r)]))
450    (let loop ([liss (cons lis more)] [r '()])
451      (receive (cars cdrs)
452          ((with-module gauche.internal %zip-nary-args) liss)
453        (cond [(not cars) (reverse r)]
454              [(apply fn cars) => (^x (loop cdrs (cons x r)))]
455              [else (loop cdrs r)])))))
456
457(define (fold kons knil lis . more)
458  (if (null? more)
459    (let loop ([lis lis] [knil knil])
460      (if (null-list? lis) knil (loop (cdr lis) (kons (car lis) knil))))
461    (let loop ([liss (cons lis more)] [knil knil])
462      (receive (cars cdrs)
463          ((with-module gauche.internal %zip-nary-args) liss knil)
464        (if cars
465          (loop cdrs (apply kons cars))
466          knil)))))
467
468(define (fold-left snok knil lis . more)
469  (if (null? more)
470    (let loop ([lis lis] [knil knil])
471      (if (null-list? lis) knil (loop (cdr lis) (snok knil (car lis)))))
472    (let loop ([liss (cons lis more)] [knil knil])
473      (receive (cars- cdrs)
474          ((with-module gauche.internal %zip-nary-args) liss)
475        (if cars-
476          (loop cdrs (apply snok knil cars-))
477          knil)))))
478
479(define (fold-right kons knil lis . more)
480  (if (null? more)
481    (let rec ([lis lis])
482      (if (null-list? lis)
483        knil
484        (kons (car lis) (rec (cdr lis)))))
485    (let rec ([liss (cons lis more)])
486      (receive (cars cdrs) ((with-module gauche.internal %zip-nary-args) liss)
487        (if cars
488          (apply kons (append! cars (list (rec cdrs))))
489          knil)))))
490
491(define (count pred lis . more)
492  (if (null? more)
493    (let rec ([lis lis] [cnt 0])
494      (if (null-list? lis)
495        cnt
496        (rec (cdr lis) (if (pred (car lis)) (+ cnt 1) cnt))))
497    (let rec ([liss (cons lis more)] [cnt 0])
498      (receive (cars cdrs) ((with-module gauche.internal %zip-nary-args) liss)
499        (if cars
500          (rec cdrs (if (apply pred cars) (+ cnt 1) cnt))
501          cnt)))))
502
503(define (reduce f ridentity lis)
504  (if (null-list? lis)
505    ridentity
506    (fold f (car lis) (cdr lis))))
507
508(define (reduce-right f ridentity lis)
509  (if (null-list? lis)
510    ridentity
511    (let rec ([head (car lis)] [lis (cdr lis)])
512      (if (pair? lis)
513        (f head (rec (car lis) (cdr lis)))
514        head))))
515
516(define (append-reverse list tail)  (reverse list tail)) ;srfi-1 compat
517(define (append-reverse! list tail) (reverse! list tail));srfi-1 compat
518
519(define (concatenate  lists) (reduce-right append  '() lists))
520(define (concatenate! lists) (reduce-right append! '() lists))
521
522(define (append-map f lis . lists)  (concatenate  (apply map f lis lists)))
523(define (append-map! f lis . lists) (concatenate! (apply map f lis lists)))
524
525(define (map* fn tail-fn lis . more)
526  (if (null? more)
527    (let rec ([xs lis] [rs '()])
528      (if (pair? xs)
529        (rec (cdr xs) (cons (fn (car xs)) rs))
530        (reverse rs (tail-fn xs))))
531    (let rec ([xss (cons lis more)] [rs '()])
532      (if (every pair? xss)
533        (receive (cars cdrs) ((with-module gauche.internal %zip-nary-args) xss)
534          (rec cdrs (cons (apply fn cars) rs)))
535        (reverse rs (apply tail-fn xss))))))
536
537(define (find pred lis)
538  (let loop ([lis lis])
539    (cond [(not (pair? lis)) #f]
540          [(pred (car lis)) (car lis)]
541          [else (loop (cdr lis))])))
542
543(define (find-tail pred lis)
544  (let loop ([lis lis])
545    (cond [(not (pair? lis)) #f]
546          [(pred (car lis)) lis]
547          [else (loop (cdr lis))])))
548
549(define (split-at lis i)
550  (let loop ([i i] [rest lis] [r '()])
551    (cond [(= i 0) (values (reverse! r) rest)]
552          [(null? rest) (error "given list is too short:" lis)]
553          [else (loop (- i 1) (cdr rest) (cons (car rest) r))])))
554
555(define (split-at! lis i)
556  (let loop ([i i] [rest lis] [prev #f])
557    (cond [(= i 0) (if prev
558                     (begin (set-cdr! prev '()) (values lis rest))
559                     (values '() rest))]
560          [(null? rest) (error "given list is too short:" lis)]
561          [else (loop (- i 1) (cdr rest) rest)])))
562
563;; partition is here, for gauche.procedure has partition$ and we don't
564;; want it to depend on srfi-1.  partition! is left in srfi-1, for its
565;; optimized version is rather complicated.
566(define (partition pred lis)
567  (let rec ([lis lis] [xs '()] [ys '()])
568    (if (null-list? lis)
569      (values (reverse! xs) (reverse! ys))
570      (if (pred (car lis))
571        (rec (cdr lis) (cons (car lis) xs) ys)
572        (rec (cdr lis) xs (cons (car lis) ys))))))
573
574(define (take list k)
575  (let loop ([lis list] [r '()] [j k])
576    (cond [(= j 0) (reverse! r)]
577          [(pair? lis) (loop (cdr lis) (cons (car lis) r) (- j 1))]
578          [else (errorf "take: input list is too short (expected at least \
579                         ~a elements, but only ~a elements long): ~,,,,70s"
580                        k (- k j) list)])))
581
582(define drop list-tail)  ; srfi-1
583
584(define (take-right lis k)
585  (let loop ([p0 (list-tail lis k)] [p1 lis])
586    (if (pair? p0) (loop (cdr p0) (cdr p1)) p1)))
587
588(define (drop-right lis k)
589  (let rec ([p0 (list-tail lis k)] [p1 lis])
590    (if (pair? p0) (cons (car p1) (rec (cdr p0) (cdr p1))) '())))
591
592(define (take! lis k)
593  (cond [(zero? k) '()]
594        [else (set-cdr! (list-tail lis (- k 1)) '()) lis]))
595
596(define (drop-right! lis k)
597  (let1 p0 (list-tail lis k)
598    (if (pair? p0)
599      (let loop ([p0 (cdr p0)] [p1 lis])
600        (if (pair? p0)
601          (loop (cdr p0) (cdr p1))
602          (begin (set-cdr! p1 '()) lis)))
603      '())))
604
605;; Permissive versions
606(define (split-at* lis k :optional (fill? #f) (filler #f))
607  (when (or (not (integer? k)) (negative? k))
608    (error "index must be non-negative integer" k))
609  (let loop ((i 0)
610             (lis lis)
611             (r '()))
612    (cond [(= i k) (values (reverse! r) lis)]
613          [(null? lis)
614           (values (if fill?
615                     (append! (reverse! r) (make-list (- k i) filler))
616                     (reverse! r))
617                   lis)]
618          [else (loop (+ i 1) (cdr lis) (cons (car lis) r))])))
619
620(define (take* lis k . args)
621  (receive (h t) (apply split-at* lis k args) h))
622
623(define (drop* lis k)
624  (when (or (not (integer? k)) (negative? k))
625    (error "index must be non-negative integer" k))
626  (let loop ((i 0)
627             (lis lis))
628    (cond [(= i k) lis]
629          [(null? lis) '()]
630          [else (loop (+ i 1) (cdr lis))])))
631
632(with-module gauche.internal
633  ;; A tolerant version of list-tail.  If LIS is shorter than K, returns
634  ;; (- k (length lis)) as the second value.
635  (define (%list-tail* lis k)
636    (let loop ([lis lis] [k k])
637      (cond [(<= k 0) (values lis 0)]
638            [(null? lis) (values lis k)]
639            [else (loop (cdr lis) (- k 1))])))
640  )
641
642(define (take-right* lis k :optional (fill? #f) (filler #f))
643  (when (or (not (integer? k)) (negative? k) (inexact? k))
644    (error "index must be non-negative exact integer" k))
645  ;; NB: This procedure can be used to take the last K elements of
646  ;; a huge lazy list.  (Not so much in take-right, with which you need
647  ;; to know the length of list is greater than K beforehand.)
648  ;; The naive implementation (drop lis (- (length lis) k)) would require
649  ;; to realize entire list on memory, which we want to avoid.
650  ;; We overwrite LIS and TAIL in each iteration instead of rebinding it,
651  ;; in order to release reference to the head of list.
652  (receive (tail j) ((with-module gauche.internal %list-tail*) lis k)
653    (if (= j 0)
654      (let loop ()
655        (if (pair? tail)
656          (begin (set! lis (cdr lis))
657                 (set! tail (cdr tail))
658                 (loop))
659          lis))
660      (if fill?
661        (append! (make-list j filler) lis)
662        lis))))
663
664(define (drop-right* lis k)
665  (let1 len (length lis)
666    (if (<= k len) (take lis (- len k)) '())))
667
668;; slices - split a list to a bunch of sublists of length k
669(define (slices lis k . args)
670  (unless (and (integer? k) (positive? k))
671    (error "index must be positive integer" k))
672  (let loop ([lis lis]
673             [r '()])
674    (if (null? lis)
675      (reverse! r)
676      (receive (h t) (apply split-at* lis k args)
677        (loop t (cons h r))))))
678
679;; intersperse - insert ITEM between elements in the list.
680;; (the order of arguments is taken from Haskell's intersperse)
681(define (intersperse item lis)
682  (define (rec l r)
683    (if (null? l)
684        (reverse! r)
685        (rec (cdr l) (list* (car l) item r))))
686  (if (null? lis)
687      '()
688      (rec (cdr lis) (list (car lis)))))
689
690;;
691;; Assoc lists
692;;
693
694(select-module gauche.internal)
695(define-in-module scheme (assoc x lis . args)
696  (%case-by-cmp args =
697                (assq x lis)
698                (assv x lis)
699                (%assoc x lis)
700                (find (^[entry] (= x (car entry))) lis)))
701
702(define-in-module gauche (alist-copy alist)
703  (map (^[elt] (cons (car elt) (cdr elt))) alist))
704
705(define-in-module gauche (alist-delete key alist . args)
706  (%case-by-cmp args =
707                (%alist-delete key alist 'eq?)
708                (%alist-delete key alist 'eqv?)
709                (%alist-delete key alist 'equal?)
710                (filter (^[elt] (not (= key (car elt)))) alist)))
711
712(define-in-module gauche (alist-delete! key alist . args)
713  (%case-by-cmp args =
714                (%alist-delete! key alist 'eq?)
715                (%alist-delete! key alist 'eqv?)
716                (%alist-delete! key alist 'equal?)
717                (filter! (^[elt] (not (= key (car elt)))) alist)))
718
719(select-module gauche)
720;; `reverse' alist search fn
721(define (rassoc key alist :optional (eq equal?))
722  (find (^[elt] (and (pair? elt) (eq (cdr elt) key))) alist))
723
724(define rassq (cut rassoc <> <> eq?))
725(define rassv (cut rassoc <> <> eqv?))
726
727;; 'assoc-ref', a shortcut of value retrieval w/ default value
728;; Default parameter comes first, following the convention of
729;; other *-ref functions.
730(define (assoc-ref alist key :optional (default #f) (eq equal?))
731  (cond [(assoc key alist eq) => cdr]
732        [else default]))
733
734(define (assq-ref alist key :optional (default #f))
735  (assoc-ref alist key default eq?))
736(define (assv-ref alist key :optional (default #f))
737  (assoc-ref alist key default eqv?))
738
739(define (rassoc-ref alist key :optional (default #f) (eq equal?))
740  (cond [(rassoc key alist eq) => car]
741        [else default]))
742
743(define (rassq-ref alist key :optional (default #f))
744  (rassoc-ref alist key default eq?))
745(define (rassv-ref alist key :optional (default #f))
746  (rassoc-ref alist key default eqv?))
747
748;; 'assoc-set!'
749(define (assoc-set! alist key val :optional (eq equal?))
750  (cond [(assoc key alist eq) => (^p (set-cdr! p val) alist)]
751        [else (acons key val alist)]))
752
753(define assq-set!  (cut assoc-set! <> <> <> eq?))
754(define assv-set!  (cut assoc-set! <> <> <> eqv?))
755
756(define (assoc-adjoin alist key val :optional (eq equal?))
757  (define (rec alis)
758    (cond [(null? alis) '()]
759          [(eq key (caar alis)) (acons key val (cdr alis))]
760          [else (let1 tail (rec (cdr alis))
761                  (if (eq? tail (cdr alis))
762                    alis
763                    (cons (car alis) tail)))]))
764  (let1 r (rec alist)
765    (if (eq? r alist)
766      (acons key val alist)
767      r)))
768
769(define (assoc-update-in alist keys proc :optional (default #f) (eq equal?))
770  (define (rec alist key keys)
771    (if (null? keys)
772      (let1 val (assoc-ref alist key default eq)
773        (assoc-adjoin alist key (proc val) eq))
774      (let1 val (assoc-ref alist key '() eq)
775        (assoc-adjoin alist key (rec val (car keys) (cdr keys)) eq))))
776  (if (null? keys)
777    (error "nees at least one key in assoc-update")
778    (rec alist (car keys) (cdr keys))))
779
780
781;;;
782;;; Extended pairs
783;;;
784
785(select-module gauche.internal)
786;; Pair attributes
787;;
788;;  Pair attributes are almost exclusively used to attach source-code
789;;  information to s-exprs.
790
791(define-cproc pair-attributes (pair::<pair>) Scm_PairAttr)
792
793(define-cproc pair-attribute-get (pair::<pair> key :optional fallback)
794  (return (Scm_PairAttrGet (SCM_PAIR pair) key fallback)))
795
796(define-cproc pair-attribute-set! (pair::<pair> key value)
797  (return (Scm_PairAttrSet (SCM_PAIR pair) key value)))
798
799(define-cproc extended-pair? (obj) ::<boolean> SCM_EXTENDED_PAIR_P)
800(define-cproc extended-cons (car cdr) Scm_ExtendedCons)
801(define-cproc extended-list (elt :rest more) Scm_ExtendedCons)
802