From 297db9b305a1caa94001e3b2b69546bd0c6e8a92 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 19 Feb 2012 16:17:33 -0600 Subject: [PATCH] fix bug introduced recently by special cases for -> --- collects/racket/contract/private/arrow.rkt | 2 ++ collects/tests/racket/contract-test.rktl | 26 ++++++++++++++++++++++ 2 files changed, 28 insertions(+) diff --git a/collects/racket/contract/private/arrow.rkt b/collects/racket/contract/private/arrow.rkt index 968572317e..7655691c2d 100644 --- a/collects/racket/contract/private/arrow.rkt +++ b/collects/racket/contract/private/arrow.rkt @@ -2030,12 +2030,14 @@ v4 todo: (define-syntax (-> stx) (syntax-case stx (any any/c boolean?) [(_ any/c ... any) + (not (syntax-parameter-value #'making-a-method)) ;; special case the (-> any/c ... any) contracts to be first-order checks only (with-syntax ([dom-len (- (length (syntax->list stx)) 2)] [name (syntax->datum stx)]) #'(flat-named-contract 'name (λ (x) (and (procedure? x) (procedure-arity-includes? x dom-len #t)))))] [(_ any/c boolean?) ;; special case (-> any/c boolean?) to use predicate/c + (not (syntax-parameter-value #'making-a-method)) #'-predicate/c] [_ #`(syntax-parameterize ((making-a-method #f)) #,(->/proc/main stx))])) diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 2024e77ede..2c997253e2 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -6273,6 +6273,32 @@ m 5)) + (test/spec-passed/result + 'object-contract/arrow-special-case1 + '(send (contract (object-contract + [m (-> any/c boolean?)]) + (new (class object% + (define/public (m x) #t) + (super-new))) + 'pos + 'neg) + m 1) + #t) + + (test/spec-passed/result + 'object-contract/arrow-special-case2 + '(send (contract (object-contract + [m (-> any/c any)]) + (new (class object% + (define/public (m x) #t) + (super-new))) + 'pos + 'neg) + m 1) + #t) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; test error message has right format