From 68efb4008a10f48f758289eca2e38a9eb47f5cf0 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 6 Jan 2010 19:34:29 +0000 Subject: [PATCH] normalized the results of procedure-arity svn: r17504 --- collects/scheme/private/norm-arity.ss | 84 ++++++++++++++ collects/scheme/private/pre-base.ss | 6 +- collects/scribblings/reference/exns.scrbl | 16 ++- .../scribblings/reference/procedures.scrbl | 8 ++ collects/tests/mzscheme/basic.ss | 109 +++++++++++++++++- collects/tests/mzscheme/kw.ss | 2 +- collects/tests/mzscheme/object.ss | 2 +- 7 files changed, 213 insertions(+), 14 deletions(-) create mode 100644 collects/scheme/private/norm-arity.ss diff --git a/collects/scheme/private/norm-arity.ss b/collects/scheme/private/norm-arity.ss new file mode 100644 index 0000000000..f967551e59 --- /dev/null +++ b/collects/scheme/private/norm-arity.ss @@ -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))))) \ No newline at end of file diff --git a/collects/scheme/private/pre-base.ss b/collects/scheme/private/pre-base.ss index d7b01b5cbb..a887b38af1 100644 --- a/collects/scheme/private/pre-base.ss +++ b/collects/scheme/private/pre-base.ss @@ -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") diff --git a/collects/scribblings/reference/exns.scrbl b/collects/scribblings/reference/exns.scrbl index 0c46cd366e..7582b1cb6d 100644 --- a/collects/scribblings/reference/exns.scrbl +++ b/collects/scribblings/reference/exns.scrbl @@ -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 diff --git a/collects/scribblings/reference/procedures.scrbl b/collects/scribblings/reference/procedures.scrbl index bc33071700..558f203ea7 100644 --- a/collects/scribblings/reference/procedures.scrbl +++ b/collects/scribblings/reference/procedures.scrbl @@ -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) diff --git a/collects/tests/mzscheme/basic.ss b/collects/tests/mzscheme/basic.ss index d7ff0673ab..7aaf513a2b 100644 --- a/collects/tests/mzscheme/basic.ss +++ b/collects/tests/mzscheme/basic.ss @@ -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)))]) diff --git a/collects/tests/mzscheme/kw.ss b/collects/tests/mzscheme/kw.ss index e0b8b8e6ae..d89e8bd7ec 100644 --- a/collects/tests/mzscheme/kw.ss +++ b/collects/tests/mzscheme/kw.ss @@ -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))) diff --git a/collects/tests/mzscheme/object.ss b/collects/tests/mzscheme/object.ss index b7b4af6a9a..12b8895f1f 100644 --- a/collects/tests/mzscheme/object.ss +++ b/collects/tests/mzscheme/object.ss @@ -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)])