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))
(err/rt-test (apply (lambda x x) 1 2)) (err/rt-test (apply (lambda x x) 1 2))
(err/rt-test (apply (lambda x x) 1 '(2 . 3))) (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 '(b e h) map cadr '((a b) (d e) (g h)))
(test '(5 7 9) map + '(1 2 3) '(4 5 6)) (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) [(proc args)
(if (#%procedure? proc) (if (#%procedure? proc)
(#2%apply proc args) (#2%apply proc args)
(#2%apply (extract-procedure proc (length args)) args))] (#2%apply (extract-procedure proc (and (#%list? args) (length args))) args))]
[(proc) [(proc)
(raise-arity-error 'apply (|#%app| arity-at-least 2) proc)] (raise-arity-error 'apply (|#%app| arity-at-least 2) proc)]
[(proc . argss) [(proc . argss)
(if (#%procedure? proc) (if (#%procedure? proc)
(#2%apply #2%apply proc argss) (#2%apply #2%apply proc argss)
(let ([len (let loop ([argss argss]) (let ([len (let loop ([argss argss] [accum 0])
(cond (cond
[(null? (cdr argss)) (length (car argss))] [(null? (cdr argss)) (let ([l (car argss)])
[else (fx+ 1 (loop (cdr argss)))]))]) (and (#%list? l)
(+ accum (length l))))]
[else (loop (cdr argss) (fx+ 1 accum))]))])
(#2%apply #2%apply (extract-procedure proc len) argss)))])) (#2%apply #2%apply (extract-procedure proc len) argss)))]))
(define-syntax (|#%app| stx) (define-syntax (|#%app| stx)
@ -87,7 +89,8 @@
(define (do-extract-procedure f orig-f n-args success-k fail-k) (define (do-extract-procedure f orig-f n-args success-k fail-k)
(cond (cond
[(#%procedure? f) [(#%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 (if success-k
(success-k f) (success-k f)
f) f)
@ -100,7 +103,7 @@
[(fixnum? v) [(fixnum? v)
(let ([a (struct-property-ref prop:procedure-arity rtd #f)]) (let ([a (struct-property-ref prop:procedure-arity rtd #f)])
(cond (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)] (wrong-arity-wrapper orig-f)]
[else [else
(do-extract-procedure (unsafe-struct-ref f v) orig-f n-args success-k wrong-arity-wrapper)]))] (do-extract-procedure (unsafe-struct-ref f v) orig-f n-args success-k wrong-arity-wrapper)]))]
@ -116,13 +119,13 @@
[else [else
(let ([a (struct-property-ref prop:procedure-arity rtd #f)]) (let ([a (struct-property-ref prop:procedure-arity rtd #f)])
(cond (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)] (wrong-arity-wrapper orig-f)]
[else [else
(do-extract-procedure (do-extract-procedure
v v
orig-f orig-f
(fx+ n-args 1) (and n-args (fx+ n-args 1))
(lambda (v) (lambda (v)
(cond (cond
[(not v) (case-lambda)] [(not v) (case-lambda)]