On Scheme

Thoughts on Scheme and teaching Scheme

Archive for March 20th, 2006

Simple Objects

Posted by Peter on March 20, 2006

Instead of simply slapping together any old object system I have decided to first lay out some different ways of implementing an object. These objects are singletons, in the sense that there is only one of them and no way of generating more. However it is trivial to generalize these objects into such a system, simply replace the (define object …) with (define make-object (lambda () …)). Also note that in the following code I am using my exception system, described just a few posts ago, and the exception: (extend-exception dispatch-exception message-exception)

The simplest kind of object has all its messages built in like so:

(define object-1
  (lambda (message . params)
    (cond ((eq? message 'print) (display params))
          ; other clauses
          (else (throw (make-dispatch-exception (cons message params)))))))

Although this system isn’t very extendable it gets the job done in most cases. Also you could add a system of local, and private, variables with a let statement around the lambda. To pass a message to this object one invokes it as (object-1 'message params …)

The next step up in complexity is adding a way to define new messages. In this case the list of dispatches is implemented with a list, but in the next example that will change into a hash table for speed and simplicity reasons.

(define object-2 
  (let
      ((dispatches '()))
    (lambda (message . params)
      (letrec ((try-to-dispatch
                (lambda (message params dispatches)
                  (if (null? dispatches)
                      (throw (make-message-exception (cons message params)))
                      (if (eq? (car (car dispatches)) message)
                          (apply (cdr (car dispatches)) params)
                          (try-to-dispatch message params (cdr dispatches))))))
               (get-dispatch
                (lambda (message dispatches)
                  (cond ((null? dispatches) (throw (make-dispatch-exception message)))
                        ((eq? (car (car dispatches)) message) (cdr (car dispatches)))
                        (else (get-dispatch message (cdr dispatches))))))
               (set-dispatch
                (lambda (message dispatches val)
                  (cond ((null? dispatches) '())
                        ((eq? (car (car dispatches)) message) (cons (cons message val) (cdr dispatches)))
                        (else (cons (car dispatches) (set-dispatch message (cdr dispatches) val))))))
               (has-dispatch?
                (lambda (message dispatches)
                  (cond ((null? dispatches) #f)
                        ((eq? (car (car dispatches)) message) #t)
                        (else (has-dispatch? message (cdr dispatches))))))
               (create-dispatch
                (lambda (message dispatches val)
                  (cond ((null? dispatches) (list (cons message val)))
                        ((eq? (car (car dispatches)) message) (cons (cons message val) (cdr dispatches)))
                        (else (cons (car dispatches) (create-dispatch message (cdr dispatches) val))))))
               )
        (cond ((eq? message 'set-dispatch)
               (set! dispatches (set-dispatch (car params) dispatches (car (cdr params)))))
              ((eq? message 'has-dispatch?)
               (has-dispatch? (car params) dispatches))
              ((eq? message 'get-dispatch)
               (get-dispatch (car params) dispatches))
              ((eq? message 'create-dispatch)
               (set! dispatches (create-dispatch (car params) dispatches (car (cdr params)))))
              (else (try-to-dispatch message params dispatches)))
        ))
    ))

In this system you can add a message with (object-2 'create-dispatch message function), which will overwrite an existing dispatch if one exists. You can set an existing dispatch only with 'set-dispatch, which is invoked in the same way. (object-2 'has-dispatch message) checks for the existence of a dispatch, and (object-2 'get-dispatch message) returns the function stored for that dispatch. Once a dispatch has been created it can be invoked in the same way as the ones defined for object-1.

Next the ability to refer the object itself in a dispatch is added. The self reference is stored via a weak box, so that the object could be garbage collected appropriately. In this implementation I chose to used fluid-let, my best friend, to set the self value. This is probably not thread safe, if that is a problem you could change the implementation so that it passes the self reference as the first parameter to any dispatch function, but I find this slightly less elegant. Also the ability to self-reference allows the program to use dispatches like member variables.

The implementation is:

(define self (lambda x x))

(define object-3
  (let ((o-3
         (let
             ((dispatches (make-hash-table)) (i-self '()))
           (lambda (message . params)
             (cond ((eq? message 'set-dispatch)
                    (hash-table-get dispatches (car params) (lambda () (throw (make-dispatch-exception params))))
                    (hash-table-put! dispatches (car params) (car (cdr params))))
                   ((eq? message 'has-dispatch?)
                    (let ((result #t)) (hash-table-get dispatches (car params) (lambda () (set! result #f))) result))
                   ((eq? message 'get-dispatch)
                    (hash-table-get dispatches (car params) (lambda () (throw (make-dispatch-exception params)))))
                   ((eq? message 'create-dispatch)
                    (hash-table-put! dispatches (car params) (car (cdr params))))
                   ((eq? message 'remove-dispatch)
                    (hash-table-remove! dispatches (car params)))
                   ((eq? message 'set-self)
                    (if (null? i-self) (set! i-self (make-weak-box (car params)))))
                   (else (fluid-let ((self (weak-box-value i-self)))
                           (if self
                               (apply (hash-table-get dispatches
                                                      message
                                                      (lambda () (throw (make-dispatch-exception (cons message params)))))
                                      params)))))
             )
           )))
    (o-3 'set-self o-3)
    o-3))

And you can see how it can be used with the following example:

(object-3 'create-dispatch 'print (lambda () (display "value: ") (display (self 'get-dispatch 'value)) (newline)))
(object-3 'create-dispatch 'value "my value")
(object-3 'print)
(object-3 'set-dispatch 'value "new value")
(object-3 'print)

The next problem I will tackle is inheritance. One way of creating an object of a certain type is to have a function, such as make-dog that takes an object and adds the appropriate dog functions to it. If that is the case an object that is extended from dog, for example a Doberman, could be created by applying make-dog to it and then make-doberman to give it the new Doberman functions. The problem with this however is that if you are inheriting from multiple sources it is possible that they have the same named functions, in which case there will be name clashing, and things won’t work. The other solution is to internally have a list of parent instances, and for each message try to dispatch to the parents as well. The problem with this solution is that a) it is inelegant, and b) makes virtual inheritance almost impossible to implement properly.

So for next time: inheritance, and possibly static data.

Posted in Exploring Scheme, OOP | Leave a Comment »

 
Follow

Get every new post delivered to your Inbox.