Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

93 lines (76 sloc) 2.896 kb
#lang racket
;; Look at
;; http://planet.racket-lang.org/package-source/neil/protobj.plt/1/2/planet-docs/protobj/index.html
(require tests/eli-tester
"foo.rkt")
; point-2D object and its constructor
(define-method* get-x get-y test-kw set-x set-y of-class)
(define (point-2D x y)
(object (object%)
(define (get-x) x)
(define (get-y) y)
(define (test-kw #:something z)
(+ x y z))
(define (set-x new-x)
(update [get-x new-x]))
(define (set-y new-y)
(update [get-y new-y]))
(define (class)
"point-2D")
(define (of-class)
(class self))))
(define (print-x-y obj)
(list (class obj)
(get-x obj)
(get-y obj)))
(define p (point-2D 5 6))
(define p1 (point-2D 5 6))
; pm is the object 'p' after the "mutation"
; Note that closures 'pm' and 'p' _share_ all the common state,
; including their identity
(define pm (set-x p 10))
; Illustrating inheritance and polymorphism
; A derived "object" inherits the message-map of its parent, and
; adds its own handlers at the top. Because subclass' handlers will
; be encountered first when a handler for a selector is being
; searched, the subclass is able to override the behavior of its
; superclass.
(define-method* get-z set-z)
(define (point-3D x y z)
(object (point-2D x y)
(define (get-z) z)
(define (set-z new-z)
(update [get-z new-z]))
(define (class)
"point-3D")))
(define q (point-3D 1 2 3))
(test
(of-class p1) => "point-2D"
(get-x p) => 5
(get-x p1) => 5
(test-kw p #:something 7) => 18
(print-x-y p) => (list "point-2D" 5 6)
; p and p1 happen at this point to be in the same state
(equal? (print-x-y p) (print-x-y p1))
; but p and p1 are different, non-identical objects
(eq? (identity p) (identity p1)) => #f
(print-x-y pm) => (list "point-2D" 10 6)
; States differ, identities are the same
(equal? (print-x-y p) (print-x-y pm)) => #f
(eq? (identity p) (identity pm))
; Although print-x-y was defined for objects of type point-2D,
; it accepts point-3D objects as well. Note however that the head
; of print-x-y's result spells "point-3D". This is because a point-3D
; object overrides the message 'class of its parent class
(print-x-y q) => (list "point-3D" 1 2)
(get-z q) => 3
; Demonstrating the use of inherited methods....
(let ([obj (set-z (set-x q 11) 12)])
(append (print-x-y obj) (list (get-z obj))))
=> (list "point-3D" 11 2 12)
(of-class q) => "point-3D" ; notice polymorphism!!!
; The of-class method is implemented in point-2D yet the result is
; "point-3D". This is because the 'of-class method sends the message
; 'class to itself. The latter handler is over-ridden in a
; class point-3D to return its own title, "point-3D".
(object 1) =error> "the parent argument")
Jump to Line
Something went wrong with that request. Please try again.