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

Allow chaperones on class methods

Browse Source 
This allows libraries to add metadata to methods in the form
of chaperone properties which can be read by contracts on
methods.
This commit is contained in:
Asumu Takikawa 2015-01-30 16:16:33 -05:00
parent c5e9f42cee
commit 5dc6be1a17
3 changed files with 39 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
pkgs/racket-doc/scribblings/reference/class.scrbl
View File

@ -252,7 +252,7 @@ interface @racket[(class->interface object%)], and is transparent
public pubment public-final override override-final overment augment augride
augment-final private abstract inherit inherit/super inherit/inner
rename-super rename-inner begin lambda case-lambda let-values letrec-values
define-values #%plain-lambda)
define-values #%plain-lambda chaperone-procedure)
(class* superclass-expr (interface-expr ...)
class-clause
...)
@ -314,7 +314,9 @@ interface @racket[(class->interface object%)], and is transparent
(let-values ([(id) method-procedure] ...+)
id)
(letrec-values ([(id) method-procedure] ...+)
id)])]{
id)
(chaperone-procedure method-procedure wrapper-proc
other-arg-expr ...)])]{
Produces a class value.

21
pkgs/racket-test-core/tests/racket/object.rktl
View File

@ -2054,6 +2054,27 @@
(void))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Test chaperone-procedure on method definitions
(test #t class? (class object% (public m) (define m (chaperone-procedure (λ (x) x) values))))
(test #t class? (class object%
(public m)
(define m
(chaperone-procedure (case-lambda [(x) x]) values))))
(test #t class? (class object%
(public m)
(define m
(let-values ([(m) (chaperone-procedure (λ (x) x) values)])
m))))
(test #t zero? (send (new (class object%
(super-new)
(public m)
(define m
(let-values ([(m) (chaperone-procedure (λ () 0) values)])
m))))
m))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)

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

@ -632,6 +632,20 @@
stx)
stx
(syntax-local-introduce #'let-))))]
[(-#%app -chaperone-procedure expr . rst)
(and (free-identifier=? (syntax -#%app)
(quote-syntax #%plain-app))
(or (free-identifier=? (syntax -chaperone-procedure)
(quote-syntax chaperone-procedure))
(free-identifier=? (syntax -chaperone-procedure)
(quote-syntax chaperone-procedure))))
(with-syntax ([expr (loop #'expr #t name locals)])
(syntax-track-origin
(rearm
(syntax/loc stx (-#%app -chaperone-procedure expr . rst))
stx)
stx
(syntax-local-introduce #'-#%app)))]
[_else
(if can-expand?
(loop (expand stx locals) #f name locals)