suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

* Implemented drop' instead of a synonym for list-tail' (so error

Browse Source 
messages are better; speed should be comparable)
* added `take-right' and `drop-right' to scheme/list, with tests and
  documentation
* also, minor documentation bug (wrong result type for `drop' can
  return `any/c')
* drop the implementation of them from srfi/1, reprovide the
  scheme/list versions

svn: r10555
This commit is contained in:
Eli Barzilay 2008-07-02 10:04:57 +00:00
parent f787d68b71
commit 1002366103
3 changed files with 92 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
collects/scheme/list.ss
View File

@ -10,6 +10,8 @@
drop
take
drop-right
take-right
append*
flatten
@ -73,20 +75,51 @@
(define empty? (lambda (l) (null? l)))
(define empty '())
(define drop list-tail)
;; internal use below
(define (drop* list n) ; no error checking, returns #f if index is too large
(if (zero? n) list (and (pair? list) (drop* (cdr list) (sub1 n)))))
(define (too-large who list n)
(raise-mismatch-error
who
(format "index ~e too large for list~a: ~e"
n (if (list? list) "" " (not a proper list)") list)
n))
(define (take list0 n0)
(unless (and (integer? n0) (exact? n0))
(raise-type-error 'take "non-negative integer" n0))
(unless (exact-nonnegative-integer? n0)
(raise-type-error 'take "non-negative exact integer" n0))
(let loop ([list list0] [n n0])
(cond [(zero? n) '()]
[(pair? list) (cons (car list) (loop (cdr list) (sub1 n)))]
[else (raise-mismatch-error
'take
(format "index ~e too large for list~a: ~e"
n0
(if (list? list) "" " (not a proper list)")
list0)
n0)])))
[else (too-large 'take list0 n0)])))
(define (drop list n)
;; could be defined as `list-tail', but this is better for errors anyway
(unless (exact-nonnegative-integer? n)
(raise-type-error 'drop "non-negative exact integer" n))
(or (drop* list n) (too-large 'drop list n)))
;; take/drop-right are originally from srfi-1, uses the same lead-pointer trick
(define (take-right list n)
(unless (exact-nonnegative-integer? n)
(raise-type-error 'take-right "non-negative exact integer" n))
(let loop ([lag list]
[lead (or (drop* list n) (too-large 'take-right list n))])
;; could throw an error for non-lists, but be more like `take'
(if (pair? lead)
(loop (cdr lag) (cdr lead))
lag)))
(define (drop-right list n)
(unless (exact-nonnegative-integer? n)
(raise-type-error 'drop-right "non-negative exact integer" n))
(let loop ([lag list]
[lead (or (drop* list n) (too-large 'drop-right list n))])
;; could throw an error for non-lists, but be more like `drop'
(if (pair? lead)
(cons (car lag) (loop (cdr lag) (cdr lead)))
'())))
(define append*
(case-lambda [(ls) (apply append ls)] ; optimize common case
@ -194,7 +227,7 @@
;; (values (if (pair? out) (cons x in) l) out)
;; (values in (if (pair? in) (cons x out) l))))))))
;; But that one is slower than this, probably due to value packages
;; But that one is slower than this, probably due to value packaging
(define (partition pred l)
(unless (and (procedure? pred) (procedure-arity-includes? pred 1))
(raise-type-error 'partition "procedure (arity 1)" pred))

33
collects/scribblings/reference/pairs.scrbl
View File

@ -516,10 +516,6 @@ Like @scheme[assoc], but finds an element using the predicate
@defproc[(last-pair [p pair?]) pair?]{
Returns the last pair of a (possibly improper) list.}
@defproc[(drop [lst any/c] [pos nonnegative-exact-integer?]) list?]{
Synonym for @scheme[list-tail].
}
@defproc[(take [lst any/c] [pos nonnegative-exact-integer?]) list?]{
Returns a fresh list whose elements are the first @scheme[pos] elements of
@scheme[lst]. If @scheme[lst] has fewer than
@ -533,6 +529,35 @@ must merely start with a chain of at least @scheme[pos] pairs.
(take 'non-list 0)
]}
@defproc[(drop [lst any/c] [pos nonnegative-exact-integer?]) any/c]{
Just like @scheme[list-tail].}
@defproc[(take-right [lst any/c] [pos nonnegative-exact-integer?]) any/c]{
Returns the @scheme[list]'s @scheme[pos]-length tail. If @scheme[lst]
has fewer than @scheme[pos] elements, then the
@exnraise[exn:fail:contract].
The @scheme[lst] argument need not actually be a list; @scheme[lst]
must merely end with a chain of at least @scheme[pos] pairs.
@examples[#:eval list-eval
(take-right '(1 2 3 4) 2)
(take-right 'non-list 0)
]}
@defproc[(drop-right [lst any/c] [pos nonnegative-exact-integer?]) list?]{
Returns a fresh list whose elements are the prefix of @scheme[lst],
dropping its @scheme[pos]-length tail. If @scheme[lst] has fewer than
@scheme[pos] elements, then the @exnraise[exn:fail:contract].
The @scheme[lst] argument need not actually be a list; @scheme[lst]
must merely end with a chain of at least @scheme[pos] pairs.
@examples[#:eval list-eval
(drop-right '(1 2 3 4) 2)
(drop-right 'non-list 0)
]}
@defproc[(add-between [lst list?] [v any/c]) list?]{
Returns a list with the same elements as @scheme[lst], but with

44
collects/tests/mzscheme/list.ss
View File

@ -145,33 +145,27 @@
(test '(1 2 3 4) sort '(4 2 3 1) < #:key getkey #:cache-keys? #t)
(test #t = c 10)))
;; ---------- take/drop ----------
;; ---------- take/drop[-right] ----------
(let ()
(define funs (list take drop take-right drop-right))
(define tests
;; ------call------- --take--- --drop---
'([(? (a b c d) 2) (a b) (c d) ]
[(? (a b c d) 0) () (a b c d)]
[(? (a b c d) 4) (a b c d) () ]
[(? (a b c . d) 1) (a) (b c . d)]
[(? (a b c . d) 3) (a b c) d ]
[(? 99 0) () 99 ]))
(for ([t tests])
(apply test (cadr t) take (cdar t))
(apply test (caddr t) drop (cdar t)))
(arity-test take 2 2)
(arity-test drop 2 2)
(err/rt-test (drop 1 1) exn:application:mismatch?)
(err/rt-test (take 1 1) exn:application:mismatch?)
(err/rt-test (drop '(1 2 3) 2.0))
(err/rt-test (take '(1 2 3) 2.0))
(err/rt-test (drop '(1) '(1)))
(err/rt-test (take '(1) '(1)))
(err/rt-test (drop '(1) -1))
(err/rt-test (take '(1) -1))
(err/rt-test (drop '(1) 2) exn:application:mismatch?)
(err/rt-test (take '(1) 2) exn:application:mismatch?)
(err/rt-test (drop '(1 2 . 3) 3) exn:application:mismatch?)
(err/rt-test (take '(1 2 . 3) 3) exn:application:mismatch?))
;; -----args------ --take--- --drop--- --take-r--- --drop-r-
'([((a b c d) 2) (a b) (c d) (c d) (a b) ]
[((a b c d) 0) () (a b c d) () (a b c d)]
[((a b c d) 4) (a b c d) () (a b c d) () ]
[((a b c . d) 1) (a) (b c . d) (c . d) (a b) ]
[((a b c . d) 3) (a b c) d (a b c . d) () ]
[(99 0) () 99 99 () ]))
(for ([t tests] #:when #t [expect (cdr t)] [fun funs])
(apply test expect fun (car t)))
(for ([fun funs])
(arity-test fun 2 2)
(err/rt-test (fun 1 1) exn:application:mismatch?)
(err/rt-test (fun '(1 2 3) 2.0))
(err/rt-test (fun '(1) '(1)))
(err/rt-test (fun '(1) -1))
(err/rt-test (fun '(1) 2) exn:application:mismatch?)
(err/rt-test (fun '(1 2 . 3) 3) exn:application:mismatch?)))
;; ---------- append* ----------
(let ()