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

fold: fix err while erroring when 3rd (or greater) list arg isnt list

Browse Source
This commit is contained in:
Stephen Chang 2019-10-01 09:59:20 -04:00 committed by Matthew Flatt
parent 84340c6cca
commit 2643a75ce3
2 changed files with 18 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
pkgs/racket-test-core/tests/racket/list.rktl
View File

@ -27,6 +27,12 @@
(err/rt-test (foldl cons 0 '() '())) (err/rt-test (foldl cons 0 '() '()))
(err/rt-test (foldl list 0 '() 10)) (err/rt-test (foldl list 0 '() 10))
(err/rt-test (foldl list 0 '() '() 10)) (err/rt-test (foldl list 0 '() '() 10))
(err/rt-test (foldl list 0 '() '() 10)
exn:fail:contract?
"expected.*list\\?.*5th")
(err/rt-test (foldl list 0 '() '() '() 10)
exn:fail:contract?
"expected.*list\\?.*6th")
(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 3))))
(err/rt-test (let/ec k (foldl k 0 '(1 2) '(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))
@ -35,6 +41,12 @@
(err/rt-test (foldr cons 0 '() '())) (err/rt-test (foldr cons 0 '() '()))
(err/rt-test (foldr list 0 '() 10)) (err/rt-test (foldr list 0 '() 10))
(err/rt-test (foldr list 0 '() '() 10)) (err/rt-test (foldr list 0 '() '() 10))
(err/rt-test (foldr list 0 '() '() 10)
exn:fail:contract?
"expected.*list\\?.*5th")
(err/rt-test (foldr list 0 '() '() '() 10)
exn:fail:contract?
"expected.*list\\?.*6th")
(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 3))))
(err/rt-test (let/ec k (foldr k 0 '(1 2) '(1 2) '(1 2 3)))) (err/rt-test (let/ec k (foldr k 0 '(1 2) '(1 2) '(1 2 3))))

12
racket/collects/racket/private/list.rkt
View File

@ -210,15 +210,15 @@
(unless (procedure-arity-includes? proc 2) (unless (procedure-arity-includes? proc 2)
(raise-mismatch-error name "given procedure does not accept 2 arguments: " proc)) (raise-mismatch-error name "given procedure does not accept 2 arguments: " proc))
(let ([len (length l)]) (let ([len (length l)])
(let loop ([more more][n 3]) (let loop ([remaining more][n 3])
(unless (null? more) (unless (null? remaining)
(unless (list? (car more)) (unless (list? (car remaining))
(apply raise-argument-error name "list?" n proc init l more)) (apply raise-argument-error name "list?" n proc init l more))
(unless (= len (length (car more))) (unless (= len (length (car remaining)))
(raise-mismatch-error name (raise-mismatch-error name
"given list does not have the same size as the first list: " "given list does not have the same size as the first list: "
(car more))) (car remaining)))
(loop (cdr more) (add1 n)))) (loop (cdr remaining) (add1 n))))
(unless (procedure-arity-includes? proc (+ 2 (length more))) (unless (procedure-arity-includes? proc (+ 2 (length more)))
(raise-mismatch-error name (raise-mismatch-error name
(format "given procedure does not accept ~a arguments: " (format "given procedure does not accept ~a arguments: "