1;; for a bit of better performance 2(define (hashtable-for-each proc ht) 3 (unless (procedure? proc) 4 (assertion-violation 'hashtable-for-each 5 (wrong-type-argument-message "procedure" proc 1))) 6 (unless (hashtable? ht) 7 (assertion-violation 'hashtable-for-each 8 (wrong-type-argument-message "hashtable" ht 2))) 9 (let ((itr (%hashtable-iter ht)) 10 (eof (cons #t #t))) 11 (let loop () 12 (let-values (((k v) (itr eof))) 13 (unless (eq? k eof) 14 (proc k v) (loop)))))) 15 16(define (hashtable-map proc ht) 17 (unless (procedure? proc) 18 (assertion-violation 'hashtable-map 19 (wrong-type-argument-message "procedure" proc 1))) 20 (unless (hashtable? ht) 21 (assertion-violation 'hashtable-map 22 (wrong-type-argument-message "hashtable" ht 2))) 23 (let ((itr (%hashtable-iter ht)) 24 (eof (cons #t #t))) 25 (let loop ((r '())) 26 (let-values (((k v) (itr eof))) 27 (if (eq? k eof) 28 r 29 (loop (cons (proc k v) r))))))) 30 31(define (hashtable-fold kons ht knil) 32 (unless (procedure? kons) 33 (assertion-violation 'hashtable-fold 34 (wrong-type-argument-message "procedure" proc 1))) 35 (unless (hashtable? ht) 36 (assertion-violation 'hashtable-fold 37 (wrong-type-argument-message "hashtable" ht 2))) 38 (let ((itr (%hashtable-iter ht)) 39 (eof (cons #t #t))) 40 (let loop ((r knil)) 41 (let-values (((k v) (itr eof))) 42 (if (eq? k eof) 43 r 44 (loop (kons k v r))))))) 45 46(define (hashtable->alist ht) 47 (hashtable-map cons ht)) 48 49(define (unique-id-list? lst) 50 (and (list? lst) 51 (not (let loop ((lst lst)) 52 (and (pair? lst) 53 (or (not (variable? (car lst))) 54 (id-memq (car lst) (cdr lst)) 55 (loop (cdr lst)))))))) 56 57#;(define (any pred ls) 58 (if (pair? ls) (if (pred (car ls)) (car ls) (any pred (cdr ls))) #f)) 59 60(define (call-with-values producer consumer) 61 (receive vals (producer) (apply consumer vals))) 62 63;; print 64(define (print . args) 65 (for-each display args) 66 (newline)) 67 68(define (fold proc seed lst1 . lst2) 69 (if (null? lst2) 70 (let loop ((lis lst1) (knil seed)) 71 (if (null? lis) 72 knil 73 (loop (cdr lis) (proc (car lis) knil)))) 74 (let loop ((lis (apply list-transpose* lst1 lst2)) (knil seed)) 75 (if (null? lis) 76 knil 77 (loop (cdr lis) (apply proc (append (car lis) (list knil)))))))) 78 79;; from Ypsilon 80(define (wrong-type-argument-message expect got . nth) 81 (if (null? nth) 82 (format "expected ~a, but got ~a" expect got) 83 (format "expected ~a, but got ~a, as argument ~a" expect got (car nth)))) 84 85;; From Gauche 86;; we don't define SRFI-43 vector-map/vector-for-each here 87;; so make those tabulate/update! internal define for better performance. 88(define (vector-map proc vec . more) 89 (define (vector-tabulate len proc) 90 (let loop ((i 0) (r '())) 91 (if (= i len) 92 (list->vector (reverse! r)) 93 (loop (+ i 1) (cons (proc i) r))))) 94 (if (null? more) 95 (vector-tabulate (vector-length vec) 96 (lambda (i) (proc (vector-ref vec i)))) 97 (let ((vecs (cons vec more))) 98 (vector-tabulate (apply min (map vector-length vecs)) 99 (lambda (i) 100 (apply proc (map (lambda (v) (vector-ref v i)) 101 vecs))))))) 102(define (vector-map! proc vec . more) 103 (define (vector-update! vec len proc) 104 (let loop ((i 0)) 105 (if (= i len) 106 vec 107 (begin 108 (vector-set! vec i (proc i)) 109 (loop (+ i 1)))))) 110 (if (null? more) 111 (vector-update! vec (vector-length vec) 112 (lambda (i) (proc (vector-ref vec i)))) 113 (let ((vecs (cons vec more))) 114 (vector-update! vec (apply min (map vector-length vecs)) 115 (lambda (i) 116 (apply proc (map (lambda (v) (vector-ref v i)) 117 vecs))))))) 118 119(define (vector-for-each proc vec . more) 120 (if (null? more) 121 (let ((len (vector-length vec))) 122 (let loop ((i 0)) 123 (unless (= i len) 124 (proc (vector-ref vec i)) 125 (loop (+ i 1))))) 126 (let* ((vecs (cons vec more)) 127 (len (apply min (map vector-length vecs)))) 128 (let loop ((i 0)) 129 (unless (= i len) 130 (apply proc (map (lambda (v) (vector-ref v i)) vecs)) 131 (loop (+ i 1))))))) 132 133;; same as vector-for-each 134(define (string-for-each proc str . more) 135 (if (null? more) 136 (let ((len (string-length str))) 137 (let loop ((i 0)) 138 (unless (= i len) 139 (proc (string-ref str i)) 140 (loop (+ i 1))))) 141 (let* ((strs (cons str more)) 142 (len (apply min (map string-length strs)))) 143 (let loop ((i 0)) 144 (unless (= i len) 145 (apply proc (map (lambda (s) (string-ref s i)) strs)) 146 (loop (+ i 1))))))) 147 148;;;; 149;; from SRFI-13 150 151;;; (string-join string-list [delimiter grammar]) => string 152;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 153;;; Paste strings together using the delimiter string. 154;;; 155;;; (join-strings '("foo" "bar" "baz") ":") => "foo:bar:baz" 156;;; 157;;; DELIMITER defaults to a single space " " 158;;; GRAMMAR is one of the symbols {prefix, infix, strict-infix, suffix} 159;;; and defaults to 'infix. 160;;; 161;;; I could rewrite this more efficiently -- precompute the length of the 162;;; answer string, then allocate & fill it in iteratively. Using 163;;; STRING-CONCATENATE is less efficient. 164 165(define (string-join strings :optional (delim " ") (grammar 'infix)) 166 (define (buildit lis final) 167 (let recur ((lis lis)) 168 (if (pair? lis) 169 (cons delim (cons (car lis) (recur (cdr lis)))) 170 final))) 171 (unless (string? delim) 172 (error 'string-join "Delimiter must be a string" delim)) 173 (cond ((pair? strings) 174 (string-concatenate 175 (case grammar 176 ((infix strict-infix) 177 (cons (car strings) (buildit (cdr strings) '()))) 178 ((prefix) (buildit strings '())) 179 ((suffix) 180 (cons (car strings) (buildit (cdr strings) (list delim)))) 181 (else (error 'string-join "Illegal join grammar" 182 grammar string-join))))) 183 ((not (null? strings)) 184 (error 'string-join "STRINGS parameter not list." 185 strings string-join)) 186 ((eq? grammar 'strict-infix) 187 (error 'string-join 188 "Empty list cannot be joined with STRICT-INFIX grammar." 189 string-join)) 190 (else ""))) ; Special-cased for infix grammar. 191 192;;;; 193;; from Ypsilon 194 195;; from srfi-1 start 196(define (null-list? l) 197 (cond ((pair? l) #f) 198 ((null? l) #t) 199 (else (assertion-violation 'null-list? "argument out of domain" l)))) 200 201(define (split-at x k) 202 (or (integer? k) 203 (assertion-violation 'split-at 204 (wrong-type-argument-message "integer" k 2))) 205 (let recur ((lis x) (k k) (r '())) 206 (cond ((zero? k) (values (reverse! r) lis)) 207 ((null? lis) (error 'split-at "given list it too short")) 208 (else (recur (cdr lis) (- k 1) (cons (car lis) r)))))) 209 210(define (find pred list) 211 (cond ((find-tail pred list) => car) 212 (else #f))) 213 214(define (find-tail pred list) 215 (or (procedure? pred) 216 (assertion-violation 'find-tail 217 (wrong-type-argument-message "procedure" pred 2))) 218 (let lp ((list list)) 219 (and (not (null? list)) 220 (if (pred (car list)) list 221 (lp (cdr list)))))) 222 223(define (assoc x lis . =) 224 (or (list? lis) 225 (assertion-violation 'assoc 226 (wrong-type-argument-message "list" lis 2))) 227 (if (null? =) 228 (assoc x lis equal?) 229 (find (lambda (entry) ((car =) x (car entry))) lis))) 230 231(define (member x lis . =) 232 (if (null? =) 233 (member x lis equal?) 234 (find-tail (lambda (y) ((car =) x y)) lis))) 235 236(define (delete x lis . =) 237 (if (null? =) 238 (delete x lis equal?) 239 (filter (lambda (y) (not ((car =) x y))) lis))) 240 241(define (delete! x lis . =) 242 (if (null? =) 243 (delete x lis equal?) 244 (filter! (lambda (y) (not ((car =) x y))) lis))) 245 246(define (reduce f ridentity lis) 247 (or (procedure? f) 248 (assertion-violation 'reduce (wrong-type-argument-message "procedure" = 1))) 249 (if (null? lis) ridentity 250 (fold f (car lis) (cdr lis)))) 251 252(define (lset-union = . lists) 253 (or (procedure? =) 254 (assertion-violation 'lset-union 255 (wrong-type-argument-message "procedure" = 1))) 256 (reduce (lambda (lis ans) ; Compute ANS + LIS. 257 (cond ((null? lis) ans) ; Don't copy any lists 258 ((null? ans) lis) ; if we don't have to. 259 ((eq? lis ans) ans) 260 (else 261 (fold (lambda (elt ans) 262 (if (exists (lambda (x) (= x elt)) ans) 263 ans 264 (cons elt ans))) 265 ans lis)))) 266 '() lists)) 267 268(define (lset-intersection = lis1 . lists) 269 (or (procedure? =) 270 (assertion-violation 'lset-intersection 271 (wrong-type-argument-message "procedure" = 1))) 272 (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. 273 (cond ((exists null? lists) '()) ; Short cut 274 ((null? lists) lis1) ; Short cut 275 (else (filter (lambda (x) 276 (for-all (lambda (lis) (member x lis =)) lists)) 277 lis1))))) 278 279(define (lset-difference = lis1 . lists) 280 (or (procedure? =) 281 (assertion-violation 'lset-difference 282 (wrong-type-argument-message "procedure" = 1))) 283 (let ((lists (filter pair? lists))) ; Throw out empty lists. 284 (cond ((null? lists) lis1) ; Short cut 285 ((memq lis1 lists) '()) ; Short cut 286 (else (filter (lambda (x) 287 (for-all (lambda (lis) (not (member x lis =))) 288 lists)) 289 lis1))))) 290 291(define (take lis k) 292 (or (integer? k) 293 (assertion-violation 'take 294 (wrong-type-argument-message "integer" k 2))) 295 (let recur ((lis lis) (k k)) 296 (if (zero? k) '() 297 (cons (car lis) 298 (recur (cdr lis) (- k 1)))))) 299 300(define (drop lis k) 301 (or (integer? k) 302 (assertion-violation 'drop 303 (wrong-type-argument-message "integer" k 2))) 304 (let iter ((lis lis) (k k)) 305 (if (zero? k) lis (iter (cdr lis) (- k 1))))) 306 307 308(define list-head take) 309 310;;;; 311;; standard libraries 312 313;; 1 Unicode 314;; 1.1 characters 315(define (make-ci-comparison = foldcase) 316 (lambda (e1 e2 . rest) 317 (let loop ((e1 (foldcase e1)) (e2 (foldcase e2)) (e* rest)) 318 (and (= e1 e2) 319 (or (null? e*) 320 (loop e2 (foldcase (car e*)) (cdr e*))))))) 321 322(define char-ci=? (make-ci-comparison char=? char-foldcase)) 323(define char-ci<? (make-ci-comparison char<? char-foldcase)) 324(define char-ci>? (make-ci-comparison char>? char-foldcase)) 325(define char-ci<=? (make-ci-comparison char<=? char-foldcase)) 326(define char-ci>=? (make-ci-comparison char>=? char-foldcase)) 327 328;; 1.2 strings 329(define string-ci=? (make-ci-comparison string=? string-foldcase)) 330(define string-ci<? (make-ci-comparison string<? string-foldcase)) 331(define string-ci>? (make-ci-comparison string>? string-foldcase)) 332(define string-ci<=? (make-ci-comparison string<=? string-foldcase)) 333(define string-ci>=? (make-ci-comparison string>=? string-foldcase)) 334 335;; 2 Bytevectors 336;; 2.4 operations on integers of arbitary size 337;; from Ypsilon 338;; we can't use macro in this file so expand by hand!! 339;;(define-syntax div256 340;; (syntax-rules () 341;; ((_ x) (bitwise-arithmetic-shift x -8)))) 342;; 343;;(define-syntax mod256 344;; (syntax-rules () 345;; ((_ x) (bitwise-and x 255)))) 346;; 347;; This moved to (rnrs bytevectors) 348;;(define-syntax endianness 349;; (syntax-rules (big little native) 350;; ((_ big) 'big) 351;; ((_ little) 'little) 352;; ((_ native) (native-endianness)))) 353 354(define (bytevector-uint-ref bv index endien size) 355 (cond ((eq? endien 'big) 356 (let ((end (+ index size))) 357 (let loop ((i index) (acc 0)) 358 (if (>= i end) 359 acc 360 (loop (+ i 1) (+ (* 256 acc) (bytevector-u8-ref bv i))))))) 361 ((eq? endien 'little) 362 (let loop ((i (+ index size -1)) (acc 0)) 363 (if (< i index) 364 acc 365 (loop (- i 1) (+ (* 256 acc) (bytevector-u8-ref bv i)))))) 366 (else 367 (assertion-violation 'bytevector-uint-ref 368 (format "expected endianness, but got ~s, as argument 3" endien) 369 (list bv index endien size))))) 370 371(define (bytevector-sint-ref bv index endien size) 372 (cond ((eq? endien 'big) 373 (if (> (bytevector-u8-ref bv index) 127) 374 (- (bytevector-uint-ref bv index endien size) (expt 256 size)) 375 (bytevector-uint-ref bv index endien size))) 376 ((eq? endien 'little) 377 (if (> (bytevector-u8-ref bv (+ index size -1)) 127) 378 (- (bytevector-uint-ref bv index endien size) (expt 256 size)) 379 (bytevector-uint-ref bv index endien size))) 380 (else 381 (assertion-violation 'bytevector-uint-ref 382 (format "expected endianness, but got ~s, as argument 3" endien) 383 (list bv index endien size))))) 384 385(define (bytevector-uint-set! bv index val endien size) 386 (cond ((= val 0) 387 (let ((end (+ index size))) 388 (let loop ((i index)) 389 (cond ((>= i end) (undefined)) 390 (else 391 (bytevector-u8-set! bv i 0) 392 (loop (+ i 1))))))) 393 ((< 0 val (expt 256 size)) 394 (cond ((eq? endien 'big) 395 (let ((start (- (+ index size) 1))) 396 (let loop ((i start) (acc val)) 397 (cond ((< i index) (undefined)) 398 (else 399 ;; mod256 -> bitwise-and 400 (bytevector-u8-set! bv i (bitwise-and acc 255)) 401 ;; div256 -> bitwise-arithmetic-shift 402 (loop (- i 1) (bitwise-arithmetic-shift acc -8))))))) 403 ((eq? endien 'little) 404 (let ((end (+ index size))) 405 (let loop ((i index) (acc val)) 406 (cond ((>= i end) (undefined)) 407 (else 408 ;; mod256 -> bitwise-and 409 (bytevector-u8-set! bv i (bitwise-and acc 255)) 410 ;; div256 -> bitwise-arithmetic-shift 411 (loop (+ i 1) (bitwise-arithmetic-shift acc -8))))))))) 412 (else 413 (assertion-violation 'bytevector-uint-set! 414 (format "value out of range, ~s as argument 3" val) 415 (list bv index val endien size)))) 416 (undefined)) 417 418(define (bytevector-sint-set! bv index val endien size) 419 (let* ((p-bound (expt 2 (- (* size 8) 1))) 420 (n-bound (- (+ p-bound 1)))) 421 (if (< n-bound val p-bound) 422 (if (>= val 0) 423 (bytevector-uint-set! bv index val endien size) 424 (bytevector-uint-set! bv index (+ val (expt 256 size)) endien size)) 425 (assertion-violation 'bytevector-sint-set! 426 (format "value out of range, ~s as argument 3" val) 427 (list bv index val endien size)))) 428 (undefined)) 429 430(define (bytevector->uint-list bv endien size) 431 (let loop ((i (- (bytevector-length bv) size)) (acc '())) 432 (if (> i -1) 433 (loop (- i size) (cons (bytevector-uint-ref bv i endien size) acc)) 434 (if (= i (- size)) 435 acc 436 (assertion-violation 'bytevector->uint-list 437 (format "expected appropriate element size as argument 3, but got ~s" size) 438 (list bv endien size)))))) 439 440(define (bytevector->sint-list bv endien size) 441 (let loop ((i (- (bytevector-length bv) size)) (acc '())) 442 (if (> i -1) 443 (loop (- i size) (cons (bytevector-sint-ref bv i endien size) acc)) 444 (if (= i (- size)) 445 acc 446 (assertion-violation 'bytevector->sint-list 447 (format "expected appropriate element size as argument 3, but got ~s" size) 448 (list bv endien size)))))) 449 450(define (uint-list->bytevector lst endien size) 451 (let ((bv (make-bytevector (* size (length lst))))) 452 (let loop ((i 0) (lst lst)) 453 (cond ((null? lst) bv) 454 (else 455 (bytevector-uint-set! bv i (car lst) endien size) 456 (loop (+ i size) (cdr lst))))))) 457 458(define (sint-list->bytevector lst endien size) 459 (let ((bv (make-bytevector (* size (length lst))))) 460 (let loop ((i 0) (lst lst)) 461 (cond ((null? lst) bv) 462 (else 463 (bytevector-sint-set! bv i (car lst) endien size) 464 (loop (+ i size) (cdr lst))))))) 465 466;; 3 list utilities 467 468(define (for-all pred lst1 . lst2) 469 (define (for-all-n pred list-of-lists) 470 (let ((argc (length list-of-lists))) 471 (define (collect-cdr lst) 472 (let loop ((lst lst)) 473 (cond ((null? lst) '()) 474 ((null? (cdar lst)) (loop (cdr lst))) 475 (else (cons (cdar lst) (loop (cdr lst))))))) 476 (define (collect-car lst) 477 (let loop ((lst lst)) 478 (cond ((null? lst) '()) 479 ((pair? (car lst)) 480 (cons (caar lst) (loop (cdr lst)))) 481 (else 482 (assertion-violation 'for-all (format "traversal reached to non-pair element ~s" (car lst)) list-of-lists))))) 483 484 (let loop ((head (collect-car list-of-lists)) (rest (collect-cdr list-of-lists))) 485 (or (= (length head) argc) 486 (assertion-violation 'for-all "expected same length chains of pairs" list-of-lists)) 487 (if (null? rest) 488 (apply pred head) 489 (and (apply pred head) 490 (loop (collect-car rest) (collect-cdr rest))))))) 491 492 (define (for-all-n-quick pred lst) 493 (or (null? lst) 494 (let loop ((head (car lst)) (rest (cdr lst))) 495 (if (null? rest) 496 (apply pred head) 497 (and (apply pred head) 498 (loop (car rest) (cdr rest))))))) 499 500 (define (for-all-1 pred lst) 501 (cond ((null? lst) #t) 502 ((pair? lst) 503 (let loop ((head (car lst)) (rest (cdr lst))) 504 (cond ((null? rest) (pred head)) 505 ((pair? rest) 506 (and (pred head) 507 (loop (car rest) (cdr rest)))) 508 (else 509 (and (pred head) 510 (assertion-violation 'for-all (format "traversal reached to non-pair element ~s" rest) (list pred lst))))))) 511 (else 512 (assertion-violation 'for-all (format "expected chain of pairs, but got ~a, as argument 2" lst) (list pred lst))))) 513 514 (cond ((null? lst2) 515 (for-all-1 pred lst1)) 516 ((apply list-transpose+ lst1 lst2) 517 => (lambda (lst) (for-all-n-quick pred lst))) 518 (else 519 (for-all-n pred (cons lst1 lst2))))) 520 521(define (exists pred lst1 . lst2) 522 (define (exists-1 pred lst) 523 (cond ((null? lst) #f) 524 ((pair? lst) 525 (let loop ((head (car lst)) (rest (cdr lst))) 526 (cond ((null? rest) (pred head)) 527 ((pred head)) 528 ((pair? rest) (loop (car rest) (cdr rest))) 529 (else 530 (assertion-violation 'exists (format "traversal reached to non-pair element ~s" rest) (list pred lst)))))) 531 (else 532 (assertion-violation 'exists (format "expected chain of pairs, but got ~a, as argument 2" lst) (list pred lst))))) 533 (define (exists-n-quick pred lst) 534 (and (pair? lst) 535 (let loop ((head (car lst)) (rest (cdr lst))) 536 (if (null? rest) 537 (apply pred head) 538 (or (apply pred head) 539 (loop (car rest) (cdr rest))))))) 540 (define (exists-n pred list-of-lists) 541 (let ((argc (length list-of-lists))) 542 (define (collect-cdr lst) 543 (let loop ((lst lst)) 544 (cond ((null? lst) '()) 545 ((null? (cdar lst)) (loop (cdr lst))) 546 (else (cons (cdar lst) (loop (cdr lst))))))) 547 (define (collect-car lst) 548 (let loop ((lst lst)) 549 (cond ((null? lst) '()) 550 ((pair? (car lst)) 551 (cons (caar lst) (loop (cdr lst)))) 552 (else 553 (assertion-violation 'exists (format "traversal reached to non-pair element ~s" (car lst)) list-of-lists))))) 554 555 (let loop ((head (collect-car list-of-lists)) (rest (collect-cdr list-of-lists))) 556 (or (= (length head) argc) 557 (assertion-violation 'exists "expected same length chains of pairs" list-of-lists)) 558 (if (null? rest) 559 (apply pred head) 560 (or (apply pred head) 561 (loop (collect-car rest) (collect-cdr rest))))))) 562 (cond ((null? lst2) 563 (exists-1 pred lst1)) 564 ((apply list-transpose+ lst1 lst2) 565 => (lambda (lst) (exists-n-quick pred lst))) 566 (else 567 (exists-n pred (cons lst1 lst2))))) 568 569(define (filter pred lst) 570 (let loop ((lst lst) (acc '())) 571 (cond ((null? lst) (reverse! acc)) 572 ((pred (car lst)) (loop (cdr lst) (cons (car lst) acc))) 573 (else (loop (cdr lst) acc))))) 574 575;; from SRFI-1, reference implementation 576(define (filter! pred lis) 577 (let lp ((ans lis)) 578 (cond ((null? ans) ans) ; Scan looking for 579 ((not (pred (car ans))) (lp (cdr ans))) ; first cons of result. 580 581 ;; ANS is the eventual answer. 582 ;; SCAN-IN: (CDR PREV) = LIS and (CAR PREV) satisfies PRED. 583 ;; Scan over a contiguous segment of the list that 584 ;; satisfies PRED. 585 ;; SCAN-OUT: (CAR PREV) satisfies PRED. Scan over a contiguous 586 ;; segment of the list that *doesn't* satisfy PRED. 587 ;; When the segment ends, patch in a link from PREV 588 ;; to the start of the next good segment, and jump to 589 ;; SCAN-IN. 590 (else (letrec ((scan-in (lambda (prev lis) 591 (if (pair? lis) 592 (if (pred (car lis)) 593 (scan-in lis (cdr lis)) 594 (scan-out prev (cdr lis)))))) 595 (scan-out (lambda (prev lis) 596 (let lp ((lis lis)) 597 (if (pair? lis) 598 (if (pred (car lis)) 599 (begin (set-cdr! prev lis) 600 (scan-in lis (cdr lis))) 601 (lp (cdr lis))) 602 (set-cdr! prev lis)))))) 603 (scan-in ans (cdr ans)) 604 ans))))) 605 606(define (partition pred lst) 607 (let loop ((lst lst) (acc1 '()) (acc2 '())) 608 (cond ((null? lst) (values (reverse! acc1) (reverse! acc2))) 609 ((pred (car lst)) (loop (cdr lst) (cons (car lst) acc1) acc2)) 610 (else (loop (cdr lst) acc1 (cons (car lst) acc2)))))) 611 612(define (map proc lst1 . lst2) 613 (if (null? lst2) 614 (let loop ((xs lst1) (r '())) 615 (cond ((pair? xs) (loop (cdr xs) (cons (proc (car xs)) r))) 616 ((null? xs) (reverse! r)) 617 (else 618 (assertion-violation 'map 619 (wrong-type-argument-message "proper list" lst1 2) 620 (list proc lst1 lst2))))) 621 (let loop ((xs (apply list-transpose* lst1 lst2)) (r '())) 622 (cond ((pair? xs) (loop (cdr xs) (cons (apply proc (car xs)) r))) 623 ((null? xs) (reverse! r)) 624 (else 625 (assertion-violation 'map 626 (wrong-type-argument-message "proper list" lst1 2) 627 (list proc lst1 lst2))))))) 628 629(define (for-each proc lst1 . lst2) 630 (if (null? lst2) 631 (let loop ((xs lst1)) 632 (cond ((pair? xs) (proc (car xs)) (loop (cdr xs))) 633 ((null? xs) (undefined)) 634 (else 635 (assertion-violation 'for-each 636 (wrong-type-argument-message "proper list" lst1 2) 637 (list proc lst1 lst2))))) 638 (let loop ((xs (apply list-transpose* lst1 lst2))) 639 (cond ((pair? xs) (apply proc (car xs)) (loop (cdr xs))) 640 ((null? xs) (undefined)) 641 (else 642 (assertion-violation 'for-each 643 (wrong-type-argument-message "proper list" lst1 2) 644 (list proc lst1 lst2))))))) 645 646;; it's used very often in the boot code so put it here 647(define (filter-map proc lst1 . lst2) 648 (unless (procedure? proc) 649 (assertion-violation 'filter-map 650 (wrong-type-argument-message "procedure" proc 1) (list proc lst1 lst2))) 651 (if (null? lst2) 652 (let loop ((lst lst1) (r '())) 653 (cond ((null? lst) (reverse! r)) 654 ((pair? lst) 655 (cond ((proc (car lst)) => 656 (lambda (x) (loop (cdr lst) (cons x r)))) 657 (else (loop (cdr lst) r)))) 658 (else 659 (assertion-violation 'filter-map 660 (wrong-type-argument-message "proper list" lst1 2) 661 (list proc lst1 lst2))))) 662 (let loop ((xs (apply list-transpose* lst1 lst2)) (r '())) 663 (cond ((null? xs) (reverse! r)) 664 ((pair? xs) 665 (cond ((apply proc (car xs)) => 666 (lambda (x) (loop (cdr xs) (cons x r)))) 667 (else (loop (cdr xs) r)))) 668 (else 669 (assertion-violation 'map 670 (wrong-type-argument-message "proper list" lst1 2) 671 (list proc lst1 lst2))))))) 672 673 674(define (fold-left proc seed lst1 . lst2) 675 (if (null? lst2) 676 (let loop ((lis lst1) (knil seed)) 677 (if (null? lis) knil (loop (cdr lis) (proc knil (car lis))))) 678 (let loop ((lis (apply list-transpose* lst1 lst2)) (knil seed)) 679 (if (null? lis) 680 knil 681 (loop (cdr lis) (apply proc knil (car lis))))))) 682 683;; tail recursive version 684(define (fold-right proc seed lst1 . lst2) 685 (if (null? lst2) 686 (let loop ((lis (reverse lst1)) 687 (result seed)) 688 (if (null? lis) 689 result 690 (loop (cdr lis) 691 (proc (car lis) result)))) 692 (let loop ((lis (reverse! (apply list-transpose* lst1 lst2))) (knil seed)) 693 (if (null? lis) 694 knil 695 (loop (cdr lis) 696 (apply proc (append! (car lis) (list knil)))))))) 697 698;;(define (fold-right proc seed lst1 . lst2) 699;; (if (null? lst2) 700;; (let loop ((lis lst1)) 701;; (if (null-list? lis) 702;; seed 703;; (proc (car lis) (loop (cdr lis))))) 704;; (let loop ((lis (apply list-transpose* lst1 lst2)) (knil seed)) 705;; (if (null-list? lis) 706;; knil 707;; (apply proc (append! (car lis) (list (loop (cdr lis) knil)))))))) 708 709(define (remp pred lst) 710 (let loop ((lst lst) (r '())) 711 (cond ((null? lst) (reverse! r)) 712 ((pred (car lst)) (loop (cdr lst) r)) 713 (else (loop (cdr lst) (cons (car lst) r)))))) 714 715(define (remove obj lst) 716 (let loop ((lst lst) (r '())) 717 (cond ((null? lst) (reverse! r)) 718 ((equal? (car lst) obj) (loop (cdr lst) r)) 719 (else (loop (cdr lst) (cons (car lst) r)))))) 720 721(define (remv obj lst) 722 (let loop ((lst lst) (r '())) 723 (cond ((null? lst) (reverse! r)) 724 ((eqv? (car lst) obj) (loop (cdr lst) r)) 725 (else (loop (cdr lst) (cons (car lst) r)))))) 726 727(define (remq obj lst) 728 (let loop ((lst lst) (r '())) 729 (cond ((null? lst) (reverse! r)) 730 ((eq? (car lst) obj) (loop (cdr lst) r)) 731 (else (loop (cdr lst) (cons (car lst) r)))))) 732 733(define (memp proc lst) 734 (cond ((null? lst) #f) 735 ((proc (car lst)) lst) 736 (else (memp proc (cdr lst))))) 737 738(define (assp proc lst) 739 (cond ((null? lst) #f) 740 ((proc (caar lst)) (car lst)) 741 (else (assp proc (cdr lst))))) 742 743;;;; 744;; 4 Sorting 745;; The algorithm is from SBCL 746(define (list-sort proc lst) 747 (define (merge-list! proc head lst1 lst2 tail) 748 (let loop () 749 (cond ((proc (car lst2) (car lst1)) 750 ;; we can't use macro so duplicate it! 751 (set-cdr! tail lst2) 752 (set! tail lst2) 753 (let ((rest (cdr lst2))) 754 (cond ((null? rest) 755 (set-cdr! lst2 lst1) 756 (cdr head)) 757 (else 758 (set! lst2 rest) 759 (loop))))) 760 (else 761 (set-cdr! tail lst1) 762 (set! tail lst1) 763 (let ((rest (cdr lst1))) 764 (cond ((null? rest) 765 (set-cdr! lst1 lst2) 766 (cdr head)) 767 (else 768 (set! lst1 rest) 769 (loop)))))))) 770 (define (fast-merge-list! proc try? head lst1 tail1 lst2 tail2 rest) 771 (if try? 772 (cond ((not (proc (car lst2) (car tail1))) 773 (set-cdr! tail1 lst2) 774 (values lst1 tail2 rest)) 775 ((proc (car tail2) (car lst1)) 776 (set-cdr! tail2 lst1) 777 (values lst2 tail1 rest)) 778 (else 779 (values (merge-list! proc head lst1 lst2 head) 780 (if (null? (cdr tail1)) 781 tail1 782 tail2) 783 rest))) 784 (values (merge-list! proc head lst1 lst2 head) 785 (if (null? (cdr tail1)) 786 tail1 787 tail2) 788 rest))) 789 (define (do-sort lst size head) 790 (define (recur lst size) 791 (cond ((= size 1) 792 (let ((h (list (car lst)))) 793 (values h h (cdr lst)))) 794 ((= size 2) 795 (let* ((a (car lst)) 796 (ad (cadr lst)) 797 (h (if (proc ad a) 798 (list ad a) 799 (list a ad)))) 800 (values h (cdr h) (cddr lst)))) 801 (else 802 (let ((half (div size 2))) 803 (receive (lst1 tail1 rest) (recur lst half) 804 (receive (lst2 tail2 rest) (recur rest (- size half)) 805 (fast-merge-list! proc (>= size 8) head 806 lst1 tail1 807 lst2 tail2 808 rest))))))) 809 (receive (lst tail size) (recur lst size) 810 lst)) 811 (define (divide lst) 812 (let loop ((acc 1) (lst lst)) 813 (cond ((null? (cdr lst)) (values acc '())) 814 (else 815 (if (proc (car lst) (cadr lst)) 816 (loop (+ acc 1) (cdr lst)) 817 (values acc (cdr lst))))))) 818 (unless (procedure? proc) 819 (assertion-violation 'list-sort 820 (wrong-type-argument-message "procedure" proc 1))) 821 (if (null? lst) 822 lst 823 (receive (n lst2) (divide lst) 824 (if (null? lst2) 825 lst 826 (let* ((head (cons '() '())) 827 (r (do-sort lst2 (length lst2) head))) 828 (merge-list! proc head (list-head lst n) r head)))))) 829 830(define (vector-sort proc vect :optional (start 0) (maybe-end #f)) 831 (define len (vector-length vect)) 832 (define end (or maybe-end len)) 833 ;; TODO should we expose this? 834 (define (vector-copy! src src-from dst dst-from size) 835 (if (<= dst-from src-from) 836 (do ((i 0 (+ i 1)) (s src-from (+ s 1)) (d dst-from (+ d 1))) 837 ((= i size) dst) 838 (vector-set! dst d (vector-ref src s))) 839 (do ((i 0 (+ i 1)) 840 (s (+ src-from size) (- s 1)) 841 (d (+ dst-from size) (- d 1))) 842 ((= i size) dst) 843 (vector-set! dst d (vector-ref src s))))) 844 845 (when (or (negative? start) (negative? end)) 846 (assertion-violation 'vector-sort! "start and end must be positive" start 847 vect)) 848 (when (or (> start len) (> end len)) 849 (assertion-violation 'vector-sort! "out of range" 850 (list (list start end) len) 851 vect)) 852 (when (> start end) 853 (assertion-violation 'vector-sort! "start is greater than end" 854 (list start end) 855 vect)) 856 857 (let* ((lst (vector->list vect start end)) 858 (lst2 (list-sort proc lst))) 859 (cond ((eq? lst lst2) vect) 860 ((= (- end start) len) 861 (list->vector lst2)) 862 (else 863 (let ((v (make-vector len))) 864 (vector-copy! vect 0 v 0 start) 865 (do ((i start (+ i 1)) (l lst2 (cdr l))) 866 ((null? l)) 867 (vector-set! v i (car l))) 868 (vector-copy! vect end v end (- len end))))))) 869 870(define (vector-sort! proc vect :optional (start 0) (maybe-end #f)) 871 (define len (vector-length vect)) 872 (define end (or maybe-end len)) 873 874 (when (or (negative? start) (negative? end)) 875 (assertion-violation 'vector-sort! "start and end must be positive" start 876 vect)) 877 (when (or (> start len) (> end len)) 878 (assertion-violation 'vector-sort! "out of range" 879 (list (list start end) len) 880 vect)) 881 (when (> start end) 882 (assertion-violation 'vector-sort! "start is greater than end" 883 (list start end) 884 vect)) 885 886 (let* ((n (- end start)) 887 (work (make-vector (+ (div n 2) 1)))) 888 889 (define (simple-sort! first last) 890 (let loop1 ((i first)) 891 (cond ((< i last) 892 (let ((m (vector-ref vect i)) (k i)) 893 (let loop2 ((j (+ i 1))) 894 (cond ((<= j last) 895 (if (proc (vector-ref vect j) m) 896 (begin 897 (set! m (vector-ref vect j)) 898 (set! k j))) 899 (loop2 (+ j 1))) 900 (else 901 (vector-set! vect k (vector-ref vect i)) 902 (vector-set! vect i m) 903 (loop1 (+ i 1)))))))))) 904 905 (define (sort! first last) 906 (cond ((> (- last first) 10) 907 (let ((middle (div (+ first last) 2))) 908 (sort! first middle) 909 (sort! (+ middle 1) last) 910 (let loop ((i first) (p2size 0)) 911 (cond ((> i middle) 912 (let loop ((p1 (+ middle 1)) (p2 0) (p3 first)) 913 (cond ((and (<= p1 last) (< p2 p2size)) 914 (cond ((proc (vector-ref work p2) (vector-ref vect p1)) 915 (vector-set! vect p3 (vector-ref work p2)) 916 (loop p1 (+ p2 1) (+ p3 1))) 917 (else 918 (vector-set! vect p3 (vector-ref vect p1)) 919 (loop (+ p1 1) p2 (+ p3 1))))) 920 (else 921 (let loop ((s2 p2)(d3 p3)) 922 (cond ((< s2 p2size) 923 (vector-set! vect d3 (vector-ref work s2)) 924 (loop (+ s2 1) (+ d3 1))))))))) 925 (else 926 (vector-set! work p2size (vector-ref vect i)) 927 (loop (+ i 1) (+ p2size 1))))))) 928 (else 929 (simple-sort! first last)))) 930 ;; the end is exclusive 931 (sort! start (- end 1)))) 932 933;;;; 934;; 8 I/O 935;; 8.2.6 input port and output port 936;; from Ypsilon 937(define (call-with-port port proc) 938 (receive args (proc port) 939 (close-port port) 940 (apply values args))) 941 942 943;; 8.2.10 output port 944(define (open-bytevector-output-port . maybe-transcoder) 945 (when (> (length maybe-transcoder) 1) 946 (assertion-violation 947 'open-bytevector-output-port 948 (format 949 "wrong number of argument: expected between 0 and 1, but got ~a" 950 (length maybe-transcoder)) 951 maybe-transcoder)) 952 (let ((transcoder (if (null? maybe-transcoder) 953 #f 954 (car maybe-transcoder)))) 955 (let* ((port (open-output-bytevector transcoder)) 956 (proc (lambda () (extract-output-bytevector port)))) 957 (values port proc)))) 958 959(define (open-string-output-port) 960 (let* ((port (open-output-string)) 961 (proc (lambda () (extract-output-string port)))) 962 (values port proc))) 963 964(define (call-with-bytevector-output-port proc . maybe-transcoder) 965 (receive (port extractor) (apply open-bytevector-output-port maybe-transcoder) 966 (proc port) (extractor))) 967 968(define (call-with-string-output-port proc) 969 (receive (port extractor) (open-string-output-port) 970 (proc port) (extractor))) 971 972;;;;; 973;; 13 hashtable 974;; 13.3 inspection 975(define (hashtable-equivalence-function ht) 976 (or (hashtable? ht) 977 (assertion-violation 'hashtable-equivalence-function 978 (wrong-type-argument-message "hashtable" ht))) 979 (case (hashtable-type ht) 980 ((eq) eq?) 981 ((eqv) eqv?) 982 ((equal) equal?) 983 ((string) string=?) 984 ((general) (hashtable-compare ht)))) 985 986(define (hashtable-hash-function ht) 987 (or (hashtable? ht) 988 (assertion-violation 'hashtable-hash-function 989 (wrong-type-argument-message "hashtable" ht))) 990 (case (hashtable-type ht) 991 ((eq) #f) 992 ((eqv) #f) 993 ((equal) equal-hash) 994 ((string) string-hash) 995 ((general) (hashtable-hasher ht)))) 996 997;;;; end of file 998;; Local Variables: 999;; coding: utf-8-unix 1000;; End: 1001