From 5dc6be1a17261d865afbddb6fa835aa7fb543b0b Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Fri, 30 Jan 2015 16:16:33 -0500
Subject: [PATCH] Allow chaperones on class methods

This allows libraries to add metadata to methods in the form
of chaperone properties which can be read by contracts on
methods.
---
 .../scribblings/reference/class.scrbl         |  6 ++++--
 .../racket-test-core/tests/racket/object.rktl | 21 +++++++++++++++++++
 .../racket/private/class-internal.rkt         | 14 +++++++++++++
 3 files changed, 39 insertions(+), 2 deletions(-)

diff --git a/pkgs/racket-doc/scribblings/reference/class.scrbl b/pkgs/racket-doc/scribblings/reference/class.scrbl
index 0bc330b7bd..7a34cb9b76 100644
--- a/pkgs/racket-doc/scribblings/reference/class.scrbl
+++ b/pkgs/racket-doc/scribblings/reference/class.scrbl
@@ -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.
 
diff --git a/pkgs/racket-test-core/tests/racket/object.rktl b/pkgs/racket-test-core/tests/racket/object.rktl
index 070cc475bc..f54fc4d493 100644
--- a/pkgs/racket-test-core/tests/racket/object.rktl
+++ b/pkgs/racket-test-core/tests/racket/object.rktl
@@ -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)
diff --git a/racket/collects/racket/private/class-internal.rkt b/racket/collects/racket/private/class-internal.rkt
index a18992df4c..2518565166 100644
--- a/racket/collects/racket/private/class-internal.rkt
+++ b/racket/collects/racket/private/class-internal.rkt
@@ -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)