normalized the results of procedure-arity
svn: r17504
This commit is contained in:
Robby Findler
parent
07fcfd8eee
commit
68efb4008a
84
collects/scheme/private/norm-arity.ss
Normal file
84
collects/scheme/private/norm-arity.ss
Normal file
|
|
@ -0,0 +1,84 @@
|
|||
(module norm-arity '#%kernel
|
||||
(#%require "for.ss" "define.ss" "small-scheme.ss" "sort.ss")
|
||||
(#%provide norm:procedure-arity
|
||||
norm:raise-arity-error
|
||||
normalize-arity) ;; for test suites
|
||||
(define norm:procedure-arity
|
||||
(let ([procedure-arity
|
||||
(λ (p)
|
||||
(normalize-arity (procedure-arity p)))])
|
||||
procedure-arity))
|
||||
(define norm:raise-arity-error
|
||||
(let ([raise-arity-error
|
||||
(λ (name arity-v . arg-vs)
|
||||
(if (or (exact-nonnegative-integer? arity-v)
|
||||
(arity-at-least? arity-v)
|
||||
(and (list? arity-v)
|
||||
(andmap (λ (x) (or (exact-nonnegative-integer? x)
|
||||
(arity-at-least? x)))
|
||||
arity-v)))
|
||||
(apply raise-arity-error name (normalize-arity arity-v) arg-vs)
|
||||
|
||||
;; here we let raise-arity-error signal an error
|
||||
(apply raise-arity-error name arity-v arg-vs)))])
|
||||
raise-arity-error))
|
||||
|
||||
;; normalize-arity : (or/c arity (listof arity))
|
||||
;; -> (or/c null
|
||||
;; arity
|
||||
;; non-empty-non-singleton-sorted-list-of-nat
|
||||
;; (append non-empty-sorted-list-of-nat
|
||||
;; (list (make-arity-at-least nat))))
|
||||
;;
|
||||
;; where arity = nat | (make-arity-at-least nat)
|
||||
;;
|
||||
;; result is normalized in the following sense:
|
||||
;; - no duplicate entries
|
||||
;; - nats are sorted
|
||||
;; - at most one arity-at-least, always at the beginning
|
||||
(define (normalize-arity a)
|
||||
(if (pair? a)
|
||||
(let-values ([(min-at-least) #f])
|
||||
|
||||
(for ((a (in-list a)))
|
||||
(when (arity-at-least? a)
|
||||
(when (or (not min-at-least)
|
||||
(< (arity-at-least-value a)
|
||||
(arity-at-least-value min-at-least)))
|
||||
(set! min-at-least a))))
|
||||
|
||||
(if-one-then-no-list
|
||||
(cond
|
||||
[min-at-least
|
||||
(append (sort
|
||||
(uniq
|
||||
(filter (λ (x) (and (number? x)
|
||||
(< x (arity-at-least-value
|
||||
min-at-least))))
|
||||
a))
|
||||
<)
|
||||
(list min-at-least))]
|
||||
[else
|
||||
(sort (uniq a) <)])))
|
||||
a))
|
||||
|
||||
;; have my own version of this to avoid a circular dependency
|
||||
(define (filter p l)
|
||||
(cond
|
||||
[(null? l) l]
|
||||
[else
|
||||
(let ([x (car l)])
|
||||
(if (p x)
|
||||
(cons x (filter p (cdr l)))
|
||||
(filter p (cdr l))))]))
|
||||
|
||||
(define (if-one-then-no-list lst)
|
||||
(cond
|
||||
[(and (pair? lst) (null? (cdr lst)))
|
||||
(car lst)]
|
||||
[else lst]))
|
||||
|
||||
(define (uniq lst)
|
||||
(let ([ht (make-hash)])
|
||||
(for-each (λ (i) (hash-set! ht i #f)) lst)
|
||||
(hash-map ht (λ (x y) x)))))
|
||||
|
|
@ -14,6 +14,7 @@
|
|||
"for.ss"
|
||||
"map.ss" ; shadows #%kernel bindings
|
||||
"kernstruct.ss"
|
||||
"norm-arity.ss"
|
||||
'#%builtin) ; so it's attached
|
||||
|
||||
(define-syntaxes (#%top-interaction)
|
||||
|
|
@ -70,7 +71,10 @@
|
|||
(rename lambda #%plain-lambda)
|
||||
(rename #%module-begin #%plain-module-begin)
|
||||
(rename module-begin #%module-begin)
|
||||
(all-from-except '#%kernel lambda λ #%app #%module-begin apply prop:procedure)
|
||||
(rename norm:procedure-arity procedure-arity)
|
||||
(rename norm:raise-arity-error raise-arity-error)
|
||||
(all-from-except '#%kernel lambda λ #%app #%module-begin apply prop:procedure
|
||||
procedure-arity raise-arity-error)
|
||||
(all-from "reqprov.ss")
|
||||
(all-from "for.ss")
|
||||
(all-from "kernstruct.ss")
|
||||
|
|
|
|||
|
|
@ -163,11 +163,17 @@ the procedure. The printed form of @scheme[v] is appended to
|
|||
|
||||
Creates an @scheme[exn:fail:contract:arity] value and @scheme[raise]s
|
||||
it as an exception. The @scheme[name] is used for the source
|
||||
procedure's name in the error message. The @scheme[arity-v] value must
|
||||
be a possible result from @scheme[procedure-arity], and it is used for
|
||||
the procedure's arity in the error message; if
|
||||
@scheme[name-symbol-or-procedure] is a procedure, its actual arity is
|
||||
ignored. The @scheme[arg-v] arguments are the actual supplied
|
||||
procedure's name in the error message.
|
||||
|
||||
The @scheme[arity-v] value must
|
||||
be a possible result from @scheme[procedure-arity], except
|
||||
that it does not have to be normalized (see @scheme[procedure-arity?] for
|
||||
the details of normalized arities); @scheme[raise-arity-error]
|
||||
will normalize the arity and used the normalized form in the error message.
|
||||
If @scheme[name-symbol-or-procedure] is a procedure, its actual arity is
|
||||
ignored.
|
||||
|
||||
The @scheme[arg-v] arguments are the actual supplied
|
||||
arguments, which are shown in the error message (using the error value
|
||||
conversion handler; see @scheme[error-value->string-handler]); also,
|
||||
the number of supplied @scheme[arg-v]s is explicitly mentioned in the
|
||||
|
|
|
|||
|
|
@ -129,6 +129,14 @@ A valid arity @scheme[_a] is one of the following:
|
|||
|
||||
]
|
||||
|
||||
Generally, @scheme[procedure-arity] always produces an arity that is normalized.
|
||||
Specifically, it is either the empty list (corresponding to the procedure
|
||||
@scheme[(case-lambda)]), one of the first two cases above, or a list
|
||||
that contains at least two elements. If it is a list, there is at most one
|
||||
@scheme[arity-at-least] instance that appears as the last element of the list,
|
||||
all of the other elements are sorted in ascending order, and there are no duplicate
|
||||
elements.
|
||||
|
||||
@mz-examples[
|
||||
(procedure-arity cons)
|
||||
(procedure-arity list)
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
|
||||
(Section 'basic)
|
||||
|
||||
(require scheme/flonum)
|
||||
(require scheme/flonum
|
||||
scheme/private/norm-arity)
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
@ -1818,12 +1819,108 @@
|
|||
(test (list 1 3 (make-arity-at-least 5))
|
||||
procedure-arity (case-lambda [(x) 0] [(x y z) 1] [(x y z w u . rest) 2]))
|
||||
(test (make-arity-at-least 0) procedure-arity (lambda x 1))
|
||||
(test (list 0 (make-arity-at-least 0)) procedure-arity (case-lambda
|
||||
[() 10]
|
||||
[x 1]))
|
||||
(test (make-arity-at-least 0) procedure-arity (case-lambda [() 10] [x 1]))
|
||||
(test (make-arity-at-least 0) procedure-arity (lambda x x))
|
||||
(arity-test procedure-arity 1 1)
|
||||
|
||||
(test '() normalize-arity '())
|
||||
(test 1 normalize-arity 1)
|
||||
(test 1 normalize-arity '(1))
|
||||
(test '(1 2) normalize-arity '(1 2))
|
||||
(test '(1 2) normalize-arity '(2 1))
|
||||
(test (make-arity-at-least 2) normalize-arity (list (make-arity-at-least 2) 3))
|
||||
(test (list 1 (make-arity-at-least 2))
|
||||
normalize-arity (list (make-arity-at-least 2) 1))
|
||||
(test (list 1 (make-arity-at-least 2))
|
||||
normalize-arity (list (make-arity-at-least 2) 1 3))
|
||||
(test (list 0 1 (make-arity-at-least 2))
|
||||
normalize-arity (list (make-arity-at-least 2) 1 0 3))
|
||||
(test (list 0 1 (make-arity-at-least 2))
|
||||
normalize-arity (list (make-arity-at-least 2)
|
||||
(make-arity-at-least 4) 1 0 3))
|
||||
(test (list 0 1 (make-arity-at-least 2))
|
||||
normalize-arity (list (make-arity-at-least 4)
|
||||
(make-arity-at-least 2) 1 0 3))
|
||||
(test (list 1 2) normalize-arity (list 1 1 2 2))
|
||||
(test 1 normalize-arity (list 1 1 1))
|
||||
(test (list 1 (make-arity-at-least 2))
|
||||
normalize-arity (list (make-arity-at-least 2) 1 1))
|
||||
(test (list 1 (make-arity-at-least 2))
|
||||
normalize-arity
|
||||
(list (make-arity-at-least 2)
|
||||
(make-arity-at-least 2) 1 1))
|
||||
|
||||
(let ()
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; randomized testing
|
||||
;; predicate: normalize-arity produces a normalized arity
|
||||
;;
|
||||
|
||||
(define (normalized-arity? a)
|
||||
(or (null? a)
|
||||
(arity? a)
|
||||
(and (list? a)
|
||||
((length a) . >= . 2)
|
||||
(andmap arity? a)
|
||||
(if (arity-at-least? (last a))
|
||||
(non-empty-non-singleton-sorted-list-ending-with-arity? a)
|
||||
(non-singleton-non-empty-sorted-list? a)))))
|
||||
|
||||
(define (arity? a)
|
||||
(or (nat? a)
|
||||
(and (arity-at-least? a)
|
||||
(nat? (arity-at-least-value a)))))
|
||||
|
||||
(define (nat? a)
|
||||
(and (number? a)
|
||||
(integer? a)
|
||||
(a . >= . 0)))
|
||||
|
||||
;; non-empty-non-singleton-sorted-list-ending-with-arity? : xx -> boolean
|
||||
;; know that 'a' is a list of at least 2 elements
|
||||
(define (non-empty-non-singleton-sorted-list-ending-with-arity? a)
|
||||
(let loop ([bound (car a)]
|
||||
[lst (cdr a)])
|
||||
(cond
|
||||
[(null? (cdr lst))
|
||||
(and (arity-at-least? (car lst))
|
||||
(> (arity-at-least-value (car lst)) bound))]
|
||||
[else
|
||||
(and (nat? (car lst))
|
||||
((car lst) . > . bound)
|
||||
(loop (car lst)
|
||||
(cdr lst)))])))
|
||||
|
||||
(define (non-empty-sorted-list? a)
|
||||
(and (pair? a)
|
||||
(sorted-list? a)))
|
||||
|
||||
(define (non-singleton-non-empty-sorted-list? a)
|
||||
(and (pair? a)
|
||||
(pair? (cdr a))
|
||||
(sorted-list? a)))
|
||||
|
||||
(define (sorted-list? a)
|
||||
(or (null? a)
|
||||
(sorted/bounded-list? (cdr a) (car a))))
|
||||
|
||||
(define (sorted/bounded-list? a bound)
|
||||
(or (null? a)
|
||||
(and (number? (car a))
|
||||
(< bound (car a))
|
||||
(sorted/bounded-list? (cdr a) (car a)))))
|
||||
|
||||
(for ((i (in-range 1 2000)))
|
||||
(let* ([rand-bound (ceiling (/ i 10))]
|
||||
[l (build-list (random rand-bound)
|
||||
(λ (i) (if (zero? (random 5))
|
||||
(make-arity-at-least (random rand-bound))
|
||||
(random rand-bound))))]
|
||||
[res (normalize-arity l)])
|
||||
(unless (normalized-arity? res)
|
||||
(error 'normalize-arity-failed "input ~s; output ~s" l res)))))
|
||||
|
||||
(test #t procedure-arity-includes? cons 2)
|
||||
(test #f procedure-arity-includes? cons 0)
|
||||
(test #f procedure-arity-includes? cons 3)
|
||||
|
|
@ -2299,7 +2396,7 @@
|
|||
(lambda (proc)
|
||||
(let ([a (procedure-reduce-arity proc ar)])
|
||||
(test #t procedure? a)
|
||||
(test ar procedure-arity a)
|
||||
(test (normalize-arity ar) procedure-arity a)
|
||||
(map (lambda (i)
|
||||
(test #t procedure-arity-includes? a i)
|
||||
(when (i . < . 100)
|
||||
|
|
@ -2331,7 +2428,7 @@
|
|||
(check-ok + (expt 2 70) (list (expt 2 70)) (list 0 10 (add1 (expt 2 70))))
|
||||
(check-ok + (make-arity-at-least 2) (list 2 5 (expt 2 70)) (list 0 1))
|
||||
(check-ok + (list 2 4) '(2 4) '(0 3))
|
||||
(check-ok + (list 4 2) '(4 2) '(0 3))
|
||||
(check-ok + (list 2 4) '(4 2) '(0 3))
|
||||
(check-ok + (list 0 (make-arity-at-least 2)) (list 0 2 5 (expt 2 70)) (list 1))
|
||||
(check-ok + (list 4 (make-arity-at-least 2)) '(2 3 4 10) '(0 1))
|
||||
(check-ok + (list 2 (make-arity-at-least 4)) '(2 4 10) '(0 1 3)))])
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@
|
|||
|
||||
;; using only optionals
|
||||
(t (procedure-arity (lambda/kw (#:optional) 0)) => 0
|
||||
(procedure-arity (lambda/kw (x #:optional y z) 0)) => '(3 1 2))
|
||||
(procedure-arity (lambda/kw (x #:optional y z) 0)) => '(1 2 3))
|
||||
(let ([f (lambda/kw (x #:optional y) (list x y))])
|
||||
(t (f 0) => '(0 #f)
|
||||
(f 0 1) => '(0 1)))
|
||||
|
|
|
|||
|
|
@ -1248,7 +1248,7 @@
|
|||
(check-arity-error (mk-f) #f))
|
||||
(let ([mk-f (lambda ()
|
||||
(eval (syntax-property #'(case-lambda [(a b) a][(c d) c]) 'method-arity-error #t)))])
|
||||
(test '(2 2) procedure-arity (mk-f))
|
||||
(test 2 procedure-arity (mk-f))
|
||||
(check-arity-error (mk-f) #t)
|
||||
(test 1 (mk-f) 1 2)
|
||||
(let ([f (mk-f)])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user