Last active
December 14, 2015 23:19
-
-
Save LnL7/5164976 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#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 ...)))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment