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

fix scoped init names (i.e., when combined with define-local-member-name)

Browse Source 
svn: r3937
This commit is contained in:
Matthew Flatt 2006-08-02 20:14:32 +00:00
parent cbae980a66
commit 2b7a722b33
3 changed files with 92 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
collects/mzlib/private/class-internal.ss
View File

@ -414,7 +414,10 @@
(bound-identifier-mapping-get
localized-map
id
(lambda () id)))])
(lambda ()
;; If internal & external names are distinguished,
;; we need to fall back to localize:
(localize id))))])
;; ----- Expand definitions -----
(let ([defn-and-exprs (expand-all-forms stx defn-and-exprs def-ctx bind-local-id)]
@ -979,7 +982,9 @@
(if (null? l)
null
(cons pos (loop (add1 pos) (cdr l)))))]
[(plain-init-name ...) (definify plain-init-names)])
[(plain-init-name ...) (definify plain-init-names)]
[(plain-init-name-localized ...) (map lookup-localize plain-init-names)]
[(local-plain-init-name ...) (generate-temporaries plain-init-names)])
(let ([mappings
;; make-XXX-map is supplied by private/classidmap.ss
(with-syntax ([the-obj the-obj]
@ -1047,17 +1052,12 @@
(quote-syntax pubment-name-localized)
(quote pubment-temp))
...)])))]
[extra-init-mappings
(with-syntax ([(init-error-map ...)
(map (lambda (x)
(syntax init-error-map))
plain-inits)])
(syntax
([(plain-init-name ...)
(values
init-error-map
...)])))])
[extra-init-mappings (syntax
([(plain-init-name ...)
(values
(make-init-error-map (quote-syntax plain-init-name-localized))
...)]))])
(let ([find-method
(lambda (methods)
(lambda (name)
@ -1106,8 +1106,8 @@
normal-plain-init-fields))]
[inherit-field-names (map lookup-localize (map cdr inherit-fields))]
[init-names (map (lambda (norm)
(lookup-localize
(norm-init/field-eid norm)))
(lookup-localize
(norm-init/field-eid norm)))
normal-inits)]
[init-mode init-mode]
[(private-method ...) (map (find-method private-methods) (map car privates))]
@ -1281,10 +1281,15 @@
code
(cons code
(cdr (syntax-e stx)))))))])
(letrec-syntaxes+values () ([(plain-init-name) undefined]
...)
(void) ; in case the body is empty
. exprs))))))))))))
(letrec-syntaxes+values
([(plain-init-name) (make-init-redirect
(quote-syntax set!)
(quote-syntax #%app)
(quote-syntax local-plain-init-name)
(quote-syntax plain-init-name-localized))] ...)
([(local-plain-init-name) undefined] ...)
(void) ; in case the body is empty
. exprs))))))))))))
;; Not primitive:
#f))))))))))))))))

26
collects/mzlib/private/classidmap.ss
View File

@ -213,14 +213,34 @@
stx))
stx))
(define init-error-map
(make-set!-transformer
(define (make-init-error-map localized-id)
(mk-set!-trans
localized-id
(lambda (stx)
(raise-syntax-error
'class
"cannot use non-field init variable in a method"
stx))))
(define (make-init-redirect set!-stx #%app-stx local-id localized-id)
(mk-set!-trans
localized-id
(lambda (stx)
(syntax-case stx ()
[(set! id expr)
(module-identifier=? (syntax set!) set!-stx)
(with-syntax ([local-id local-id])
(syntax/loc stx (set! local-id expr)))]
[(id . args)
(with-syntax ([local-id local-id]
[#%app #%app-stx])
(syntax/loc stx (#%app local-id . args)))]
[_else (datum->syntax-object
local-id
(syntax-e local-id)
stx
stx)]))))
(define super-error-map
(lambda (stx)
(raise-syntax-error
@ -290,7 +310,7 @@
(provide (protect make-this-map make-field-map make-method-map
make-direct-method-map
make-rename-super-map make-rename-inner-map
init-error-map super-error-map
make-init-error-map make-init-redirect super-error-map
make-with-method-map
flatten-args
make-private-name localize

45
collects/tests/mzscheme/object.ss
View File

@ -1236,6 +1236,51 @@
(test '(x-d 3 (d a-val 3 #f)) 'send-b+ (send o x-d 3))
(void)))
;; ----------------------------------------
;; Localizing init names:
(let ()
(define-local-member-name the-local-name)
(define counter%
(class object%
(super-new)
(init [the-local-name 0])
(define private-field the-local-name)
(define/public (increment)
(new counter% [the-local-name (+ private-field 1)]))
(define/public (value)
private-field)))
(test 14 'send-increment (send (send (new counter% [the-local-name 13]) increment) value)))
(let ()
(define-local-member-name the-local-name)
(define counter%
(class object%
(super-new)
(init [(my-local-name the-local-name) 0])
(define private-field my-local-name)
(define/public (increment)
(new counter% [the-local-name (+ private-field 1)]))
(define/public (value)
private-field)))
(test 9 'send-increment (send (send (new counter% [the-local-name 8]) increment) value)))
;; Make sure redirect works for assignment and application:
(let ()
(define-local-member-name the-local-name)
(define c%
(class object%
(super-new)
(init the-local-name)
(define fld (list the-local-name
(the-local-name 3)
(set! the-local-name 12)
the-local-name))
(define/public (get-fld) fld)))
(test (list add1 4 (void) 12) 'send-fld (send (new c% [the-local-name add1]) get-fld)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)