suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Adjusts the contract system so that it preserves the names of functions.

Browse Source 
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.
This commit is contained in:
Robby Findler 2010-09-17 10:20:47 -05:00
parent c1c1461596
commit c6fc7137ee
3 changed files with 29 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/racket/contract/private/arrow.rkt
View File

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

27
collects/racket/contract/private/base.rkt
View File

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

12
collects/tests/racket/contract-test.rktl
View File

@ -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,10 +9086,9 @@ 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))
@ -9097,7 +9096,6 @@ so that propagation occurs.
(test 'contract-inferred-name-test5 object-name (contract-eval 'contract-inferred-name-test5))
;
;
;