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

fix foldr/foldr argument checking (PR 10215)

Browse Source 
svn: r14706
This commit is contained in:
Matthew Flatt 2009-05-04 02:20:06 +00:00
parent 57d518dc8c
commit 57ff3c2486
2 changed files with 45 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
collects/scheme/private/list.ss
View File

@ -151,12 +151,38 @@
(list last)
(cons (f (car l)) (loop (cdr l))))))
(define (check-fold name proc init l more)
(unless (procedure? proc)
(apply raise-type-error name "procedure" 0 proc init l more))
(unless (list? l)
(apply raise-type-error name "list" 2 proc init l more))
(if (null? more)
(unless (procedure-arity-includes? proc 2)
(raise-mismatch-error name "arity mismatch, does not accept 1 argument: " proc))
(let ([len (length l)])
(let loop ([more more][n 3])
(unless (null? more)
(unless (list? (car more))
(apply raise-type-error name "list" n proc init l more))
(unless (= len (length (car more)))
(raise-mismatch-error name
"given list does not have the same size as the first list: "
(car more)))
(loop (cdr more) (add1 n))))
(unless (procedure-arity-includes? proc (+ 2 (length more)))
(raise-mismatch-error name
(format "arity mismatch, does not accept ~a arguments: "
(add1 (length more)))
proc)))))
(define foldl
(case-lambda
[(f init l)
(check-fold 'foldl f init l null)
(let loop ([init init] [l l])
(if (null? l) init (loop (f (car l) init) (cdr l))))]
[(f init l . ls)
(check-fold 'foldl f init l ls)
(let loop ([init init] [ls (cons l ls)])
(cond [(andmap pair? ls)
(loop (apply f (mapadd car ls init)) (map cdr ls))]
@ -167,11 +193,13 @@
(define foldr
(case-lambda
[(f init l)
(check-fold 'foldr f init l null)
(let loop ([init init] [l l])
(if (null? l)
init
(f (car l) (loop init (cdr l)))))]
[(f init l . ls)
(check-fold 'foldr f init l ls)
(let loop ([ls (cons l ls)])
(cond [(andmap pair? ls)
(apply f (mapadd car ls (loop (map cdr ls))))]

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

@ -21,6 +21,23 @@
(arity-test foldl 3 -1)
(arity-test foldr 3 -1)
(err/rt-test (foldl 'list 0 10))
(err/rt-test (foldl list 0 10))
(err/rt-test (foldl add1 0 '()))
(err/rt-test (foldl cons 0 '() '()))
(err/rt-test (foldl list 0 '() 10))
(err/rt-test (foldl list 0 '() '() 10))
(err/rt-test (let/ec k (foldl k 0 '(1 2) '(1 2 3))))
(err/rt-test (let/ec k (foldl k 0 '(1 2) '(1 2) '(1 2 3))))
(err/rt-test (foldr 'list 0 10))
(err/rt-test (foldr list 0 10))
(err/rt-test (foldr add1 0 '()))
(err/rt-test (foldr cons 0 '() '()))
(err/rt-test (foldr list 0 '() 10))
(err/rt-test (foldr list 0 '() '() 10))
(err/rt-test (let/ec k (foldr k 0 '(1 2) '(1 2 3))))
(err/rt-test (let/ec k (foldr k 0 '(1 2) '(1 2) '(1 2 3))))
(test '(0 1 2) memf add1 '(0 1 2))
(test '(2 (c 17)) memf number? '((a 1) (0 x) (1 w) 2 (c 17)))
(test '("ok" (2 .7) c) memf string? '((a 0) (0 a) (1 w) "ok" (2 .7) c))