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

Add set-field!. Because it's useful, because we have get-field, so why

Browse Source 
not it, and because it's an easy way to later test external field contracts.

svn: r18199
This commit is contained in:
Stevie Strickland 2010-02-19 23:55:39 +00:00
parent e9264b1fac
commit 95438db40f
4 changed files with 80 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/mzlib/class-traced.ss
View File

@ -24,6 +24,7 @@
(rename class-field-mutator-traced class-field-mutator)
(rename with-method-traced with-method)
(rename get-field-traced get-field)
(rename set-field!-traced set-field!)
(rename field-bound?-traced field-bound?)
(rename field-names-traced field-names)
private* public* pubment*

49
collects/scheme/private/class-internal.ss
View File

@ -36,7 +36,7 @@
object=?
new make-object instantiate
send send/apply send* class-field-accessor class-field-mutator with-method
get-field field-bound? field-names
get-field set-field! field-bound? field-names
private* public* pubment*
override* overment*
augride* augment*
@ -55,7 +55,7 @@
method-in-interface? interface->method-names class->interface class-info
(struct-out exn:fail:object)
make-primitive-class
class/c object/c
class/c #| object/c |#
;; "keywords":
private public override augment
@ -3535,6 +3535,47 @@
(begin0 (mutator obj value)
(set-event obj 'name value)))))]))
(define-syntaxes (set-field! set-field!-traced)
(let ()
(define (core-set-field! traced?)
(λ (stx)
(syntax-case stx ()
[(_ name obj val)
(identifier? #'name)
(with-syntax ([set (if traced?
#'set-field!/proc-traced
#'set-field!/proc)]
[localized (localize #'name)])
(syntax/loc stx (set `localized obj val)))]
[(_ name obj val)
(raise-syntax-error
'set-field! "expected a field name as first argument"
stx #'name)])))
(values (core-set-field! #f) (core-set-field! #t))))
(define-traced (set-field!/proc id obj val)
(unless (object? obj)
(raise-mismatch-error
'set-field!
"expected an object, got "
obj))
(trace-begin
(trace (set-event obj id val))
(let loop ([obj obj])
(let* ([cls (object-ref obj)]
[field-ht (class-field-ht cls)]
[index (hash-ref field-ht id #f)])
(cond
[index
((class-field-set! (car index)) obj (cdr index) val)]
[(wrapper-object? obj)
(loop (wrapper-object-wrapped obj))]
[else
(raise-mismatch-error
'get-field
(format "expected an object that has a field named ~s, got " id)
obj)])))))
(define-syntaxes (get-field get-field-traced)
(let ()
(define (core-get-field traced?)
@ -4303,7 +4344,7 @@
(rename-out [_interface interface]) interface* interface?
object% object? object=? externalizable<%> printable<%> equal<%>
new make-object instantiate
get-field field-bound? field-names
get-field set-field! field-bound? field-names
send send/apply send* class-field-accessor class-field-mutator with-method
private* public* pubment*
override* overment*
@ -4322,5 +4363,5 @@
method-in-interface? interface->method-names class->interface class-info
(struct-out exn:fail:object)
make-primitive-class
class/c object/c)
class/c #|object/c|#)

2
collects/tests/mzscheme/contract-test.ss
View File

@ -4512,6 +4512,7 @@
; ;;;;
; ;;;
#|
(test/pos-blame
'object/c-first-order-object-1
'(contract (object/c)
@ -4553,6 +4554,7 @@
(new (class object% (super-new) (field [n 3])))
'pos
'neg))
|#
;
;

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

@ -1154,6 +1154,38 @@
(test 10 'get-field3 (get-field f o))
(test 11 'get-field3 (get-field g o)))
(syntax-test #'(set-field!))
(syntax-test #'(set-field! a))
(syntax-test #'(set-field! a b))
(syntax-test #'(set-field! 1 b c))
(syntax-test #'(set-field! a b c d))
(error-test #'(set-field! x 1 2) exn:application:mismatch?)
(error-test #'(set-field! x (new object%) 2) exn:application:mismatch?)
(error-test #'(set-field! x (new (class object% (define x 1) (super-new))) 2)
exn:application:mismatch?)
(error-test #'(let ([o (let ()
(define-local-member-name f)
(new (class object%
(field [f 0])
(super-new))))])
(set-field! f o 2)))
(test 1 'set-field!1 (let ([o (new (class object% (field [x 0]) (super-new)))])
(set-field! x o 1)
(get-field x o)))
(test 1 'set-field!2 (let ()
(define-local-member-name f)
(define o (new (class object% (field [f 0]) (super-new))))
(set-field! f o 1)
(get-field f o)))
(let ([o (new (class (class object% (field [f 10]) (super-new))
(field [g 11])
(super-new)))])
(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))))
(syntax-test #'(field-bound?))
(syntax-test #'(field-bound? a))
(syntax-test #'(field-bound? 1 b))