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

made class/c use the name from the context for the name of the contract, when available

Browse Source
This commit is contained in:
Robby Findler 2012-04-06 16:17:24 -05:00
parent 483dde9ea8
commit 1a9ab0b018
2 changed files with 76 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
collects/racket/private/class-internal.rkt
View File

@ -2966,13 +2966,14 @@
inherits inherit-contracts inherit-fields inherit-field-contracts inherits inherit-contracts inherit-fields inherit-field-contracts
supers super-contracts inners inner-contracts supers super-contracts inners inner-contracts
overrides override-contracts augments augment-contracts overrides override-contracts augments augment-contracts
augrides augride-contracts absents absent-fields opaque?) augrides augride-contracts absents absent-fields opaque? name)
#:omit-define-syntaxes #:omit-define-syntaxes
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:projection class/c-proj #:projection class/c-proj
#:name #:name
(λ (ctc) (λ (ctc)
(or (class/c-name ctc)
(let* ([pair-ids-ctcs (let* ([pair-ids-ctcs
(λ (is ctcs) (λ (is ctcs)
(for/list ([i (in-list is)] (for/list ([i (in-list is)]
@ -3013,7 +3014,7 @@
(handle-optional 'override (class/c-overrides ctc) (class/c-override-contracts ctc)) (handle-optional 'override (class/c-overrides ctc) (class/c-override-contracts ctc))
(handle-optional 'augment (class/c-augments ctc) (class/c-augment-contracts ctc)) (handle-optional 'augment (class/c-augments ctc) (class/c-augment-contracts ctc))
(handle-optional 'augride (class/c-augrides ctc) (class/c-augride-contracts ctc)) (handle-optional 'augride (class/c-augrides ctc) (class/c-augride-contracts ctc))
(handle-absents (class/c-absents ctc) (class/c-absent-fields ctc)))))) (handle-absents (class/c-absents ctc) (class/c-absent-fields ctc)))))))
#:first-order #:first-order
(λ (ctc) (λ (ctc)
(λ (cls) (λ (cls)
@ -3201,6 +3202,17 @@
[augride-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augride-contracts null)))] [augride-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augride-contracts null)))]
[absents #`(list #,@(reverse (hash-ref parsed-forms 'absents null)))] [absents #`(list #,@(reverse (hash-ref parsed-forms 'absents null)))]
[absent-fields #`(list #,@(reverse (hash-ref parsed-forms 'absent-fields null)))]) [absent-fields #`(list #,@(reverse (hash-ref parsed-forms 'absent-fields null)))])
(with-syntax ([name
;; same as syntax-local-infer-name, except doesn't
;; make a name up from the src loc; in that case,
;; we just use the big ole (class/c ...)-based name
(or (let loop ([prop (syntax-property stx 'inferred-name)])
(cond
[(symbol? prop) prop]
[(pair? prop) (or (loop (car prop))
(loop (cdr prop)))]
[else #f]))
(syntax-local-name))])
(syntax/loc stx (syntax/loc stx
(let* ([inits+contracts (sort (list (cons i i-c) ...) (let* ([inits+contracts (sort (list (cons i i-c) ...)
(lambda (s1 s2) (lambda (s1 s2)
@ -3217,7 +3229,8 @@
augments augment-ctcs augments augment-ctcs
augrides augride-ctcs augrides augride-ctcs
absents absent-fields absents absent-fields
opaque?)))))])) opaque?
'name))))))]))
(define (check-object-contract obj methods fields fail) (define (check-object-contract obj methods fields fail)
(unless (object? obj) (unless (object? obj)

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

@ -10256,6 +10256,10 @@ so that propagation occurs.
(test-name '(set/c (set/c char?) #:cmp 'eqv) (set/c (set/c char? #:cmp 'dont-care) #:cmp 'eqv)) (test-name '(set/c (set/c char?) #:cmp 'eqv) (set/c (set/c char? #:cmp 'dont-care) #:cmp 'eqv))
(test-name '(set/c (-> char? char?) #:cmp 'equal) (set/c (-> char? char?) #:cmp 'equal)) (test-name '(set/c (-> char? char?) #:cmp 'equal) (set/c (-> char? char?) #:cmp 'equal))
(test-name '(class/c [m (->m integer? integer?)]) (class/c [m (->m integer? integer?)]))
(test-name 'c%/c (let ([c%/c (class/c [m (->m integer? integer?)])])
c%/c))
;; NOT YET RELEASED ;; NOT YET RELEASED
#; #;
(test-name '(pr/dc [x integer?] (test-name '(pr/dc [x integer?]