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

racket/cmdline: fix problem with arity checking

Browse Source 
Extra normalization due to 59b1e32fe9 exposed the bug.
This commit is contained in:
Matthew Flatt 2013-03-31 20:29:23 -06:00
parent 5d8f470e0b
commit b78982fe6a
2 changed files with 24 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
collects/racket/cmdline.rkt
View File

@ -192,21 +192,17 @@
(define (print-args port l f)
(let loop ([l l]
[a (let a-c ([a (procedure-arity f)])
(cond [(number? a) (cons (sub1 a) (sub1 a))]
[(arity-at-least? a)
(let ([v (sub1 (arity-at-least-value a))])
(cons v v))]
[else (let ([r (map a-c a)])
(cons (apply min (map car r))
(apply max (map cdr r))))]))])
[n 1])
(unless (null? l)
(define optional? (procedure-arity-includes? f n))
(fprintf port " ~a<~a>~a"
(if (positive? (car a)) "" "[")
(if optional? "[" "")
(car l)
(if (positive? (car a)) "" "]"))
(unless (positive? (cdr a)) (fprintf port " ..."))
(loop (cdr l) (cons (sub1 (car a)) (sub1 (cdr a)))))))
(if optional? "]" ""))
(when (and (null? (cdr l))
(procedure-arity-includes? f (+ n 2)))
(fprintf port " ..."))
(loop (cdr l) (add1 n)))))
(define (procedure-arity-includes-at-least? p n)
(let a-c ([a (procedure-arity p)])
@ -303,15 +299,11 @@
(or (number? a) (arity-at-least? a))))
(raise-type-error 'parse-command-line "unknown-flag procedure of simple arity, accepting 1 argument (an perhaps more)" unknown-flag))
(letrec ([a (procedure-arity finish)]
[l (length finish-help)]
[a-c (lambda (a)
(or (and (number? a) (sub1 a))
(and (arity-at-least? a)
(max 1 (arity-at-least-value a)))
(and (list? a) (apply max (map a-c a)))))])
(unless (= (a-c a) l)
(error 'parse-command-line "the length of the argument help string list does not match the arity of the finish procedure")))
(unless (procedure-arity-includes? finish (add1 (length finish-help)))
(raise-arguments-error 'parse-command-line
"mismatch in length of argument help string and finish procedure arity"
"argument help string" finish-help
"finish procedure" finish))
(let* ([finalled? #f] ; set to true when 'once-final is seen
[once-spec-set

11
collects/tests/racket/cmdline.rktl
View File

@ -199,4 +199,15 @@
(syntax-test #'(command-line "hello" #("ok") (=> 'done) (once-any ("-ok" a "the ok flag" 7))))
(syntax-test #'(command-line "hello" #("ok") (=> 1 2 3 4) (once-any ("-ok" a "the ok flag" 7))))
(err/rt-test (parse-command-line "test" #("x") null (lambda () 'too-few) '("arg")))
(err/rt-test (parse-command-line "test" #("x") null (lambda (x) 'still-too-few) '("arg")))
(err/rt-test (parse-command-line "test" #("x") null (lambda (x y z) 'too-many) '("arg")))
(err/rt-test (parse-command-line "test" #("x") null (lambda (x y z . w) 'too-many) '("arg")))
(test 'ok parse-command-line "test" #("x") null (lambda (x y) 'ok) '("arg"))
(test 'ok parse-command-line "test" #("x") null (lambda (x . y) 'ok) '("arg"))
(test 'ok parse-command-line "test" #("x") null (lambda (x y . z) 'ok) '("arg"))
(test 'ok parse-command-line "test" #("x") null (case-lambda [(x) 'none] [(x y) 'ok]) '("arg"))
(test 'ok parse-command-line "test" #("x") null (case-lambda [(x) 'none] [(x . ys) 'ok]) '("arg"))
(test 'ok parse-command-line "test" #("x") null (case-lambda [(x) 'none] [(x y . z) 'ok]) '("arg"))
(report-errs)