diff options
Diffstat (limited to 'srfi-1.scm')
| -rw-r--r-- | srfi-1.scm | 230 |
1 files changed, 218 insertions, 12 deletions
@@ -1,5 +1,6 @@ ;;; "srfi-1.scm" SRFI-1 list-processing library -*-scheme-*- -; Copyright 2001 Aubrey Jaffer +;; Copyright 2001 Aubrey Jaffer +;; Copyright 2003 Sven Hartrumpf ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is @@ -8,7 +9,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -48,7 +49,10 @@ ((< i 0) ans))) ;;@args obj1 obj2 -(define cons* comlist:list*) +(define cons* list*) + +;;@args flist +(define list-copy copy-list) ;;@args count start step ;;@args count start @@ -112,9 +116,13 @@ ;;@args pair (define first car) +;;@args pair (define second cadr) +;;@args pair (define third caddr) +;;@args pair (define fourth cadddr) +;;@args pair (define (fifth obj) (car (cddddr obj))) (define (sixth obj) (cadr (cddddr obj))) (define (seventh obj) (caddr (cddddr obj))) @@ -126,17 +134,21 @@ (define (car+cdr pair) (values (car pair) (cdr pair))) ;;@body -(define (take lst k) (comlist:butnthcdr k lst)) +(define (drop lst k) (nthcdr k lst)) +(define (take lst k) (butnthcdr k lst)) +;;@args lst k (define take! take) -(define (drop lst k) (comlist:nthcdr k lst)) ;;@args lst k -(define take-right comlist:butlast) -(define drop-right comlist:last) +(define take-right last) +;;@args lst k +(define drop-right butlast) +;;@args lst k (define drop-right! drop-right) -;;@body +;;@args lst k (define (split-at lst k) (values (take lst k) (drop lst k))) +;;@args lst k (define split-at! split-at) ;;@args lst @@ -144,7 +156,7 @@ (define (last lst . k) (if (null? k) (car (last-pair lst)) - (apply comlist:last lst k))) + (apply take-right lst k))) ;;@subheading Miscellaneous @@ -159,7 +171,7 @@ ;;Reverse is provided by R4RS. ;;@args lst -(define reverse! comlist:nreverse) +(define reverse! nreverse) ;;@body (define (append-reverse rev-head tail) @@ -202,16 +214,159 @@ ;;@subheading Fold and Unfold + +;;; We stop when LIS1 runs out, not when any list runs out. +;;@args f list1 clist2 ... +(define (map! f lis1 . lists) + (if (pair? lists) + (let lp ((lis1 lis1) (lists lists)) + (if (not (null-list? lis1)) + (call-with-values ; expanded a receive call + (lambda () (%cars+cdrs/no-test lists)) + (lambda (heads tails) + (set-car! lis1 (apply f (car lis1) heads)) + (lp (cdr lis1) tails))))) + + ;; Fast path. + (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1)) + lis1) + +;;@args f clist1 clist2 ... +(define (pair-for-each proc lis1 . lists) + (if (pair? lists) + (let lp ((lists (cons lis1 lists))) + (let ((tails (%cdrs lists))) + (if (pair? tails) + (begin (apply proc lists) + (lp tails))))) + ;; Fast path. + (let lp ((lis lis1)) + (if (not (null-list? lis)) + (let ((tail (cdr lis))) ; Grab the cdr now, + (proc lis) ; in case PROC SET-CDR!s LIS. + (lp tail)))))) + + ;;@subheading Filtering and Partitioning +;;@body +(define (filter pred lis) ; Sleazing with EQ? makes this one faster. + (let recur ((lis lis)) + (if (null-list? lis) lis ; Use NOT-PAIR? to handle dotted lists. + (let ((head (car lis)) + (tail (cdr lis))) + (if (pred head) + (let ((new-tail (recur tail))) ; Replicate the RECUR call so + (if (eq? tail new-tail) lis + (cons head new-tail))) + (recur tail)))))) ; this one can be a tail call. +;;@body +(define (filter! pred l) + (if (null? l) + l + (let ((l2 l) + (l3 (cdr l))) + (do ((end #f) + (result '())) + (end result) + (cond ((pred (car l2)) ; keep the first element of l2 + (cond ((null? result) + (set! result l2))) ; first pair of remaining elements + (cond ((pair? l3) + (set! l2 l3) + (set! l3 (cdr l2))) + (else + (set! end #t)))) + (else ; remove the first element of l2 + (cond ((pair? l3) + (set-car! l2 (car l3)) + (set! l3 (cdr l3)) + (set-cdr! l2 l3)) + (else + (cond ((pair? result) + (list-remove-last! result))) + (set! end #t))))))))) + +;;@args pred list +(define (partition pred lis) + (let recur ((lis lis)) + (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle dotted lists. + (let ((elt (car lis)) + (tail (cdr lis))) + (call-with-values ; expanded a receive call + (lambda () (recur tail)) + (lambda (in out) + (if (pred elt) + (values (if (pair? out) (cons elt in) lis) out) + (values in (if (pair? in) (cons elt out) lis))))))))) + ;;@subheading Searching ;;@args pred list -(define find comlist:find-if) +(define find find-if) ;;@args pred list -(define find-tail comlist:member-if) +(define find-tail member-if) +;;@body +(define remove + (let ((comlist:remove remove)) + (lambda (pred l) + (if (procedure? pred) + (filter (lambda (x) (not (pred x))) l) + (comlist:remove pred l))))) ; 'remove' has incompatible semantics in comlist of SLIB! +;;@body +(define (remove! pred l) (filter! (lambda (x) (not (pred x))) l)) + +;;@args pred clist1 clist2 ... +(define (any pred lis1 . lists) + (if (pair? lists) + ;; N-ary case + (call-with-values ; expanded a receive call + (lambda () (%cars+cdrs (cons lis1 lists))) + (lambda (heads tails) + (and (pair? heads) + (let lp ((heads heads) (tails tails)) + (call-with-values ; expanded a receive call + (lambda () (%cars+cdrs tails)) + (lambda (next-heads next-tails) + (if (pair? next-heads) + (or (apply pred heads) (lp next-heads next-tails)) + (apply pred heads)))))))) ; Last PRED app is tail call. + ;; Fast path + (and (not (null-list? lis1)) + (let lp ((head (car lis1)) (tail (cdr lis1))) + (if (null-list? tail) + (pred head) ; Last PRED app is tail call. + (or (pred head) (lp (car tail) (cdr tail)))))))) + +;;@args pred clist1 clist2 ... +(define (list-index pred lis1 . lists) + (if (pair? lists) + ;; N-ary case + (let lp ((lists (cons lis1 lists)) (n 0)) + (call-with-values ; expanded a receive call + (lambda () (%cars+cdrs lists)) + (lambda (heads tails) + (and (pair? heads) + (if (apply pred heads) n + (lp tails (+ n 1))))))) + ;; Fast path + (let lp ((lis lis1) (n 0)) + (and (not (null-list? lis)) + (if (pred (car lis)) n (lp (cdr lis) (+ n 1))))))) + +;;@args pred list +(define (span pred lis) + (let recur ((lis lis)) + (if (null-list? lis) (values '() '()) + (let ((x (car lis))) + (if (pred x) + (call-with-values ; eliminated a receive call + (lambda () (recur (cdr lis))) + (lambda (prefix suffix) + (values (cons x prefix) suffix))) + (values '() lis)))))) ;;@args obj list pred ;;@args obj list @@ -251,3 +406,54 @@ (find (lambda (pair) (pred obj (car pair))) alist)))))) ;;@subheading Set operations + + +;;;; helper functions from the reference implementation: + +;;; LISTS is a (not very long) non-empty list of lists. +;;; Return two lists: the cars & the cdrs of the lists. +;;; However, if any of the lists is empty, just abort and return [() ()]. + +(define (%cars+cdrs lists) + (call-with-current-continuation + (lambda (abort) + (let recur ((lists lists)) + (if (pair? lists) + (call-with-values ; expanded a receive call + (lambda () (car+cdr lists)) + (lambda (list other-lists) + (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out + (call-with-values ; expanded a receive call + (lambda () (car+cdr list)) + (lambda (a d) + (call-with-values ; expanded a receive call + (lambda () (recur other-lists)) + (lambda (cars cdrs) + (values (cons a cars) (cons d cdrs))))))))) + (values '() '())))))) + +;;; Like %CARS+CDRS, but blow up if any list is empty. +(define (%cars+cdrs/no-test lists) + (let recur ((lists lists)) + (if (pair? lists) + (call-with-values ; expanded a receive call + (lambda () (car+cdr lists)) + (lambda (list other-lists) + (call-with-values ; expanded a receive call + (lambda () (car+cdr list)) + (lambda (a d) + (call-with-values ; expanded a receive call + (lambda () (recur other-lists)) + (lambda (cars cdrs) + (values (cons a cars) (cons d cdrs)))))))) + (values '() '())))) + +(define (%cdrs lists) + (call-with-current-continuation + (lambda (abort) + (let recur ((lists lists)) + (if (pair? lists) + (let ((lis (car lists))) + (if (null-list? lis) (abort '()) + (cons (cdr lis) (recur (cdr lists))))) + '()))))) |