diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index 47b5746e5a..81300e1df6 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -29,8 +29,8 @@ define-serializable-class define-serializable-class* class? mixin - interface interface? - object% object? externalizable<%> printable<%> + interface interface* interface? + object% object? externalizable<%> printable<%> equal<%> object=? new make-object instantiate send send/apply send* class-field-accessor class-field-mutator with-method @@ -2008,7 +2008,7 @@ [method-names (append (reverse public-names) super-method-ids)] [field-names (append public-field-names super-field-ids)] [super-interfaces (cons (class-self-interface super) interfaces)] - [i (interface-make name super-interfaces #f method-names #f)] + [i (interface-make name super-interfaces #f method-names #f null)] [methods (if no-method-changes? (class-methods super) (make-vector method-width))] @@ -2058,21 +2058,14 @@ (values struct:prim-object prim-object-make prim-object? #f #f) ;; Normal struct creation: (make-struct-type obj-name - (class-struct:object super) + (add-properties (class-struct:object super) interfaces) 0 ;; No init fields ;; Fields for new slots: num-fields undefined ;; Map object property to class: (append (list (cons prop:object c)) - (if (interface-extension? i printable<%>) - (list (cons prop:custom-write - (lambda (obj port write?) - (if write? - (send obj custom-write port) - (send obj custom-display port))))) - null) - (if deserialize-id + (if deserialize-id (list (cons prop:serializable ;; Serialization: @@ -2329,6 +2322,30 @@ (for-class name)))) syms))) + (define (add-properties struct-type intfs) + (if (ormap (lambda (i) + (pair? (interface-properties i))) + intfs) + (let ([ht (make-hash)]) + ;; Hash on gensym to avoid providing the same property multiple + ;; times when it originated from a single interface. + (for-each (lambda (i) + (for-each (lambda (p) + (hash-set! ht (vector-ref p 0) p)) + (interface-properties i))) + intfs) + ;; Create a new structure type to house the properties, so + ;; that they can't see any fields directly via guards: + (let-values ([(struct: make- ? -ref -set!) + (make-struct-type 'props struct-type 0 0 #f + (hash-map ht (lambda (k v) + (cons (vector-ref v 1) + (vector-ref v 2)))) + #f)]) + struct:)) + ;; No properties to add: + struct-type)) + (define-values (prop:object object? object-ref) (make-struct-type-property 'object)) ;;-------------------------------------------------------------------- @@ -2337,10 +2354,10 @@ ;; >> Simplistic implementation for now << - (define-syntax _interface - (lambda (stx) - (syntax-case stx () - [(_ (interface-expr ...) var ...) + (define-for-syntax do-interface + (lambda (stx m-stx) + (syntax-case m-stx () + [((interface-expr ...) ([prop prop-val] ...) var ...) (let ([vars (syntax->list (syntax (var ...)))] [name (syntax-local-infer-name stx)]) (for-each @@ -2364,7 +2381,33 @@ (compose-interface 'name (list interface-expr ...) - `(var ...)))))]))) + `(var ...) + (list prop ...) + (list prop-val ...)))))]))) + + (define-syntax (_interface stx) + (syntax-case stx () + [(_ (interface-expr ...) var ...) + (do-interface stx #'((interface-expr ...) () var ...))])) + + (define-syntax (interface* stx) + (syntax-case stx () + [(_ (interface-expr ...) ([prop prop-val] ...) var ...) + (do-interface stx #'((interface-expr ...) ([prop prop-val] ...) var ...))] + [(_ (interface-expr ...) (prop+val ...) var ...) + (for-each (lambda (p+v) + (syntax-case p+v () + [(p v) (void)] + [_ (raise-syntax-error #f + "expected `[ ]'" + stx + p+v)])) + (syntax->list #'(prop+val ...)))] + [(_ (interface-expr ...) prop+vals . _) + (raise-syntax-error #f + "expected `([ ] ...)'" + stx + #'prop+vals)])) (define-struct interface (name ; symbol @@ -2373,18 +2416,27 @@ #:mutable] public-ids ; (listof symbol) (in any order?!?) [class ; (union #f class) -- means that anything implementing - #:mutable]) ; this interface must be derived from this class + #:mutable] ; this interface must be derived from this class + properties) ; (listof (vector gensym prop val)) #:inspector insp) - (define (compose-interface name supers vars) + (define (compose-interface name supers vars props vals) (for-each (lambda (intf) (unless (interface? intf) (obj-error 'interface - "superinterface expression returned a non-interface: ~a~a" + "superinterface expression returned a non-interface: ~e~a" intf (for-intf name)))) supers) + (for-each + (lambda (p) + (unless (struct-type-property? p) + (obj-error 'interface + "property expression returned a non-property: ~e~a" + p + (for-intf name)))) + props) (let ([ht (make-hasheq)]) (for-each (lambda (var) @@ -2405,24 +2457,38 @@ ""))))) (interface-public-ids super))) supers) - ;; Check for [conflicting] implementation requirements - (let ([class (get-implement-requirement supers 'interface (for-intf name))] - [interface-make (if name - (make-naming-constructor - struct:interface - (string->symbol (format "interface:~a" name))) - make-interface)]) - ;; Add supervars to table: - (for-each - (lambda (super) - (for-each - (lambda (var) (hash-set! ht var #t)) - (interface-public-ids super))) - supers) - ;; Done - (let ([i (interface-make name supers #f (hash-map ht (lambda (k v) k)) class)]) - (setup-all-implemented! i) - i)))) + ;; Merge properties: + (let ([prop-ht (make-hash)]) + ;; Hash on gensym to avoid providing the same property multiple + ;; times when it originated from a single interface. + (for-each (lambda (i) + (for-each (lambda (p) + (hash-set! prop-ht (vector-ref p 0) p)) + (interface-properties i))) + supers) + (for-each (lambda (p v) + (let ([g (gensym)]) + (hash-set! prop-ht g (vector g p v)))) + props vals) + ;; Check for [conflicting] implementation requirements + (let ([class (get-implement-requirement supers 'interface (for-intf name))] + [interface-make (if name + (make-naming-constructor + struct:interface + (string->symbol (format "interface:~a" name))) + make-interface)]) + ;; Add supervars to table: + (for-each + (lambda (super) + (for-each + (lambda (var) (hash-set! ht var #t)) + (interface-public-ids super))) + supers) + ;; Done + (let ([i (interface-make name supers #f (hash-map ht (lambda (k v) k)) class + (hash-map prop-ht (lambda (k v) v)))]) + (setup-all-implemented! i) + i))))) ;; setup-all-implemented! : interface -> void ;; Creates the hash table for all implemented interfaces @@ -2466,7 +2532,7 @@ make-)) (define object<%> ((make-naming-constructor struct:interface 'interface:object%) - 'object% null #f null #f)) + 'object% null #f null #f null)) (setup-all-implemented! object<%>) (define object% ((make-naming-constructor struct:class 'class:object%) 'object% @@ -3726,7 +3792,23 @@ (_interface () externalize internalize)) (define printable<%> - (_interface () custom-write custom-display)) + (interface* () + ([prop:custom-write (lambda (obj port write?) + (if write? + (send obj custom-write port) + (send obj custom-display port)))]) + custom-write custom-display)) + + (define equal<%> + (interface* () + ([prop:equal+hash (list + (lambda (obj obj2 base-equal?) + (send obj equal-to? obj2 base-equal?)) + (lambda (obj base-hash-code) + (send obj equal-hash-code-of base-hash-code)) + (lambda (obj base-hash2-code) + (send obj equal-secondary-hash-code-of base-hash2-code)))]) + equal-to? equal-hash-code-of equal-secondary-hash-code-of)) ;; Providing traced versions: (provide class-traced @@ -3768,8 +3850,8 @@ define-serializable-class define-serializable-class* class? mixin - (rename-out [_interface interface]) interface? - object% object? object=? externalizable<%> printable<%> + (rename-out [_interface interface]) interface* interface? + object% object? object=? externalizable<%> printable<%> equal<%> new make-object instantiate get-field field-bound? field-names send send/apply send* class-field-accessor class-field-mutator with-method diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index 7da30e2c3e..7ec58e5756 100644 --- a/collects/scribblings/reference/class.scrbl +++ b/collects/scribblings/reference/class.scrbl @@ -77,8 +77,6 @@ @note-lib[scheme/class #:use-sources (scheme/private/class-internal)] -@local-table-of-contents[] - A @deftech{class} specifies @itemize{ @@ -184,6 +182,23 @@ is the most specific requirement from its superinterfaces. If the superinterfaces specify inconsistent derivation requirements, the @exnraise[exn:fail:object].} +@defform[(interface* (super-interface-expr ...) + ([property-expr val-expr] ...) + id ...)]{ + +Like @scheme[interface], but also associates to the interface the +structure-type properties produced by the @scheme[property-expr]s with +the corresponding @scheme[val-expr]s. + +Whenever the resulting interface (or a sub-interface derived from it) +is explicitly implemented by a class through the @scheme[class*] form, +each property is attached with its value to a structure type that +instantiated by instances of the class. Specifically, the property is +attached to a structure type with zero immediate fields, which is +extended to produce the internal structure type for instances of the +class (so that no information about fields is accessible to the +structure type property's guard, if any).} + @; ------------------------------------------------------------------------ @section[#:tag "createclass"]{Creating Classes} @@ -1456,6 +1471,60 @@ Returns a flat-contract that recognizes classes that are subclasses of @scheme[class].} +@; ------------------------------------------------------------------------ + +@section[#:tag "objectequality"]{Object Equality and Hashing} + +But default, objects that are instances of different classes or that +are instances of a non-transparent class are @scheme[equal?] only if +they are @scheme[eq?]. Like transparent structures, two objects that +are instances of the same transparent class (i.e., every superclass of +the class has @scheme[#f] as its inspector) are @scheme[equal?] when +their field values are @scheme[equal?]. + +To customize the way that a class instance is compared to other +instances by @scheme[equal?], implement the @scheme[equal<%>] +interface. + +@defthing[equal<%> interface?]{ + +The @scheme[equal<%>] interface includes three methods, which are +analogous to the functions provided for a structure type with +@scheme[prop:equal+hash]: + +@itemize[ + + @item{@scheme[equal-to?] --- Takes two arguments. The first argument + is an object that is an instance of the same class (or a subclass + that does not re-declare its implementation of @scheme[equal<%>]) + and that is being compared to the target object. The second argument + is a @scheme[equal?]-like procedure of two arguments that should be + used for recursive equality testing. The result should be a true + value if the object and the first argument of the method are equal, + @scheme[#f] otherwise.} + + @item{@scheme[equal-hash-code-of] --- Takes one argument, which is a + procedure of one argument that should be used for recursive hash-code + computation. The result should be an exact integer representing the + target object's hash code.} + + @item{@scheme[equal-secondary-hash-code-of] --- Takes one argument, + which is a procedure of one argument that should be used for + recursive hash-code computation. The result should be an exact + integer representing the target object's secondary hash code.} + +] + +The @scheme[equal<%>] interface is unusual in that declaring the +implementation of the interface is different from inheriting the +interface. Two objects can be equal only if they are instances of +classes whose most specific ancestor to explicitly implement +@scheme[equal<%>] is the same ancestor. + +See @scheme[prop:equal+hash] for more information on equality +comparisons and hash codes. The @scheme[equal<%>] interface is +implemented with @scheme[interface*] and @scheme[prop:equal+hash].} + @; ------------------------------------------------------------------------ @section[#:tag "objectserialize"]{Object Serialization} @@ -1556,8 +1625,11 @@ a single argument, which is the destination port to @scheme[write] or Calls to the @scheme[custom-write] or @scheme[custom-display] are like calls to a procedure attached to a structure type through the @scheme[prop:custom-write] property. In particular, recursive printing -can trigger an escape from the call. See @scheme[prop:custom-write] -for more information.} +can trigger an escape from the call. + +See @scheme[prop:custom-write] for more information. The +@scheme[printable<%>] interface is implemented with +@scheme[interface*] and @scheme[prop:custom-write].} @; ------------------------------------------------------------------------ diff --git a/collects/tests/mzscheme/object.ss b/collects/tests/mzscheme/object.ss index e5850aaf96..ee2d968c91 100644 --- a/collects/tests/mzscheme/object.ss +++ b/collects/tests/mzscheme/object.ss @@ -6,7 +6,7 @@ (require scheme/class) (Section 'object) - + ;; ------------------------------------------------------------ ;; Test syntax errors @@ -1413,6 +1413,63 @@ (check #f #t) (check #t #t)) +;; ---------------------------------------- +;; Implementing equal<%> + +(let () + (define c% + (class* object% (equal<%>) + (init-field x) + + (define/public (get-x) x) + (define/public (set-x v) (set! x v)) + + (define/public (equal-to? other recur-equal?) + (recur-equal? x (send other get-x))) + (define/public (equal-hash-code-of recur-hash-code) + (+ 1 (recur-hash-code x))) + (define/public (equal-secondary-hash-code-of recur-hash-code) + (+ 1 (recur-hash-code x))) + (super-new))) + (test #t equal? (new c% [x 10]) (new c% [x 10])) + (test #f equal? (new c% [x 10]) (new c% [x 12])) + + (let ([o (new c% [x 10])] + [o2 (new c% [x 10])]) + (send o set-x o) + (send o2 set-x o2) + (test #t equal? o o2) + (test #t equal? o (new c% [x o])) + (test #f equal? o (new c% [x 10])) + (let ([ht (make-hash)]) + (hash-set! ht o o) + (hash-set! ht (new c% [x "hello"]) 'hi) + (test #t eq? o (hash-ref ht o2)) + (test #f hash-ref ht (new c% [x 10]) #f) + (test 'hi hash-ref ht (new c% [x "hello"])) + (let ([d% (class c% + (super-new [x "hello"]))]) + (test 'hi hash-ref ht (new d%) #f)) + (let ([d% (class* c% (equal<%>) + (super-new [x "hello"]))]) + (test 'nope hash-ref ht (new d%) 'nope))))) + +;; ---------------------------------------- +;; Implementing new properties + +(let () + (define proc<%> + (interface* () + ([prop:procedure (lambda (o . args) + (send/apply o apply args))]) + apply)) + (define c% + (class* object% (proc<%>) + (define/public (apply . args) + (cons 'applied-to args)) + (super-new))) + (test '(applied-to 1 2 3) (new c%) 1 2 3)) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs)