From ba56fd72da56dcc445c714e04252fc6d0f6df684 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 4 Sep 2012 15:10:20 -0600
Subject: [PATCH] racket/class: add `dynamic-get-field' and
 `dynamic-set-field!'

---
 collects/racket/private/class-internal.rkt | 20 ++++++++++++++++++--
 collects/scribblings/reference/class.scrbl | 14 +++++++++++++-
 collects/tests/racket/object.rktl          |  5 ++++-
 doc/release-notes/racket/HISTORY.txt       |  1 +
 4 files changed, 36 insertions(+), 4 deletions(-)

diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt
index a226edfb0d..1348cfd379 100644
--- a/collects/racket/private/class-internal.rkt
+++ b/collects/racket/private/class-internal.rkt
@@ -40,6 +40,7 @@
            send send/apply send/keyword-apply send* send+ dynamic-send
            class-field-accessor class-field-mutator with-method
            get-field set-field! field-bound? field-names
+           dynamic-get-field dynamic-set-field!
            private* public*  pubment*
            override* overment*
            augride* augment*
@@ -4432,6 +4433,9 @@ An example
       stx #'name)]))
 
 (define (set-field!/proc id obj val)
+  (do-set-field! 'set-field! id obj val))
+
+(define (do-set-field! who id obj val)
   (unless (object? obj)
     (raise-argument-error 'set-field!
                           "object?"
@@ -4446,6 +4450,10 @@ An example
                     "field name" (as-write id)
                     "object" obj))))
 
+(define (dynamic-set-field! id obj val)
+  (unless (symbol? id) (raise-argument-error 'dynamic-get-field "symbol?" id))
+  (do-set-field! 'dynamic-set-field! id obj val))
+
 (define-syntax (get-field stx)
   (syntax-case stx ()
     [(_ name obj)
@@ -4458,8 +4466,11 @@ An example
       stx (syntax name))]))
 
 (define (get-field/proc id obj)
+  (do-get-field 'get-field id obj))
+
+(define (do-get-field who id obj)
   (unless (object? obj)
-    (raise-argument-error 'get-field
+    (raise-argument-error who
                           "object?"
                           obj))
   (let* ([cls (object-ref obj)]
@@ -4467,11 +4478,15 @@ An example
           [fi (hash-ref field-ht id #f)])
      (if fi
          ((field-info-external-ref fi) obj)
-         (obj-error 'get-field
+         (obj-error who
                     "given object does not have the requested field"
                     "field name" (as-write id)
                     "object" obj))))
 
+(define (dynamic-get-field id obj)
+  (unless (symbol? id) (raise-argument-error 'dynamic-get-field "symbol?" id))
+  (do-get-field 'dynamic-get-field id obj))
+
 (define-syntax (field-bound? stx)
   (syntax-case stx ()
     [(_ name obj)
@@ -5179,6 +5194,7 @@ An example
          object% object? object=? externalizable<%> printable<%> writable<%> equal<%>
          new make-object instantiate
          get-field set-field! field-bound? field-names
+         dynamic-get-field dynamic-set-field!
          send send/apply send/keyword-apply send* send+ dynamic-send
          class-field-accessor class-field-mutator with-method
          private* public*  pubment*
diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl
index 9babc39139..b14aeb4f87 100644
--- a/collects/scribblings/reference/class.scrbl
+++ b/collects/scribblings/reference/class.scrbl
@@ -1409,13 +1409,25 @@ If @racket[obj-expr] does not produce an object, the
 @exnraise[exn:fail:contract]. If the object has no @racket[id] field,
 the @exnraise[exn:fail:object].}
 
+@defproc[(dynamic-get-field [field-name symbol?] [obj object?]) any/c]{
+
+Extracts the field from @racket[obj] with the (external) name that
+matches @racket[field-name]. If the object has no field matching @racket[field-name],
+the @exnraise[exn:fail:object].}
+
 @defform[(set-field! id obj-expr expr)]{
 
 Sets the field with (external) name @racket[id] from the value of
 @racket[obj-expr] to the value of @racket[expr].
 
 If @racket[obj-expr] does not produce an object, the
-@exnraise[exn:fail:contract].  If the object has no @racket[id] method,
+@exnraise[exn:fail:contract].  If the object has no @racket[id] field,
+the @exnraise[exn:fail:object].}
+
+@defproc[(dynamic-set-field! [field-name symbol?] [obj object?] [v any/c]) void?]{
+
+Sets the field from @racket[obj] with the (external) name that
+matches @racket[field-name] to @racket[v]. If the object has no field matching @racket[field-name],
 the @exnraise[exn:fail:object].}
 
 @defform[(field-bound? id obj-expr)]{
diff --git a/collects/tests/racket/object.rktl b/collects/tests/racket/object.rktl
index d812ab1694..547351c47c 100644
--- a/collects/tests/racket/object.rktl
+++ b/collects/tests/racket/object.rktl
@@ -937,6 +937,7 @@
         (set! f (* 2 f)))))
   (let* ([factory-derived (send (new derived%) factory)])
     (test 4 'factory-derived-f (get-field f factory-derived))
+    (test 4 dynamic-get-field 'f factory-derived)
     (send factory-derived double)
     (test 8 'factory-derived-f-doubled (get-field f factory-derived))))
 
@@ -1299,7 +1300,9 @@
   (test 12 'set-field!3 (begin (set-field! f o 12)
                                (get-field f o)))
   (test 14 'set-field!4 (begin (set-field! g o 14)
-                               (get-field g o))))
+                               (get-field g o)))
+  (test 18 'set-field!5 (begin (dynamic-set-field! 'g o 18)
+                               (dynamic-get-field 'g o))))
 
 (syntax-test #'(field-bound?))
 (syntax-test #'(field-bound? a))
diff --git a/doc/release-notes/racket/HISTORY.txt b/doc/release-notes/racket/HISTORY.txt
index bd194f760e..7cf67411bf 100644
--- a/doc/release-notes/racket/HISTORY.txt
+++ b/doc/release-notes/racket/HISTORY.txt
@@ -1,5 +1,6 @@
 Version 5.3.0.22
 ffi/unsafe: added cpointer-gcable?
+racket/class: added dynamic-get-field and dynamic-set-field!
 
 Version 5.3.0.20
 Added exn:break:hang-up and exn:break:terminate, added