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

fix interaction of `procedure-arity-includes?' and other things

Browse Source 
A arity-reduced procedure-valued `prop:procedure' was not handled
correctly, for example.

A good candidate for random testing? I had the right kind of test in
place, but only for an arity of 1. It turns out that testing any other
arity would have exposed the problem, so now there are tests with
arity 0. If I had randomly generated procedures instead of manually
constructing `f0' through `f1:+' in "procs.rktl", then maybe I would
have more naturally generalized the arity testing, too. Then again,
I did already have relevant inputs, and it was the testing of inputs
that was too specific.

Closes PR 12870
This commit is contained in:
Matthew Flatt 2012-06-25 17:08:14 -06:00
parent 90b5aad56b
commit cb88590dfb
2 changed files with 22 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/tests/racket/procs.rktl
View File

@ -87,13 +87,17 @@
(test-values (list (caddr p) (cadddr p)) (test-values (list (caddr p) (cadddr p))
(lambda () (lambda ()
(procedure-keywords (car p)))) (procedure-keywords (car p))))
(let ([1-ok? (let loop ([a a]) (define (check-ok n a)
(or (equal? a 1) (let loop ([a a])
(or (equal? a n)
(and (arity-at-least? a) (and (arity-at-least? a)
((arity-at-least-value a) . <= . 1)) ((arity-at-least-value a) . <= . n))
(and (list? a) (and (list? a)
(ormap loop a))))]) (ormap loop a)))))
(let ([1-ok? (check-ok 1 a)]
[0-ok? (check-ok 0 a)])
(test 1-ok? procedure-arity-includes? (car p) 1 #t) (test 1-ok? procedure-arity-includes? (car p) 1 #t)
(test 0-ok? procedure-arity-includes? (car p) 0 #t)
;; While we're here test renaming, etc.: ;; While we're here test renaming, etc.:
(test 'other object-name (procedure-rename (car p) 'other)) (test 'other object-name (procedure-rename (car p) 'other))
(test (procedure-arity (car p)) procedure-arity (procedure-rename (car p) 'other)) (test (procedure-arity (car p)) procedure-arity (procedure-rename (car p) 'other))
@ -293,6 +297,17 @@
(define (f2 #:x [x 8]) (list x)) (define (f2 #:x [x 8]) (list x))
(test 'f2 object-name f2)) (test 'f2 object-name f2))
;; ----------------------------------------
;; Check `procedure-arity-includes?' with method-style `prop:procedure' value
;; and `procedure-arity-reduce':
(let ()
(struct a ()
#:property prop:procedure (procedure-reduce-arity
(lambda (x y [z 5]) (+ y z))
3))
(test #t procedure-arity-includes? (a) 2))
;; ---------------------------------------- ;; ----------------------------------------
(report-errs) (report-errs)

2
src/racket/src/fun.c
View File

@ -1977,7 +1977,7 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
if (a >= 0) { if (a >= 0) {
bign = scheme_make_integer(a); bign = scheme_make_integer(a);
if (drop) if (drop)
bign = scheme_bin_plus(bign, scheme_make_integer(a)); bign = scheme_bin_plus(bign, scheme_make_integer(drop));
} }
if (a == -1) if (a == -1)
return clone_arity(((Scheme_Structure *)p)->slots[1], drop); return clone_arity(((Scheme_Structure *)p)->slots[1], drop);