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

adjust make-wrapper-class and make-wrapper-object to cooperate better with the way projections are curried

Browse Source
This commit is contained in:
Robby Findler 2018-04-09 11:23:05 -05:00
parent a48259ba29
commit 853f14b9a5
2 changed files with 37 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
racket/collects/racket/contract/private/object.rkt
View File

@ -59,11 +59,15 @@
(build-contract-property (build-contract-property
#:late-neg-projection #:late-neg-projection
(λ (ctc) (λ (ctc)
(define flds (object-contract-fields ctc))
(define fld-ctcs (object-contract-field-ctcs ctc))
(define mtds (object-contract-methods ctc))
(define mtd-ctcs (object-contract-method-ctcs ctc))
(λ (blame) (λ (blame)
(define p-app
(make-wrapper-object blame mtds mtd-ctcs))
(λ (val neg-party) (λ (val neg-party)
(make-wrapper-object ctc val blame neg-party (p-app ctc val neg-party flds fld-ctcs))))
(object-contract-methods ctc) (object-contract-method-ctcs ctc)
(object-contract-fields ctc) (object-contract-field-ctcs ctc)))))
#:name #:name
(λ (ctc) `(object-contract ,@(map (λ (fld ctc) (build-compound-type-name 'field fld ctc)) (λ (ctc) `(object-contract ,@(map (λ (fld ctc) (build-compound-type-name 'field fld ctc))
(object-contract-fields ctc) (object-contract-fields ctc)

46
racket/collects/racket/private/class-c-old.rkt
View File

@ -1458,10 +1458,9 @@
(define fields (base-object/c-fields ctc)) (define fields (base-object/c-fields ctc))
(define field-contracts (base-object/c-field-contracts ctc)) (define field-contracts (base-object/c-field-contracts ctc))
(λ (blame) (λ (blame)
(define p-app (make-wrapper-class blame methods method-contracts))
(λ (val neg-party) (λ (val neg-party)
(make-wrapper-class (p-app val neg-party fields field-contracts))))
val blame neg-party
methods method-contracts fields field-contracts))))
(define (check-object-contract obj methods fields fail) (define (check-object-contract obj methods fields fail)
(unless (object? obj) (unless (object? obj)
@ -1579,18 +1578,32 @@
;; make-wrapper-object: contract object blame neg-party ;; make-wrapper-object: contract object blame neg-party
;; (listof symbol) (listof contract?) (listof symbol) (listof contract?) ;; (listof symbol) (listof contract?) (listof symbol) (listof contract?)
;; -> wrapped object ;; -> wrapped object
(define (make-wrapper-object ctc obj blame neg-party methods method-contracts fields field-contracts) (define (make-wrapper-object blame methods method-contracts)
(check-object-contract obj methods fields (λ args (apply raise-blame-error blame obj args))) (define p-app
(let ([original-obj (if (has-original-object? obj) (original-object obj) obj)] (make-wrapper-class blame methods method-contracts))
[new-cls (make-wrapper-class (object-ref obj) ;; TODO: object-ref audit (λ (ctc obj neg-party fields field-contracts)
blame neg-party (check-object-contract obj methods fields (λ args (apply raise-blame-error blame obj args)))
methods method-contracts fields field-contracts)]) (let ([original-obj (if (has-original-object? obj) (original-object obj) obj)]
(impersonate-struct obj object-ref (λ (o c) new-cls) ;; TODO: object-ref audit [new-cls (p-app (object-ref obj) ;; TODO: object-ref audit
impersonator-prop:contracted ctc neg-party
impersonator-prop:original-object original-obj))) fields field-contracts)])
(impersonate-struct obj object-ref (λ (o c) new-cls) ;; TODO: object-ref audit
impersonator-prop:contracted ctc
impersonator-prop:original-object original-obj))))
(define (make-wrapper-class cls blame neg-party methods method-contracts fields field-contracts) (define (make-wrapper-class blame methods method-contracts)
(define method-projs
(for/list ([c (in-list method-contracts)]
[m (in-list methods)])
(cond
[(and c (not (just-check-existence? c)))
(define blame* (blame-add-context blame (format "the ~a method in" m)
#:important m))
((contract-late-neg-projection c) blame*)]
[else #f])))
(λ (cls neg-party fields field-contracts)
(let* ([name (class-name cls)] (let* ([name (class-name cls)]
[method-width (class-method-width cls)] [method-width (class-method-width cls)]
[method-ht (class-method-ht cls)] [method-ht (class-method-ht cls)]
@ -1683,14 +1696,15 @@
(vector-copy! meths 0 (class-methods cls)) (vector-copy! meths 0 (class-methods cls))
;; Now apply projections ;; Now apply projections
(for ([m (in-list methods)] (for ([m (in-list methods)]
[c (in-list method-contracts)]) [c (in-list method-contracts)]
[method-proj (in-list method-projs)])
(when c (when c
(unless (just-check-existence? c) (unless (just-check-existence? c)
(define i (hash-ref method-ht m)) (define i (hash-ref method-ht m))
(define p ((contract-late-neg-projection c) (define p ((contract-late-neg-projection c)
(blame-add-context blame (format "the ~a method in" m) (blame-add-context blame (format "the ~a method in" m)
#:important m))) #:important m)))
(vector-set! meths i (make-method (p (vector-ref meths i) neg-party) m)))))) (vector-set! meths i (make-method (method-proj (vector-ref meths i) neg-party) m))))))
;; Handle external field contracts ;; Handle external field contracts
(unless (null? fields) (unless (null? fields)
@ -1712,4 +1726,4 @@
(apply p-neg args))) (apply p-neg args)))
neg-party))))) neg-party)))))
(copy-seals cls c))) (copy-seals cls c))))