From 2b7a722b3381ab0ddf163fcd80cc15965775465c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 2 Aug 2006 20:14:32 +0000 Subject: [PATCH] fix scoped init names (i.e., when combined with define-local-member-name) svn: r3937 --- collects/mzlib/private/class-internal.ss | 43 ++++++++++++---------- collects/mzlib/private/classidmap.ss | 26 ++++++++++++-- collects/tests/mzscheme/object.ss | 45 ++++++++++++++++++++++++ 3 files changed, 92 insertions(+), 22 deletions(-) diff --git a/collects/mzlib/private/class-internal.ss b/collects/mzlib/private/class-internal.ss index f8ce686c38..ab064932cd 100644 --- a/collects/mzlib/private/class-internal.ss +++ b/collects/mzlib/private/class-internal.ss @@ -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)))))))))))))))) diff --git a/collects/mzlib/private/classidmap.ss b/collects/mzlib/private/classidmap.ss index e62334964f..7e2721cebc 100644 --- a/collects/mzlib/private/classidmap.ss +++ b/collects/mzlib/private/classidmap.ss @@ -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 diff --git a/collects/tests/mzscheme/object.ss b/collects/tests/mzscheme/object.ss index 4d5cc4474c..e8fe3cbba8 100644 --- a/collects/tests/mzscheme/object.ss +++ b/collects/tests/mzscheme/object.ss @@ -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)