normalized the results of procedure-arity

svn: r17504

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)))))

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")

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
+procedure's name in the error message. 
-be a possible result from @scheme[procedure-arity], and it is used for
+
-the procedure's arity in the error message; if
+The @scheme[arity-v] value must
-@scheme[name-symbol-or-procedure] is a procedure, its actual arity is
+be a possible result from @scheme[procedure-arity], except
-ignored.  The @scheme[arg-v] arguments are the actual supplied
+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

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)

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 
+(test (make-arity-at-least 0) procedure-arity (case-lambda [() 10] [x 1]))
-							[() 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)))])

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)))

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)])