dispatch-test.rkt

#lang r5rs

(#%require "dispatching.rkt")

(define (make-wallet value)
  (define (add! amount)
    (set! value (+ value amount)))
  (define (take! amount)
    (set! value (- value amount)))
  (dispatch (wallet) add! take! value))

(define (make-person name)
  (let ((wallet (make-wallet 10)))
    (define (sayhello)
      (display "Hello, I'm ")
      (display name))
  (dispatch (person) name sayhello wallet)))

(define bob (make-person "Bob"))

(send bob (sayhello)) ; prints "Hello, I'm Bob"
(send bob name) ; gives "Bob"
(send bob wallet value) ; gives 10
(send bob wallet (add! 50)) ; value now 60
(send bob wallet (take! 15)) ; value now 45

(define bobs-wallet (send bob wallet)) ; encouraged for saving on dispatch messages

(send bobs-wallet (add! 5)) ; value now 50
(send bobs-wallet (take! 10)) ; value now 40

(send bobs-wallet value) ; gives 40

(define bobs-wallet-add! (send bobs-wallet add!))
(define bobs-wallet-take! (send bob wallet take!))

(bobs-wallet-take! 30) ; value now 10
(bobs-wallet-add! 10) ; value now 20

(send bob type) ; gives 'person
(send bobs-wallet type) ; gives 'wallet
(send bob wallet type) ; also gives 'wallet

(send bob (sayhi)) ; error: message "sayhi" not recognized
(send bob wallet (add-one-thousand!)) ; error: message "add-one-thousand!" not recognized

dispatching.rkt

#lang r5rs

(#%require (only racket/base error)) ; for error only

(define (super-object msg type)
  (error 'NoMethodError "undefined method `~a' for ~a" msg type))

(define-syntax extend
  (syntax-rules ()
    ((_ (parent-object object-name) local-var ...)
     (let ((parent parent-object))
       (define (object-name msg)
         (case msg
           ((local-var) local-var)
           ...
           ((type) 'object-name)
           (else (parent msg 'object-name))))
       object-name))))

(define-syntax dispatch
  (syntax-rules ()
    ((_(object-name) local-var ...)
     (extend (super-object object-name) local-var ...))))

(define-syntax send
  (syntax-rules ()
    ((_ finish)                            finish)
    ((_ start (method args ...) expr ...) (send ((start `method) args ...) expr ...))
    ((_ start field expr ...)             (send (start `field) expr ...))))