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

adjust the expansion of class so that it tracks identifiers

Browse Source 
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.
This commit is contained in:
Robby Findler 2012-08-17 08:39:08 -05:00
parent 5a2c235739
commit 52f18ee370
2 changed files with 208 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -380,12 +380,8 @@
(begin (begin
(map bind-local-id (syntax->list #'(id ...))) (map bind-local-id (syntax->list #'(id ...)))
(cons e (loop (cdr l))))] (cons e (loop (cdr l))))]
[(begin . _) [_else
(raise-syntax-error (cons e (loop (cdr l)))]))))))
#f
"ill-formed begin expression"
e)]
[_else (cons e (loop (cdr l)))]))))))
;; returns two lists: expressions that start with an identifier in ;; returns two lists: expressions that start with an identifier in
;; `kws', and expressions that don't ;; `kws', and expressions that don't
@ -533,9 +529,12 @@
(lambda (the-obj . vars) (lambda (the-obj . vars)
(let-syntax ([the-finder (quote-syntax the-obj)]) (let-syntax ([the-finder (quote-syntax the-obj)])
body1 body ...)))]) body1 body ...)))])
(syntax-track-origin
(with-syntax ([l (rearm (add-method-property l) stx)]) (with-syntax ([l (rearm (add-method-property l) stx)])
(syntax/loc stx (syntax/loc stx
(let ([name l]) name)))))) (let ([name l]) name)))
stx
(syntax-local-introduce #'lam)))))
stx)] stx)]
[(#%plain-lambda . _) [(#%plain-lambda . _)
(bad "ill-formed lambda expression for method" stx)] (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)]
[(λ . _) [(λ . _)
(bad "ill-formed lambda expression for method" stx)] (bad "ill-formed lambda expression for method" stx)]
[(case-lambda [vars body1 body ...] ...) [(case-lam [vars body1 body ...] ...)
(andmap vars-ok? (syntax->list (syntax (vars ...)))) (and (free-identifier=? #'case-lam #'case-lambda)
(andmap vars-ok? (syntax->list (syntax (vars ...)))))
(if xform? (if xform?
(with-syntax ([the-obj the-obj] (with-syntax ([the-obj the-obj]
[the-finder the-finder] [the-finder the-finder]
@ -553,9 +553,12 @@
(case-lambda [(the-obj . vars) (case-lambda [(the-obj . vars)
(let-syntax ([the-finder (quote-syntax the-obj)]) (let-syntax ([the-finder (quote-syntax the-obj)])
body1 body ...)] ...))]) body1 body ...)] ...))])
(syntax-track-origin
(with-syntax ([cl (rearm (add-method-property cl) stx)]) (with-syntax ([cl (rearm (add-method-property cl) stx)])
(syntax/loc stx (syntax/loc stx
(let ([name cl]) name))))) (let ([name cl]) name)))
stx
(syntax-local-introduce #'case-lam))))
stx)] stx)]
[(case-lambda . _) [(case-lambda . _)
(bad "ill-formed case-lambda expression for method" stx)] (bad "ill-formed case-lambda expression for method" stx)]
@ -612,6 +615,7 @@
ids new-ids) ids new-ids)
null)] null)]
[body body]) [body body])
(syntax-track-origin
(rearm (rearm
(if xform? (if xform?
(if letrec? (if letrec?
@ -623,7 +627,9 @@
body)))) body))))
(syntax/loc stx (let- ([(new-id) proc] ...) (syntax/loc stx (let- ([(new-id) proc] ...)
body))) body)))
stx)))] stx)
stx
(syntax-local-introduce #'let-))))]
[_else [_else
(if can-expand? (if can-expand?
(loop (expand stx locals) #f name locals) (loop (expand stx locals) #f name locals)
@ -920,6 +926,28 @@
[(rename-inners) [(rename-inners)
(flatten pair (extract* (list (quote-syntax -rename-inner)) decls))]) (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: ;; At most one inspect:
(unless (or (null? inspect-decls) (unless (or (null? inspect-decls)
(null? (cdr inspect-decls))) (null? (cdr inspect-decls)))
@ -1000,7 +1028,8 @@
(if (null? exprs) (if (null? exprs)
(values (reverse ms) (reverse pms) (reverse es) (reverse sd)) (values (reverse ms) (reverse pms) (reverse es) (reverse sd))
(syntax-case (car exprs) (define-values define-syntaxes) (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 ...)))]) (let ([ids (syntax->list (syntax (id ...)))])
;; Check form: ;; Check form:
(for-each (lambda (id) (for-each (lambda (id)
@ -1017,10 +1046,14 @@
(unless (null? (cdr ids)) (unless (null? (cdr ids))
(bad "each method variable needs its own definition" (bad "each method variable needs its own definition"
(car exprs))) (car exprs)))
(let ([expr (proc-shape #f (syntax expr) #f (let ([expr
(syntax-track-origin
(proc-shape #f (syntax expr) #f
the-obj the-finder the-obj the-finder
bad class-name expand-stop-names bad class-name expand-stop-names
def-ctx lookup-localize)] def-ctx lookup-localize)
(car exprs)
(syntax-local-introduce #'d-v))]
[public? (ormap (lambda (i) [public? (ormap (lambda (i)
(bound-identifier=? i (car ids))) (bound-identifier=? i (car ids)))
local-public-names)]) local-public-names)])
@ -1156,9 +1189,12 @@
;; Non-method definitions to set! ;; Non-method definitions to set!
;; Initializations args access/set! ;; Initializations args access/set!
(let ([exprs (map (lambda (e) (let ([exprs (map (lambda (e)
(syntax-case e (define-values -field -init-rest) (syntax-case e ()
[(define-values (id ...) expr) [(d-v (id ...) expr)
(syntax/loc e (set!-values (id ...) expr))] (free-identifier=? #'d-v #'define-values)
(syntax-track-origin (syntax/loc e (set!-values (id ...) expr))
e
#'d-v)]
[(_init orig idp ...) [(_init orig idp ...)
(and (identifier? (syntax _init)) (and (identifier? (syntax _init))
(ormap (lambda (it) (ormap (lambda (it)
@ -1179,28 +1215,40 @@
(syntax (lambda () defexp))))) (syntax (lambda () defexp)))))
norms)] norms)]
[class-name class-name]) [class-name class-name])
(syntax-track-origin
(syntax/loc e (syntax/loc e
(begin (begin
1 ; to ensure a non-empty body 1 ; to ensure a non-empty body
(set! id (extract-arg 'class-name `idpos init-args defval)) (set! id (extract-arg 'class-name `idpos init-args defval))
...))))] ...))
[(-field orig idp ...) e
#'_init)))]
[(-fld orig idp ...)
(free-identifier=? #'-fld #'-field)
(with-syntax ([(((iid eid) expr) ...) (with-syntax ([(((iid eid) expr) ...)
(map normalize-init/field (syntax->list #'(idp ...)))]) (map normalize-init/field (syntax->list #'(idp ...)))])
(syntax-track-origin
(syntax/loc e (begin (syntax/loc e (begin
1 ; to ensure a non-empty body 1 ; to ensure a non-empty body
(set! iid expr) (set! iid expr)
...)))] ...))
[(-init-rest id/rename) e
#'-fld))]
[(-i-r id/rename)
(free-identifier=? #'-i-r #'-init-rest)
(with-syntax ([n (+ (length plain-inits) (with-syntax ([n (+ (length plain-inits)
(length plain-init-fields) (length plain-init-fields)
-1)] -1)]
[id (if (identifier? #'id/rename) [id (if (identifier? #'id/rename)
#'id/rename #'id/rename
(stx-car #'id/rename))]) (stx-car #'id/rename))])
(syntax/loc e (set! id (extract-rest-args n init-args))))] (syntax-track-origin
[(-init-rest) (syntax/loc e (set! id (extract-rest-args n init-args)))
(syntax (void))] e
#'-i-r))]
[(-i-r)
(free-identifier=? #'-i-r #'-init-rest)
(syntax-track-origin (syntax (void)) e #'-i-r)]
[_else e])) [_else e]))
exprs)] exprs)]
[mk-method-temp [mk-method-temp
@ -1437,7 +1485,7 @@
(stx-car (stx-cdr (car inspect-decls))) (stx-car (stx-cdr (car inspect-decls)))
#'(current-inspector))] #'(current-inspector))]
[deserialize-id-expr deserialize-id-expr]) [deserialize-id-expr deserialize-id-expr])
(add-decl-props
(quasisyntax/loc stx (quasisyntax/loc stx
(let ([superclass super-expression] (let ([superclass super-expression]
[interfaces (list interface-expression ...)]) [interfaces (list interface-expression ...)])
@ -1605,7 +1653,7 @@
(void) ; in case the body is empty (void) ; in case the body is empty
. exprs))))))))))))) . exprs)))))))))))))
;; Not primitive: ;; Not primitive:
#f)))))))))))))))) #f)))))))))))))))))
;; The class* and class entry points: ;; The class* and class entry points:
(values (values

111
collects/tests/racket/object.rktl
View File

@ -1690,6 +1690,116 @@
(err/rt-test (send (new required%) m 1 2 3) given-3?) (err/rt-test (send (new required%) m 1 2 3) given-3?)
(err/rt-test (send (new optional%) 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) (report-errs)