From c6fc7137ee77d0cb958e599800a94483d784fe1e Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 17 Sep 2010 10:20:47 -0500 Subject: [PATCH] Adjusts the contract system so that it preserves the names of functions. closes PR 11220 Altho, this does not fix the case where a function is being passed thru another contracted function. Eg, when you give the identity function this contract: (-> (-> integer? integer?) (-> integer? integer?)) if you pass some function with a name in there, it won't come back with a name anymore (indeed, it won't even have the name anymore in the body of the function). For that, the fix would have to be put into each of the function contract combinators. --- collects/racket/contract/private/arrow.rkt | 2 +- collects/racket/contract/private/base.rkt | 27 ++++++++++++++++++---- collects/tests/racket/contract-test.rktl | 12 ++++------ 3 files changed, 29 insertions(+), 12 deletions(-) diff --git a/collects/racket/contract/private/arrow.rkt b/collects/racket/contract/private/arrow.rkt index 7ab5baee74..05fb090c29 100644 --- a/collects/racket/contract/private/arrow.rkt +++ b/collects/racket/contract/private/arrow.rkt @@ -39,7 +39,7 @@ v4 todo: procedure-accepts-and-more? check-procedure check-procedure/more - make-contracted-function) + (struct-out contracted-function)) (define-syntax-parameter making-a-method #f) (define-for-syntax (make-this-parameters id) diff --git a/collects/racket/contract/private/base.rkt b/collects/racket/contract/private/base.rkt index d083eee082..a993853e90 100644 --- a/collects/racket/contract/private/base.rkt +++ b/collects/racket/contract/private/base.rkt @@ -18,7 +18,8 @@ improve method arity mismatch contract violation error messages? unstable/srcloc unstable/location "guts.rkt" - "blame.rkt") + "blame.rkt" + "arrow.rkt") (define-syntax-parameter current-contract-region (λ (stx) #'(quote-module-path))) @@ -40,9 +41,27 @@ improve method arity mismatch contract violation error messages? (define (apply-contract c v pos neg name loc usr) (let ([c (coerce-contract 'contract c)]) (check-source-location! 'contract loc) - (((contract-projection c) - (make-blame loc name (contract-name c) pos neg usr #t)) - v))) + (let ([new-val + (((contract-projection c) + (make-blame loc name (contract-name c) pos neg usr #t)) + v)]) + (if (and name + (not (parameter? new-val)) ;; when PR 11221 is fixed, remove this line + (procedure? new-val) + (not (eq? name (object-name new-val)))) + (cond + [(contracted-function? new-val) + ;; when PR11222 is fixed, change these things: + ;; - eliminate this cond case + ;; - remove the require of arrow.rkt above + ;; - change (struct-out contracted-function) + ;; in arrow.rkt to make-contracted-function + (make-contracted-function + (procedure-rename (contracted-function-proc new-val) name) + (contracted-function-ctc new-val))] + [else + (procedure-rename new-val name)]) + new-val)))) (define-syntax (recursive-contract stx) (syntax-case stx () diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 7f7f3180ae..4c0e672dba 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -9066,11 +9066,11 @@ so that propagation occurs. ; (contract-eval - '(module contract-test-suite-inferred-name1 scheme/base - (require scheme/contract) + '(module contract-test-suite-inferred-name1 racket/base + (require racket/contract) (define contract-inferred-name-test-contract (-> integer? any)) - (define (contract-inferred-name-test x) #t) - (provide/contract (contract-inferred-name-test contract-inferred-name-test-contract)) + (define (contract-inferred-name-test1 x) #t) + (provide/contract (contract-inferred-name-test1 contract-inferred-name-test-contract)) (define (contract-inferred-name-test2 x) x) (provide/contract (contract-inferred-name-test2 (-> number? number?))) @@ -9086,17 +9086,15 @@ so that propagation occurs. (define (contract-inferred-name-test5) 7) (provide/contract (contract-inferred-name-test5 (->i () () any))) - )) (contract-eval '(require 'contract-test-suite-inferred-name1)) - ;; (eval '(test 'contract-inferred-name-test object-name contract-inferred-name-test)) ;; this one can't be made to pass, sadly. + (test 'contract-inferred-name-test1 object-name (contract-eval 'contract-inferred-name-test1)) (test 'contract-inferred-name-test2 object-name (contract-eval 'contract-inferred-name-test2)) (test 'contract-inferred-name-test2b object-name (contract-eval 'contract-inferred-name-test2b)) (test 'contract-inferred-name-test3 object-name (contract-eval 'contract-inferred-name-test3)) (test 'contract-inferred-name-test4 object-name (contract-eval 'contract-inferred-name-test4)) (test 'contract-inferred-name-test5 object-name (contract-eval 'contract-inferred-name-test5)) - ; ;