Simple OO Inheritance in Scheme (SICP Redux)

Over on the reddit thread for my last blog post, there were a few requests for a more full-featured object oriented implementation.  I've been looking for a good excuse to brush up on my Lisp, so I've implemented a couple of examples.

There's no Haskell content here, so only follow the cut if you're interested in following up on the last post. 


I'll start with a reworked copy of Abelson & Sussman's original example.

(define (make-account balance)
  (define (set-balance x) (set! balance x))
  (define (get-balance) balance)
  (make-account-internal set-balance get-balance))

(define (make-account-internal setbal getbal)
  (define (withdraw amount)
     (if (>= (getbal) amount)
         (begin (setbal (- (getbal) amount))
                (getbal))
         "Insufficient Funds"))
  (define (deposit amount)
     (setbal (+ (getbal) amount))
     (getbal))
  (define (dispatch msg)
     (cond ((eq? msg 'withdraw) withdraw)
           ((eq? msg 'deposit) deposit)
           (else (error "Unknown request"
                        msg))))
  dispatch)

Here we have make-account binding get-balance and set-balance to functions, then calling make-account-internal to create our account object, using those bindings.  Other than this additional level of indirection, this code works exactly as the code shown yesterday (in fact, yesterday's example used the outdated sequence instead of begin, and doesn't run on a modern interpreter like Racket or guile). The extra level of indirection will be useful when we try to implement inheritance, given the scoping rules of Lisp.

Subclass Inheritance

Once we have these definitions, we can implement inheritance by creating a new version of  dispatch that directly calls any functions that are created or overridden in the subclass, and passes on all other calls to the  dispatch it inherits from the code above.  If we wanted to implement an account that has one-time overdraft protection with a limit of 100, we might use the following:

(define (make-overdraft-account balance) 
  (define (set-balance x) (set! balance x))
  (define (get-balance) balance)
  (make-overdraft-account-internal set-balance    
                                   get-balance)))

(define (make-overdraft-account-internal setbal getbal)
  (let ((parent-dispatch (make-account-internal setbal
                                               getbal)))
    (define (withdraw amount)
      (if (and (>= (getbal) 0)
               (>= (+ (getbal) 100) amount))
          (begin (setbal (- (getbal) amount))
                 (getbal))
          "Insufficient Funds"))
    (define (dispatch msg)
      (cond ((eq? msg 'withdraw) withdraw)
            (else (parent-dispatch msg))))
    dispatch))

> (define acc-o (make-overdraft-account 75))
> ((acc-o 'deposit) 10)
85
> ((acc-o 'withdraw) 200)
"Insufficient Funds"
> ((acc-o 'withdraw) 100)
-15
> ((acc-o 'withdraw) 5)
"Insufficient Funds"

Again, the wrapper class is responsible for making closures to handle the get and set functions.  When we get to  make-...-internal, we see why the wrapper was necessary.  Both the functions handled by dispatch (in this scope) and the functions handled by parent-dispatch (in a the parent's scope) need to get and set the balance.

Prototype Inheritance

To test our method for prototype inheritance, let's make a limited-account where the balance is limited to 1000.  That will require overriding the deposit method and using the other methods of the prototype object.  To implement inheritance, we will create our new object, and provide a method for setting its prototype. The new object will have no prototype when initialized; the caller must set the prototype with an additional call.  Locally, when we set the prototype, we will set the local binding for  parent-dispatch to the dispatch of the prototype object.  We will then use this handle to pass on any messages that have no local definition.  

Seems simple enough, but there's a wrinkle:  suppose that we have set our prototype object to acc.  When we pass a  withdraw message to our prototype's handler, then withdraw will use the setbal and getbal bindings of acc, not of the local object.  That's a problem!  We can circumvent this problem by setting our prototype to a deep copy of the specified object rather than the object itself.  We need to make sure that callers are aware that the local object will be blind to any changes in the procedures of the original prototype object. 

We will start the implementation with the new code for the original  account class.  We have to define the copy procedure and add it to dispatch:

(define (make-account-internal setbal getbal)
   . . .
   (define (copy setb getb)
      (make-account-internal setb getb))
   (define (dispatch msg)
      (cond ((eq? msg 'copy) copy)
      . . .

Now we can define make-limited-account: 

(define (make-limited-account balance)
  (let ((set-balance (lambda (x) (set! balance x)))
        (get-balance (lambda () balance)))
     (make-limited-account-internal set-balance
                                    get-balance)))

(define (make-limited-account-internal setbal getbal)
  (let ((parent-dispatch '()) (limit 1000))
    (define (deposit amount)
      (if (<= (+ (getbal) amount) limit)
          (begin (setbal (+ (getbal) amount))
                 (getbal))
          "Over Limit"))
    (define (set-proto proto)
      (set! parent-dispatch
            ((proto 'copy) setbal getbal)))
    (define (dispatch msg)
      (cond ((eq? msg 'deposit) deposit)
            ((eq? msg 'set-proto) set-proto)
            ((not (null? parent-dispatch))
             (parent-dispatch msg))
            (else (((error "Unknown request" msg))))
    dispatch))

> (define acc-l (make-limited-account 75))
> ((acc-l 'deposit) 10)
85
> ((acc-l 'withdraw) 20)
. . Unknown request withdraw
> ((acc-l 'set-proto) acc)
> ((acc-l 'withdraw) 20)
65
> ((acc 'withdraw) 25)
25

I agree with one of the previous comments that for a production system I would use a full-featured dispatch table rather than the simple function here.  I think this is enough to exhibit the general idea, though.