From 95438db40f1358a6e86bbd922df9ab2c0bb9123a Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 19 Feb 2010 23:55:39 +0000 Subject: [PATCH] Add set-field!. Because it's useful, because we have get-field, so why not it, and because it's an easy way to later test external field contracts. svn: r18199 --- collects/mzlib/class-traced.ss | 1 + collects/scheme/private/class-internal.ss | 49 +++++++++++++++++++++-- collects/tests/mzscheme/contract-test.ss | 2 + collects/tests/mzscheme/object.ss | 32 +++++++++++++++ 4 files changed, 80 insertions(+), 4 deletions(-) diff --git a/collects/mzlib/class-traced.ss b/collects/mzlib/class-traced.ss index f503746d5a..737a06cbe0 100644 --- a/collects/mzlib/class-traced.ss +++ b/collects/mzlib/class-traced.ss @@ -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* diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index 3d7fab704e..992ab8eb1f 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -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|#) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index b8f2ac04b2..64c575d06b 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -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)) +|# ; ; diff --git a/collects/tests/mzscheme/object.ss b/collects/tests/mzscheme/object.ss index 12b8895f1f..89025f6888 100644 --- a/collects/tests/mzscheme/object.ss +++ b/collects/tests/mzscheme/object.ss @@ -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))