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

add equal<%> ad interface*

Browse Source 
svn: r12946
This commit is contained in:
Matthew Flatt 2008-12-28 15:05:02 +00:00
parent df7796873a
commit 0cd2537a82
3 changed files with 258 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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 `[<prop-expr> <val-expr>]'"
stx
p+v)]))
(syntax->list #'(prop+val ...)))]
[(_ (interface-expr ...) prop+vals . _)
(raise-syntax-error #f
"expected `([<prop-expr> <val-expr>] ...)'"
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

80
collects/scribblings/reference/class.scrbl
View File

@ -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].}
@; ------------------------------------------------------------------------

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

@ -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)