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

cs: fix error reporting for apply on a non-list

Browse Source
This commit is contained in:
Matthew Flatt 2019-10-12 16:20:16 -06:00
parent 2d3b426d05
commit cd596e5277
2 changed files with 13 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/racket-test-core/tests/racket/basic.rktl
View File

@ -1497,6 +1497,8 @@
(err/rt-test (apply (lambda x x) 1))
(err/rt-test (apply (lambda x x) 1 2))
(err/rt-test (apply (lambda x x) 1 '(2 . 3)))
(err/rt-test (apply 10 '(2 . 3)))
(err/rt-test (apply 10 0 '(2 . 3)))
(test '(b e h) map cadr '((a b) (d e) (g h)))
(test '(5 7 9) map + '(1 2 3) '(4 5 6))

19
racket/src/cs/rumble/procedure.ss
View File

@ -42,16 +42,18 @@
[(proc args)
(if (#%procedure? proc)
(#2%apply proc args)
(#2%apply (extract-procedure proc (length args)) args))]
(#2%apply (extract-procedure proc (and (#%list? args) (length args))) args))]
[(proc)
(raise-arity-error 'apply (|#%app| arity-at-least 2) proc)]
[(proc . argss)
(if (#%procedure? proc)
(#2%apply #2%apply proc argss)
(let ([len (let loop ([argss argss])
(let ([len (let loop ([argss argss] [accum 0])
(cond
[(null? (cdr argss)) (length (car argss))]
[else (fx+ 1 (loop (cdr argss)))]))])
[(null? (cdr argss)) (let ([l (car argss)])
(and (#%list? l)
(+ accum (length l))))]
[else (loop (cdr argss) (fx+ 1 accum))]))])
(#2%apply #2%apply (extract-procedure proc len) argss)))]))
(define-syntax (|#%app| stx)
@ -87,7 +89,8 @@
(define (do-extract-procedure f orig-f n-args success-k fail-k)
(cond
[(#%procedure? f)
(if (chez:procedure-arity-includes? f n-args)
(if (or (not n-args)
(chez:procedure-arity-includes? f n-args))
(if success-k
(success-k f)
f)
@ -100,7 +103,7 @@
[(fixnum? v)
(let ([a (struct-property-ref prop:procedure-arity rtd #f)])
(cond
[(and a (not (bitwise-bit-set? (unsafe-struct*-ref f a) n-args)))
[(and a n-args (not (bitwise-bit-set? (unsafe-struct*-ref f a) n-args)))
(wrong-arity-wrapper orig-f)]
[else
(do-extract-procedure (unsafe-struct-ref f v) orig-f n-args success-k wrong-arity-wrapper)]))]
@ -116,13 +119,13 @@
[else
(let ([a (struct-property-ref prop:procedure-arity rtd #f)])
(cond
[(and a (not (bitwise-bit-set? (unsafe-struct*-ref f a) n-args)))
[(and a n-args (not (bitwise-bit-set? (unsafe-struct*-ref f a) n-args)))
(wrong-arity-wrapper orig-f)]
[else
(do-extract-procedure
v
orig-f
(fx+ n-args 1)
(and n-args (fx+ n-args 1))
(lambda (v)
(cond
[(not v) (case-lambda)]