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