Fixing a few bugs from drdr

This commit is contained in:
Jay McCarthy 2010-08-12 14:54:48 -06:00
parent fae0cb2c99
commit debd6026f3
3 changed files with 13 additions and 19 deletions

View File

@ -1,5 +1,5 @@
#lang scheme/base #lang scheme/base
(require (only-in "private/list.rkt" split-at))
(provide first second third fourth fifth sixth seventh eighth ninth tenth (provide first second third fourth fifth sixth seventh eighth ninth tenth
last-pair last rest last-pair last rest
@ -107,6 +107,14 @@
[(pair? list) (cons (car list) (loop (cdr list) (sub1 n)))] [(pair? list) (cons (car list) (loop (cdr list) (sub1 n)))]
[else (too-large 'take list0 n0)]))) [else (too-large 'take list0 n0)])))
(define (split-at list0 n0)
(unless (exact-nonnegative-integer? n0)
(raise-type-error 'split-at "non-negative exact integer" n0))
(let loop ([list list0] [n n0] [pfx '()])
(cond [(zero? n) (values (reverse pfx) list)]
[(pair? list) (loop (cdr list) (sub1 n) (cons (car list) pfx))]
[else (too-large 'split-at list0 n0)])))
(define (drop list n) (define (drop list n)
;; could be defined as `list-tail', but this is better for errors anyway ;; could be defined as `list-tail', but this is better for errors anyway
(unless (exact-nonnegative-integer? n) (unless (exact-nonnegative-integer? n)

View File

@ -1,9 +1,7 @@
(module list "pre-base.rkt" (module list "pre-base.rkt"
(provide split-at (provide foldl
foldl
foldr foldr
remv remv
@ -26,19 +24,6 @@
build-list build-list
compose) compose)
(define (split-at list0 n0)
(unless (exact-nonnegative-integer? n0)
(raise-type-error 'split-at "non-negative exact integer" n0))
(let loop ([list list0] [n n0] [pfx '()])
(cond [(zero? n) (values (reverse pfx) list)]
[(pair? list) (loop (cdr list) (sub1 n) (cons (car list) pfx))]
[else
(raise-mismatch-error
'split-at
(format "index ~e too large for list~a: "
n0 (if (list? list0) "" " (not a proper list)"))
list0)])))
(#%require (rename "sort.rkt" raw-sort sort) (#%require (rename "sort.rkt" raw-sort sort)
(for-syntax "stxcase-scheme.rkt")) (for-syntax "stxcase-scheme.rkt"))

View File

@ -39,8 +39,9 @@
[(v s) [(v s)
(-seqn-cons (values v) s)] (-seqn-cons (values v) s)]
[vs*s [vs*s
(define-values (vs sl) (split-at vs*s (sub1 (length vs*s)))) ; XXX double reverse is bad but moving split-at causes a problem I can't figure
(-seqn-cons (apply values vs) (car sl))])) (define s*vs (reverse vs*s))
(-seqn-cons (apply values (reverse (cdr s*vs))) (car s*vs))]))
(define (seqn-first s) (define (seqn-first s)
(define-values (more? next) (sequence-generate s)) (define-values (more? next) (sequence-generate s))