From fb853882881a251091f39e482df7f017b0275c6d Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 19 Dec 2009 20:56:40 +0000 Subject: [PATCH] Add this%, which is the class counterpart of the object reference "this". svn: r17359 --- collects/scheme/private/class-internal.ss | 8 +++-- collects/scheme/private/classidmap.ss | 16 ++++++++- collects/scribblings/reference/class.scrbl | 29 +++++++++++++++++ collects/tests/mzscheme/object.ss | 38 ++++++++++++++++++++++ 4 files changed, 88 insertions(+), 3 deletions(-) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index f631cabf21..96d51be73b 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -61,7 +61,7 @@ public-final override-final augment-final field init init-field init-rest rename-super rename-inner inherit inherit/super inherit/inner inherit-field - this super inner + this this% super inner super-make-object super-instantiate super-new inspect)) @@ -170,6 +170,7 @@ (define/provide-context-keyword [this this-param] + [this% this%-param] [super super-param] [inner inner-param] [super-make-object super-make-object-param] @@ -229,6 +230,7 @@ (quote-syntax super) (quote-syntax inner) (quote-syntax this) + (quote-syntax this%) (quote-syntax super-instantiate) (quote-syntax super-make-object) (quote-syntax super-new) @@ -1334,7 +1336,9 @@ (syntax-parameterize ([this-param (make-this-map (quote-syntax this-id) (quote-syntax the-finder) - (quote the-obj))]) + (quote the-obj))] + [this%-param (make-this%-map (quote-syntax (object-ref this)) + (quote-syntax the-finder))]) (let-syntaxes mappings (syntax-parameterize diff --git a/collects/scheme/private/classidmap.ss b/collects/scheme/private/classidmap.ss index f5450540af..54001b8d63 100644 --- a/collects/scheme/private/classidmap.ss +++ b/collects/scheme/private/classidmap.ss @@ -45,6 +45,20 @@ stx)] [id (find the-finder the-obj stx)]))))) +(define (make-this%-map replace-stx the-finder) + (let ([set!-stx (datum->syntax the-finder 'set!)]) + (make-set!-transformer + (λ (stx) + (syntax-case stx () + [(set! id expr) + (free-identifier=? #'set! set!-stx) + (raise-syntax-error 'class "cannot mutate this% identifier" stx)] + [id + (identifier? #'id) + (quasisyntax/loc stx #,replace-stx)] + [(f . args) + (quasisyntax/loc stx (#,replace-stx . args))]))))) + (define (make-field-map trace-flag the-finder the-obj the-binder the-binder-localized field-accessor field-mutator field-pos/null) (let ([set!-stx (datum->syntax the-finder 'set!)]) @@ -356,7 +370,7 @@ finalize-call-event)))) (qstx (app method object . args))))) -(provide (protect-out make-this-map make-field-map make-method-map +(provide (protect-out make-this-map make-this%-map make-field-map make-method-map make-direct-method-map make-rename-super-map make-rename-inner-map make-init-error-map make-init-redirect super-error-map diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index 021b068527..9678ebb0ff 100644 --- a/collects/scribblings/reference/class.scrbl +++ b/collects/scribblings/reference/class.scrbl @@ -357,6 +357,7 @@ flattened for top-level and embedded definitions. Within a @scheme[class*] form for instances of the new class, @scheme[this] is bound to the object itself; +@scheme[this%] is bound to the class of the object; @scheme[super-instantiate], @scheme[super-make-object], and @scheme[super-new] are bound to forms to initialize fields in the superclass (see @secref["objcreation"]); @scheme[super] is @@ -398,6 +399,34 @@ a syntax error. (send (new table) describe-self) ]} +@defidform[this%]{ + +Within a @scheme[class*] form, @scheme[this%] refers to the class +of the current object (i.e., the object being initialized or whose +method was called). Use outside the body of a @scheme[class*] form is +a syntax error. + +@defexamples[ +#:eval class-eval +(define account% + (class object% + (super-new) + (init-field balance) + (define/public (add n) + (new this% [balance (+ n balance)])))) +(define savings% + (class account% + (super-new) + (inherit-field balance) + (define interest 0.04) + (define/public (add-interest) + (send this add (* interest balance))))) +(let* ([acct (new savings% [balance 500])] + [acct (send acct add 500)] + [acct (send acct add-interest)]) + (printf "Current balance: ~a\n" (get-field balance acct))) +]} + @defclassforms[ [(inspect inspector-expr) ()] [(init init-decl ...) ("clinitvars")] diff --git a/collects/tests/mzscheme/object.ss b/collects/tests/mzscheme/object.ss index ee2d968c91..b7b4af6a9a 100644 --- a/collects/tests/mzscheme/object.ss +++ b/collects/tests/mzscheme/object.ss @@ -260,6 +260,7 @@ (class-keyword-test #'super) (class-keyword-test #'inner) (class-keyword-test #'this) +(class-keyword-test #'this%) (class-keyword-test #'super-new) (class-keyword-test #'super-make-object) (class-keyword-test #'super-instantiate) @@ -821,6 +822,43 @@ (test 10 (class-field-accessor many-fields% a) om1) (test 12 (class-field-accessor many-fields% b) om1)) +;; ------------------------------------------------------------ +;; Test this% +(let () + (define base% + (class object% + (super-new) + (define/public (factory) + (new this%)))) + (define derived% + (class base% + (super-new) + (init-field [f 4]) + (define/public (double) + (set! f (* 2 f))))) + (let* ([factory-derived (send (new derived%) factory)]) + (test 4 'factory-derived-f (get-field f factory-derived)) + (send factory-derived double) + (test 8 'factory-derived-f-doubled (get-field f factory-derived)))) + +(let () + (define account% + (class object% + (super-new) + (init-field balance) + (define/public (add n) + (new this% [balance (+ n balance)])))) + (define savings% + (class account% + (super-new) + (inherit-field balance) + (define interest 0.04) + (define/public (add-interest) + (send this add (* interest balance))))) + (let* ([acct (new savings% [balance 500])] + [acct (send acct add 500)] + [acct (send acct add-interest)]) + (test 1040.0 'acct-balance (get-field balance acct)))) ;; ------------------------------------------------------------ ;; Test public*, define-public, etc.