From 52f18ee370f1f33e5d14774282acb7a775d9d394 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 17 Aug 2012 08:39:08 -0500
Subject: [PATCH] adjust the expansion of class so that it tracks identifiers
 that it drops from the expansion (like define/public) by adding them to the
 origin syntax property (and sometimes to disappeared-use; see the
 add-decl-props function for details on those that aren't in the origin
 property)

this means that check syntax will now pick them up
so they'll show up in the blue boxes in drracket

Thanks Matthew, for some helpful advice and
comments on an initial version of the commit.
---
 collects/racket/private/class-internal.rkt | 148 ++++++++++++++-------
 collects/tests/racket/object.rktl          | 111 +++++++++++++++-
 2 files changed, 208 insertions(+), 51 deletions(-)

diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt
index ee79e98430..a75049e035 100644
--- a/collects/racket/private/class-internal.rkt
+++ b/collects/racket/private/class-internal.rkt
@@ -380,12 +380,8 @@
                    (begin
                      (map bind-local-id (syntax->list #'(id ...)))
                      (cons e (loop (cdr l))))]
-                  [(begin . _)
-                   (raise-syntax-error 
-                    #f
-                    "ill-formed begin expression"
-                    e)]
-                  [_else (cons e (loop (cdr l)))]))))))
+                  [_else 
+                   (cons e (loop (cdr l)))]))))))
     
     ;; returns two lists: expressions that start with an identifier in
     ;; `kws', and expressions that don't
@@ -533,9 +529,12 @@
                               (lambda (the-obj . vars) 
                                 (let-syntax ([the-finder (quote-syntax the-obj)])
                                   body1 body ...)))])
-                     (with-syntax ([l (rearm (add-method-property l) stx)])
-                       (syntax/loc stx 
-                         (let ([name l]) name))))))
+                     (syntax-track-origin
+                      (with-syntax ([l (rearm (add-method-property l) stx)])
+                        (syntax/loc stx 
+                          (let ([name l]) name)))                  
+                      stx
+                      (syntax-local-introduce #'lam)))))
                stx)]
           [(#%plain-lambda . _)
            (bad "ill-formed lambda expression for method" stx)]
@@ -543,8 +542,9 @@
            (bad "ill-formed lambda expression for method" stx)]
           [(λ . _)
            (bad "ill-formed lambda expression for method" stx)]
-          [(case-lambda [vars body1 body ...] ...)
-           (andmap vars-ok? (syntax->list (syntax (vars ...))))
+          [(case-lam [vars body1 body ...] ...)
+           (and (free-identifier=? #'case-lam #'case-lambda)
+                (andmap vars-ok? (syntax->list (syntax (vars ...)))))
            (if xform?
                (with-syntax ([the-obj the-obj]
                              [the-finder the-finder]
@@ -553,9 +553,12 @@
                              (case-lambda [(the-obj . vars) 
                                            (let-syntax ([the-finder (quote-syntax the-obj)])
                                              body1 body ...)] ...))])
-                   (with-syntax ([cl (rearm (add-method-property cl) stx)])
-                     (syntax/loc stx
-                       (let ([name cl]) name)))))
+                   (syntax-track-origin 
+                    (with-syntax ([cl (rearm (add-method-property cl) stx)])
+                      (syntax/loc stx
+                        (let ([name cl]) name)))
+                    stx
+                    (syntax-local-introduce #'case-lam))))
                stx)]
           [(case-lambda . _)
            (bad "ill-formed case-lambda expression for method" stx)]
@@ -612,18 +615,21 @@
                                  ids new-ids)
                                 null)]
                            [body body])
-               (rearm
-                (if xform?
-                    (if letrec?
-                        (syntax/loc stx (letrec-syntax mappings
-                                          (let- ([(new-id) proc] ...) 
-                                                body)))
-                        (syntax/loc stx (let- ([(new-id) proc] ...) 
-                                              (letrec-syntax mappings
-                                                body))))
-                    (syntax/loc stx (let- ([(new-id) proc] ...) 
-                                          body)))
-                stx)))]
+               (syntax-track-origin
+                (rearm
+                 (if xform?
+                     (if letrec?
+                         (syntax/loc stx (letrec-syntax mappings
+                                           (let- ([(new-id) proc] ...) 
+                                                 body)))
+                         (syntax/loc stx (let- ([(new-id) proc] ...) 
+                                               (letrec-syntax mappings
+                                                 body))))
+                     (syntax/loc stx (let- ([(new-id) proc] ...) 
+                                           body)))
+                 stx)
+                stx
+                (syntax-local-introduce #'let-))))]
           [_else 
            (if can-expand?
                (loop (expand stx locals) #f name locals)
@@ -920,6 +926,28 @@
                           [(rename-inners)
                            (flatten pair (extract* (list (quote-syntax -rename-inner)) decls))])
               
+              ;; this function copies properties from the declarations expressions
+              ;; that get dropped from a class form (e.g. (public x) from the body
+              ;; of a class). It doesn't use syntax-track-origin because there is
+              ;; no residual code that it would make sense to be the result of expanding
+              ;; those away. So, instead we only look at a few properties (as below).
+              (define (add-decl-props stx)
+                (for/fold ([stx stx])
+                          ([decl (in-list (append inspect-decls decls))])
+                  (define (copy-prop src dest stx)
+                    (syntax-property 
+                     stx
+                     dest
+                     (cons (syntax-property decl src)
+                           (syntax-property stx dest))))
+                  (copy-prop
+                   'origin 'disappeared-use
+                   (copy-prop
+                    'disappeared-use 'disappeared-use
+                    (copy-prop
+                     'disappeared-binding 'disappeared-binding
+                     stx)))))
+              
               ;; At most one inspect:
               (unless (or (null? inspect-decls)
                           (null? (cdr inspect-decls)))
@@ -1000,7 +1028,8 @@
                                 (if (null? exprs)
                                     (values (reverse ms) (reverse pms) (reverse es) (reverse sd))
                                     (syntax-case (car exprs) (define-values define-syntaxes)
-                                      [(define-values (id ...) expr)
+                                      [(d-v (id ...) expr)
+                                       (free-identifier=? #'d-v #'define-values)
                                        (let ([ids (syntax->list (syntax (id ...)))])
                                          ;; Check form:
                                          (for-each (lambda (id)
@@ -1017,10 +1046,14 @@
                                                (unless (null? (cdr ids))
                                                  (bad "each method variable needs its own definition"
                                                       (car exprs)))
-                                               (let ([expr (proc-shape #f (syntax expr) #f 
-                                                                       the-obj the-finder
-                                                                       bad class-name expand-stop-names
-                                                                       def-ctx lookup-localize)]
+                                               (let ([expr 
+                                                      (syntax-track-origin
+                                                       (proc-shape #f (syntax expr) #f 
+                                                                   the-obj the-finder
+                                                                   bad class-name expand-stop-names
+                                                                   def-ctx lookup-localize)
+                                                       (car exprs)
+                                                       (syntax-local-introduce #'d-v))]
                                                      [public? (ormap (lambda (i) 
                                                                        (bound-identifier=? i (car ids)))
                                                                      local-public-names)])
@@ -1156,9 +1189,12 @@
                     ;;  Non-method definitions to set!
                     ;;  Initializations args access/set!
                     (let ([exprs (map (lambda (e)
-                                        (syntax-case e (define-values -field -init-rest)
-                                          [(define-values (id ...) expr)
-                                           (syntax/loc e (set!-values (id ...) expr))]
+                                        (syntax-case e ()
+                                          [(d-v (id ...) expr)
+                                           (free-identifier=? #'d-v #'define-values)
+                                           (syntax-track-origin (syntax/loc e (set!-values (id ...) expr))
+                                                                e
+                                                                #'d-v)]
                                           [(_init orig idp ...)
                                            (and (identifier? (syntax _init))
                                                 (ormap (lambda (it) 
@@ -1179,28 +1215,40 @@
                                                                          (syntax (lambda () defexp)))))
                                                                  norms)]
                                                            [class-name class-name])
-                                               (syntax/loc e 
-                                                 (begin 
-                                                   1 ; to ensure a non-empty body
-                                                   (set! id (extract-arg 'class-name `idpos init-args defval))
-                                                   ...))))]
-                                          [(-field orig idp ...)
+                                               (syntax-track-origin
+                                                (syntax/loc e 
+                                                  (begin 
+                                                    1 ; to ensure a non-empty body
+                                                    (set! id (extract-arg 'class-name `idpos init-args defval))
+                                                    ...))
+                                                e
+                                                #'_init)))]
+                                          [(-fld orig idp ...)
+                                           (free-identifier=? #'-fld #'-field)
                                            (with-syntax ([(((iid eid) expr) ...)
                                                           (map normalize-init/field (syntax->list #'(idp ...)))])
-                                             (syntax/loc e (begin 
-                                                             1 ; to ensure a non-empty body
-                                                             (set! iid expr)
-                                                             ...)))]
-                                          [(-init-rest id/rename)
+                                             (syntax-track-origin
+                                              (syntax/loc e (begin 
+                                                              1 ; to ensure a non-empty body
+                                                              (set! iid expr)
+                                                              ...))
+                                              e
+                                              #'-fld))]
+                                          [(-i-r id/rename)
+                                           (free-identifier=? #'-i-r #'-init-rest)
                                            (with-syntax ([n (+ (length plain-inits)
                                                                (length plain-init-fields)
                                                                -1)]
                                                          [id (if (identifier? #'id/rename)
                                                                  #'id/rename
                                                                  (stx-car #'id/rename))])
-                                             (syntax/loc e (set! id (extract-rest-args n init-args))))]
-                                          [(-init-rest)
-                                           (syntax (void))]
+                                             (syntax-track-origin
+                                              (syntax/loc e (set! id (extract-rest-args n init-args)))
+                                              e
+                                              #'-i-r))]
+                                          [(-i-r)
+                                           (free-identifier=? #'-i-r #'-init-rest)
+                                           (syntax-track-origin (syntax (void)) e #'-i-r)]
                                           [_else e]))
                                       exprs)]
                           [mk-method-temp
@@ -1437,7 +1485,7 @@
                                                          (stx-car (stx-cdr (car inspect-decls)))
                                                          #'(current-inspector))]
                                           [deserialize-id-expr deserialize-id-expr])
-                              
+                              (add-decl-props
                               (quasisyntax/loc stx
                                 (let ([superclass super-expression]
                                       [interfaces (list interface-expression ...)])
@@ -1605,7 +1653,7 @@
                                                         (void) ; in case the body is empty
                                                         . exprs)))))))))))))
                                    ;; Not primitive:
-                                   #f))))))))))))))))
+                                   #f)))))))))))))))))
     
     ;; The class* and class entry points:
     (values
diff --git a/collects/tests/racket/object.rktl b/collects/tests/racket/object.rktl
index a46ea53cd4..d812ab1694 100644
--- a/collects/tests/racket/object.rktl
+++ b/collects/tests/racket/object.rktl
@@ -1690,6 +1690,116 @@
   (err/rt-test (send (new required%) m 1 2 3) given-3?)
   (err/rt-test (send (new optional%) m 1 2 3) given-3?))
 
+;; ----------------------------------------
+;; Origin tracking
+
+(let ()
+  ;; tries to find each of 'searching-for' in the
+  ;; origin property of the fully expanded version
+  ;; of stx. Returns the ones it cannot find.
+  (define (search-prop property stx . searching-for)
+    (define (check-prop o)
+      (let loop ([o o])
+        (cond
+          [(pair? o)
+           (loop (car o))
+           (loop (cdr o))]
+          [(identifier? o)
+           (set! searching-for 
+                 (filter (λ (x) (not (free-identifier=? x o)))
+                         searching-for))])))
+    
+    (let loop ([stx (expand stx)])
+      (cond
+        [(pair? stx)
+         (loop (car stx))
+         (loop (cdr stx))]
+        [(syntax? stx)
+         (check-prop (syntax-property stx property))
+         (loop (syntax-e stx))]))
+    
+    searching-for)
+  
+  (test '() search-prop 'origin
+        '(class object%)
+        #'class)
+  (test '() search-prop 'disappeared-use
+        '(class object% (inherit m)) 
+        #'inherit)
+  (test '() search-prop 'origin
+        '(class object% (super-new)) #'super-new)
+  (test '() search-prop 'disappeared-use
+        '(class* object% () (inherit m))
+        #'inherit)
+  (test '() search-prop 'origin
+        '(mixin () () (define/private (m x) x))
+        #'define/private)
+  (test '() search-prop 'origin
+        '(class object% (super-make-object))
+        #'super-make-object)
+  (test '() search-prop 'origin
+        '(class object% (define/public (m x) x))
+        #'define/public)
+  (test '() search-prop 'origin
+        '(class object% (define/public m (lambda (x) x)))
+        #'define/public
+        #'lambda)
+  (test '() search-prop 'origin
+        '(class object% (define/augment m (lambda (x) x)))
+        #'define/augment
+        #'lambda)
+  (test '() search-prop 'origin
+        '(class object% (define/override (m x) (super m x)))
+        #'define/override
+        #'super)
+  (test '() search-prop 'origin 
+        '(class object% (define/augment (m x) (inner 1 m x)))
+        #'define/augment
+        #'inner)
+  (test '() search-prop 'origin
+        '(class object% (define f 11))
+        #'define)
+  (test '() search-prop 'origin
+        '(class object% (public f) (define f (λ (x) x)))
+        #'define
+        #'λ)
+  (test '() search-prop 'disappeared-use
+        '(class object% (public f) (define f (λ (x) x)))
+        #'public)
+  (test '() search-prop 'origin
+        '(class object% (private f) (define f (λ (x) x)))
+        #'define
+        #'λ)
+  (test '() search-prop 'disappeared-use
+        '(class object% (private f) (define f (λ (x) x)))
+        #'private)
+  (test '() search-prop 'origin
+        '(class object%
+           (begin
+             (define/public (m x) x)
+             (define/private (n x) x)))
+        #'begin
+        #'define/public
+        #'define/private)
+  (test '() search-prop 'disappeared-use
+        '(class object% (inspect #f))
+        #'inspect)
+  (test '() search-prop 'origin
+        '(class object% (field [x #f]))
+        #'field)
+  (test '() search-prop 'origin
+        '(class object% (init x))
+        #'init)
+  (test '() search-prop 'origin
+        '(class object% (init-field x))
+        #'init-field)
+  (test '() search-prop 'origin
+        '(class object% (init-rest args))
+        #'init-rest)
+  (test '() search-prop 'origin
+        '(class object% (init-rest))
+        #'init-rest))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 ;; ----------------------------------------
@@ -1713,4 +1823,3 @@
 
 
 (report-errs)
-