fall back to the slow path when application expression looks wrong

closes PR 14279
2014-01-12 23:14:50 -06:00 · 2014-01-12 23:14:50 -06:00 · 4d123bb26d
commit 4d123bb26d
parent 04628e3516
7 changed files with 333 additions and 89 deletions
--- a/pkgs/racket-pkgs/racket-test/tests/racket/contract-helpers.rkt
+++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract-helpers.rkt
@ -1,6 +1,11 @@
 #lang racket
 (require rackunit
-         racket/contract/private/arrow)
+         racket/contract/private/arrow
+         
+         (for-template racket/contract/private/arrow-val-first)
+         racket/contract/private/application-arity-checking
+         racket/contract/private/arr-i-parse)
+
 (check-equal? (matches-arity-exactly? (λ () 1) 0 0 '() '()) #t)
 (check-equal? (matches-arity-exactly? (λ () 1) 1 1 '() '()) #f)
 (check-equal? (matches-arity-exactly? (λ () 1) 0 1 '() '()) #f)
@ -65,3 +70,41 @@
 (check-equal? (matches-arity-exactly? (lambda (x #:y y #:z [z 1]) y)
 	                              1 1 '() '(#:y #:z))
              #f)
+
+
+(check-equal? (->-valid-app-shapes #'(-> integer? integer?))
+              (valid-app-shapes '(1) '() '()))
+(check-equal? (->-valid-app-shapes #'(-> integer? boolean? integer?))
+              (valid-app-shapes '(2) '() '()))
+(check-equal? (->-valid-app-shapes #'(-> integer? #:x any/c integer?))
+              (valid-app-shapes '(1) '(#:x) '()))
+(check-equal? (->-valid-app-shapes #'(-> integer? #:x any/c #:y any/c integer?))
+              (valid-app-shapes '(1) '(#:x #:y) '()))
+
+(check-equal? (->*-valid-app-shapes #'(->* (integer? #:x any/c #:y any/c) integer?))
+              (valid-app-shapes '(1) '(#:x #:y) '()))
+(check-equal? (->*-valid-app-shapes #'(->* () (integer? #:x any/c #:y any/c) integer?))
+              (valid-app-shapes '(0 1) '() '(#:x #:y)))
+(check-equal? (->*-valid-app-shapes #'(->* (any/c) (any/c) #:rest any/c integer?))
+              (valid-app-shapes '(1 2 . 3) '() '()))
+
+(check-equal? (->i-valid-app-shapes #'(->i () () [r any/c]))
+              (valid-app-shapes '(0) '() '()))
+(check-equal? (->*-valid-app-shapes #'(->i ([p integer?] #:x [x any/c] #:y [y any/c]) [r any/c]))
+              (valid-app-shapes '(1) '(#:x #:y) '()))
+(check-equal? (->*-valid-app-shapes #'(->i () ([p integer?] #:x [x any/c] #:y [y any/c]) [r any/c]))
+              (valid-app-shapes '(0 1) '() '(#:x #:y)))
+(check-equal? (->*-valid-app-shapes #'(->i ([m any/c]) ([o any/c]) #:rest [r any/c] [r any/c]))
+              (valid-app-shapes '(1 2 . 3) '() '()))
+
+              
+(check-true  (valid-argument-list? #'(f x) (valid-app-shapes '(1 2 . 3) '() '())))
+(check-true  (valid-argument-list? #'(f x y) (valid-app-shapes '(1 2 . 3) '() '())))
+(check-true  (valid-argument-list? #'(f x y a b c d) (valid-app-shapes '(1 2 . 3) '() '())))
+(check-false (valid-argument-list? #'(f) (valid-app-shapes '(1 2 . 3) '() '()) #f))
+(check-true  (valid-argument-list? #'(f #:x x) (valid-app-shapes '(0) '(#:x) '())))
+(check-true  (valid-argument-list? #'(f #:x x) (valid-app-shapes '(0) '() '(#:x))))
+(check-true  (valid-argument-list? #'(f) (valid-app-shapes '(0) '() '(#:x))))
+(check-false (valid-argument-list? #'(f) (valid-app-shapes '(0) '(#:x) '()) #f))
+(check-false (valid-argument-list? #'(f #:y y) (valid-app-shapes '(0) '(#:x) '()) #f))
+(check-false (valid-argument-list? #'(f #:x) (valid-app-shapes '(0) '(#:x) '()) #f))
--- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/contract-out.rkt
+++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/contract-out.rkt
@ -938,6 +938,27 @@
      (eval '(require 'provide/contract48-m1)))
   "provide/contract48-m1")
  
+  ;; test to make sure that arity errors have the 
+  ;; right name at the beginning of the message
+  (test/spec-passed/result
+   'provide/contract49
+   '(let ()
+      (eval '(module provide/contract49-m1 racket/base
+               (require racket/contract/base)
+               (define (f x) x)
+               (provide (contract-out [f (-> any/c any)]))))
+      (eval '(module provide/contract49-m2 racket/base
+               (require 'provide/contract48-m1)
+               (f 1 2)))
+      (with-handlers ([exn:fail? (λ (x) 
+                                   (define m (regexp-match #rx"([^:]*:)" (exn-message x)))
+                                   (if m
+                                       (cadr m) 
+                                       (list "regexp failed to match"
+                                             (exn-message x))))])
+        (eval '(require 'provide/contract49-m2))))
+   "f:")
+  
  (contract-error-test
   'contract-error-test8
   #'(begin
--- a/racket/collects/racket/contract/private/application-arity-checking.rkt
+++ b/racket/collects/racket/contract/private/application-arity-checking.rkt
@ -0,0 +1,72 @@
+#lang racket/base
+
+#|
+
+Used to check an application site of a well-known
+contract function to see if the shape is okay.
+
+That is, each contract builds a valid-app-shapes struct
+describing what application expression shapes are okay
+and valid-argument-list? checks an application against
+a valid-app-shape.
+
+|#
+
+(provide (struct-out valid-app-shapes)
+         valid-argument-list?)
+
+;; valid-arities : (or/c (listof nat) (improper-listof nat))
+;;    -- if improper, then the last nat indicates that any number
+;;       of args equal to or later than that last nat are okay
+;; mandatory-kwds : (listof keyword?)
+;; optional-kwds : (or/c (listof keyword?) 'any)
+;;   'any indicates that any keyword is allowed
+(struct valid-app-shapes (valid-arities mandatory-kwds optional-kwds) 
+  #:prefab)
+
+(define (valid-argument-list? app-stx the-valid-app-shape [log-problems? #t])
+  (cond
+    [the-valid-app-shape
+     (define-values (kwds arg-count)
+       (let loop ([stx (syntax-case app-stx ()
+                         [(function . args) #'args])]
+                  [kwds '()]
+                  [arg-count 0])
+         (syntax-case stx ()
+           [(kwd kwd-arg . rest)
+            (keyword? (syntax-e #'kwd))
+            (loop #'rest (cons (syntax-e #'kwd) kwds) arg-count)]
+           [(arg . rest)
+            (loop #'rest kwds (+ arg-count 1))]
+           [()
+            (values kwds arg-count)])))
+     
+     (define good-arg-count?
+       (let loop ([allowed-counts (valid-app-shapes-valid-arities the-valid-app-shape)])
+         (cond
+           [(null? allowed-counts) #f]
+           [(number? allowed-counts) (arg-count . >= . allowed-counts)]
+           [else (or (= arg-count (car allowed-counts))
+                     (loop (cdr allowed-counts)))])))
+     
+     (define ans?
+       (and good-arg-count?
+            (for/and ([kwd (in-list (valid-app-shapes-mandatory-kwds the-valid-app-shape))])
+              (member kwd kwds))
+            (for/and ([kwd (in-list kwds)])
+              (or (member kwd (valid-app-shapes-mandatory-kwds the-valid-app-shape))
+                  (member kwd (valid-app-shapes-optional-kwds the-valid-app-shape))))
+            #t))
+     (when log-problems?
+       (unless ans?
+         (log-problem app-stx)))
+     ans?]
+    [else #t]))
+
+(define-logger optimizer)
+(define (log-problem stx)
+  (log-optimizer-warning 
+   "warning in ~a:~a:~a: contract system detects procedure incorrectly applied"
+   (syntax-source stx)
+   (syntax-line stx)
+   (syntax-column stx)))
--- a/racket/collects/racket/contract/private/arr-i-parse.rkt
+++ b/racket/collects/racket/contract/private/arr-i-parse.rkt
@ -6,6 +6,8 @@
                    [make-module-identifier-mapping make-free-identifier-mapping]
                    [module-identifier-mapping-get free-identifier-mapping-get]
                    [module-identifier-mapping-put! free-identifier-mapping-put!])
+         "application-arity-checking.rkt"
+         "arr-util.rkt"
         (for-template racket/base
                       "misc.rkt"))

@ -498,8 +500,33 @@ code does the parsing and validation of the syntax.
      [_
       (raise-syntax-error #f "bad syntax" stx)])))

+(define (->i-valid-app-shapes stx)
+  (define an-istx (parse-->i stx))
+  (define mans 0)
+  (define opts 0)
+  (define man-kwds '())
+  (define opt-kwds '())
+  (for ([arg (in-list (istx-args an-istx))])
+    (define kwd (arg-kwd arg))
+    (define opt? (arg-optional? arg))
+    (cond
+      [(and kwd opt?)
+       (set! opt-kwds (cons kwd opt-kwds))]
+      [(and kwd (not opt?))
+       (set! man-kwds (cons kwd man-kwds))]
+      [(and (not kwd) opt?)
+       (set! opts (+ opts 1))]
+      [(and (not kwd) (not opt?))
+       (set! mans (+ mans 1))]))
+  (valid-app-shapes-from-man/opts mans 
+                                  opts
+                                  (istx-rst an-istx)
+                                  man-kwds
+                                  opt-kwds))
+
 (provide
 parse-->i
+ ->i-valid-app-shapes
 (struct-out istx)
 (struct-out arg/res)
 (struct-out arg)
--- a/racket/collects/racket/contract/private/arr-util.rkt
+++ b/racket/collects/racket/contract/private/arr-util.rkt
@ -1,7 +1,9 @@
 #lang racket/base

+(require "application-arity-checking.rkt")
 (provide split-doms
-         sort-keywords)
+         sort-keywords
+         valid-app-shapes-from-man/opts)

 ;; split-doms : syntax identifier syntax -> syntax
 ;; given a sequence of keywords interpersed with other
@ -59,3 +61,19 @@
    (cond
      [(null? pairs) null]
      [else (insert (car pairs) (loop (cdr pairs)))])))
+
+
+
+
+ 
+
+(define (valid-app-shapes-from-man/opts min-arg-length num-of-opts rest? man-kwds opt-kwds)
+  (define opt+man-dom-lengths
+    (for/list ([i (in-range (+ num-of-opts 1))])
+      (+ i min-arg-length)))
+  (valid-app-shapes (if rest?
+                        (append opt+man-dom-lengths 
+                                (+ min-arg-length num-of-opts 1))
+                        opt+man-dom-lengths)
+                    man-kwds
+                    opt-kwds))
--- a/racket/collects/racket/contract/private/arrow-val-first.rkt
+++ b/racket/collects/racket/contract/private/arrow-val-first.rkt
@ -1,5 +1,6 @@
 #lang racket/base
 (require (for-syntax racket/base
+                     "application-arity-checking.rkt"
                     "arr-util.rkt")
         "kwd-info-struct.rkt"
         "arity-checking.rkt"
@ -14,7 +15,9 @@

 (provide ->2 ->*2
         (for-syntax ->2-handled?
-                     ->*2-handled?))
+                     ->*2-handled?
+                     ->-valid-app-shapes
+                     ->*-valid-app-shapes))

 (define-for-syntax (->2-handled? stx)
  (syntax-case stx (any values any/c)
@ -444,6 +447,17 @@
                                                    this->)]
                        let-bindings))]))])))

+(define-for-syntax (->-valid-app-shapes stx)
+  (syntax-case stx ()
+    [(_ args ...)
+     (let ()
+       (define this-> (gensym 'this->))
+       (define-values (regular-args kwds kwd-args let-bindings)
+         (parse-arrow-args stx (syntax->list #'(args ...)) this->))
+       (valid-app-shapes (list (- (length regular-args) 1))
+                         (map syntax->datum kwds)
+                         '()))]))
+
 (define-syntax (->2 stx)
  (syntax-case stx ()
    [(_ args ...)
@ -521,22 +535,55 @@
               kwd-doms
               (cons #`[t x] let-bindings)))])))

-(define-syntax (->*2 stx)
-  (cond
-    [(->*2-handled? stx)
+(define-for-syntax (parse->*2 stx)
  (syntax-case stx ()
    [(_ (raw-mandatory-dom ...) . other)
     (let ()
       (define-values (raw-optional-doms rest-ctc pre rng-ctcs post)
         (arrow:parse-leftover->* stx #'other))
-          (with-syntax ([((mandatory-dom ...) 
-                          ((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...)
-                          (mandatory-let-bindings ...))
+       (with-syntax ([(man-dom
+                       man-dom-kwds
+                       man-lets)
                      (:split-doms stx '->* #'(raw-mandatory-dom ...))]
-                        [((optional-dom ...)
-                          ((optional-dom-kwd optional-dom-kwd-ctc) ...)
-                          (optional-let-bindings ...))
-                         (:split-doms stx '->* raw-optional-doms)]
+                     [(opt-dom
+                       opt-dom-kwds
+                       opt-lets)
+                      (:split-doms stx '->* raw-optional-doms)])
+         (values
+          #'man-dom
+          #'man-dom-kwds
+          #'man-lets
+          #'opt-dom
+          #'opt-dom-kwds
+          #'opt-lets
+          rest-ctc pre rng-ctcs post)))]))
+
+(define-for-syntax (->*-valid-app-shapes stx)
+  (define-values (man-dom man-dom-kwds man-lets
+                          opt-dom opt-dom-kwds opt-lets
+                          rest-ctc pre rng-ctcs post)
+    (parse->*2 stx))
+  (with-syntax ([((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...) man-dom-kwds]
+                [((optional-dom-kwd optional-dom-kwd-ctc) ...) opt-dom-kwds])
+    (valid-app-shapes-from-man/opts (length (syntax->list man-dom))
+                                    (length (syntax->list opt-dom))
+                                    rest-ctc
+                                    (syntax->datum #'(mandatory-dom-kwd ...))
+                                    (syntax->datum #'(optional-dom-kwd ...)))))
+
+(define-syntax (->*2 stx)
+  (cond
+    [(->*2-handled? stx)
+     (define-values (man-dom man-dom-kwds man-lets
+                             opt-dom opt-dom-kwds opt-lets
+                             rest-ctc pre rng-ctcs post)
+       (parse->*2 stx))
+     (with-syntax ([(mandatory-dom ...) man-dom]
+                   [((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...) man-dom-kwds]
+                   [(mandatory-let-bindings ...) man-lets]
+                   [(optional-dom ...) opt-dom]
+                   [((optional-dom-kwd optional-dom-kwd-ctc) ...) opt-dom-kwds]
+                   [(optional-let-bindings ...) opt-lets]
                   [(pre-x post-x) (generate-temporaries '(pre-cond post-cond))])
       (with-syntax ([((kwd dom opt?) ...) #'((mandatory-dom-kwd mandatory-dom-kwd-ctc #f) ...
                                              (optional-dom-kwd optional-dom-kwd-ctc #t) ...)]
@ -575,7 +622,7 @@
                             #'#f)
                       #,(and post #t)
                       #,plus-one-arity-function 
-                            #,chaperone-constructor)))))])]
+                       #,chaperone-constructor))))]
    [else
     (syntax-case stx ()
       [(_ args ...)
--- a/racket/collects/racket/contract/private/provide.rkt
+++ b/racket/collects/racket/contract/private/provide.rkt
@ -13,6 +13,8 @@
                     racket/list
                     racket/struct-info
                     setup/path-to-relative
+                     "application-arity-checking.rkt"
+                     "arr-i-parse.rkt"
                     (prefix-in a: "helpers.rkt")
                     (rename-in syntax/private/boundmap
                                ;; the private version of the library
@ -56,11 +58,13 @@
  
  (struct provide/contract-info (contract-id original-id))
  
+
  (struct provide/contract-arrow-transformer provide/contract-info
    (saved-id-table 
     saved-ho-id-table 
     partially-applied-id
-     extra-neg-party-argument-fn)
+     extra-neg-party-argument-fn
+     valid-argument-lists)
    #:property
    prop:set!-transformer
    (λ (self stx)
@ -68,7 +72,8 @@
            [saved-id-table (provide/contract-arrow-transformer-saved-id-table self)]
            [saved-ho-id-table (provide/contract-arrow-transformer-saved-ho-id-table self)]
            [extra-neg-party-argument-fn 
-             (provide/contract-arrow-transformer-extra-neg-party-argument-fn self)])
+             (provide/contract-arrow-transformer-extra-neg-party-argument-fn self)]
+            [valid-arg-lists (provide/contract-arrow-transformer-valid-argument-lists self)])
        (with-syntax ([partially-applied-id partially-applied-id]
                      [extra-neg-party-argument-fn extra-neg-party-argument-fn])
          (if (eq? 'expression (syntax-local-context))
@ -85,18 +90,20 @@
                ;; Expand to a use of the lifted expression:
                (define (adjust-location new-stx)
                  (datum->syntax new-stx (syntax-e new-stx) stx new-stx))
+                (define (gen-slow-path-code)
+                  (define lifted-ctc-val
+                    (or (hash-ref saved-ho-id-table key #f)
+                        ;; No: lift the neg name creation
                        (with-syntax ([lifted-neg-party (syntax-local-introduce lifted-neg-party)])
+                          (syntax-local-introduce 
+                           (syntax-local-lift-expression
+                            #'(partially-applied-id lifted-neg-party))))))
+                  (when key (hash-set! saved-ho-id-table key lifted-ctc-val))
+                  (adjust-location (syntax-local-introduce lifted-ctc-val)))
                (syntax-case stx (set!)
                  [name 
                   (identifier? #'name)
-                     (let ([lifted-ctc-val
-                            (or (hash-ref saved-ho-id-table key #f)
-                                ;; No: lift the neg name creation
-                                (syntax-local-introduce 
-                                 (syntax-local-lift-expression
-                                  #'(partially-applied-id lifted-neg-party))))])
-                       (when key (hash-set! saved-ho-id-table key lifted-ctc-val))
-                       (adjust-location (syntax-local-introduce lifted-ctc-val)))]
+                   (gen-slow-path-code)]
                  [(set! id arg)
                   (raise-syntax-error
                    'contract/out
@ -104,15 +111,19 @@
                    stx #'id)]
                  [(name more ...)
                   (with-syntax ([app (datum->syntax stx '#%app)])
+                     (if (valid-argument-list? stx valid-arg-lists)
+                         (with-syntax ([lifted-neg-party (syntax-local-introduce lifted-neg-party)])
                           (adjust-location
                            #'(app extra-neg-party-argument-fn 
                                   lifted-neg-party
-                               more ...)))])))
+                                   more ...)))
+                         #`(app #,(gen-slow-path-code) more ...)))]))
              ;; In case of partial expansion for module-level and internal-defn
              ;; contexts, delay expansion until it's a good time to lift
              ;; expressions:
              (quasisyntax/loc stx (#%expression #,stx)))))))
  
+  
  (struct provide/contract-transformer provide/contract-info (saved-id-table partially-applied-id)
    #:property
    prop:set!-transformer
@ -167,10 +178,10 @@
                 #`(app #,id args ...))]
              [x (identifier? #'x) id])))))
  
-  (define (make-provide/contract-arrow-transformer contract-id id pai enpfn)
+  (define (make-provide/contract-arrow-transformer contract-id id pai enpfn val)
    (provide/contract-arrow-transformer contract-id id
                                        (make-hasheq) (make-hasheq)
-                                        pai enpfn)))
+                                        pai enpfn val)))


 ;; tl-code-for-one-id/new-name : syntax syntax syntax (union syntax #f) -> (values syntax syntax)
@ -234,12 +245,16 @@
                                                        srcloc-expr
                                                        contract-error-name
                                                        pos-module-source)
-  (define arrow?
+  (define-values (arrow? the-valid-app-shapes)
    (syntax-case ctrct (->2 ->*2 ->i)
-      [(->2 . _) (->2-handled? ctrct)]
-      [(->*2 . _) (->*2-handled? ctrct)]
-      [(->i . _) #t]
-      [_ #f]))
+      [(->2 . _) 
+       (->2-handled? ctrct)
+       (values #t (->-valid-app-shapes ctrct))]
+      [(->*2 . _) 
+       (values (->*2-handled? ctrct)
+               (->*-valid-app-shapes ctrct))]
+      [(->i . _) (values #t (->i-valid-app-shapes ctrct))]
+      [_ (values #f #f)]))
  (with-syntax ([id id]
                [(partially-applied-id extra-neg-party-argument-fn contract-id) 
                 (generate-temporaries (list 'idX 'idY 'idZ))]
@ -267,10 +282,11 @@
        
        (define-syntax #,id-rename
          #,(if arrow?
-                #'(make-provide/contract-arrow-transformer 
+                #`(make-provide/contract-arrow-transformer 
                   (quote-syntax contract-id) (quote-syntax id)
                   (quote-syntax partially-applied-id)
-                   (quote-syntax extra-neg-party-argument-fn))
+                   (quote-syntax extra-neg-party-argument-fn)
+                   #,the-valid-app-shapes)
                #'(make-provide/contract-transformer 
                   (quote-syntax contract-id) (quote-syntax id)
                   #f #f