ClosureTalk


ClosureTalk is a simple object system that uses closures to create a message-passing based object model, very similar to the one used in Smalltalk and Ruby.

It consists of only two objects: Object and Class (both which are classes). Object is the baseclass of all classes (including Class), and Class is the class of all classes (including Object and Class).

The implementation is given below.

Some examples:

To create a subclass from a class, you send the message 'subclass to the class, passing the name and the variables of the class as arguments:

 (define String (Object 'subclass 'String '(str length)))  

Adding an init method to initialize new objects:

 (String 'add-method 'init 
   (lambda (this data . l) 
     (this 'call-super 'init) 
     (cond ((and (not (null? l)) 
                 (string? (car l))) 
            (data 'str (car l)) 
            (data 'length (string-length (car l)))) 
           (else 
            (data 'str "") 
            (data 'length 0))))) 

Some remarks: Each method needs to have at least two arguments: this and data. The this-argument refers to the current object, but with access to private methods. The data-argument contains the data of this specific instance. In order to get a variable, you send the variable name to data. To set the variable you send the variable name with the new contents. Note: The this and data argument shouldn't be carried outside the method. If you need to send the object to another function, you should use (this 'self) instead.

Creating instances:

 (define a_string (String 'new "a brandnew string!")) 

Adding methods:

 (String 'add-method 'length  
   (lambda (this data) 
     (data 'length))) 
  
 (a_string 'length) 
 => 18 

Class relationships:

 ((Class 'superclass) 'name) 
 => Object 
  
 (Object 'superclass) 
 => #f 
  
 ((String 'superclass) 'name) 
 => Object 
  
 ((Class 'class) 'name) 
 => Class 
  
 ((a_string 'class) 'name) 
 => String 

Since Class is a class-object itself, it is possible to add methods to Class:

 (Class 'add-method 'accessor 
   (lambda (this data var) 
     (this 'add-method var 
       (lambda (this data . arg) 
         (apply data (cons var arg)))))) 
  
 (String 'accessor 'str) 
  
 (a_string 'str) 
 => "a brandnew string!" 
  
 (a_string 'str "another string") 
 (a_string 'str) 
 => "another string" 

Implementation:

Note that this implementation should work on most standard compliant scheme, but is not very efficient. If it would be used in a real system, it could be adapted for efficiency (for example, the association lists used for method-lookup could be replaced by hash-tables). PLT scheme has a problem with the code, apparently because it does not distinguish between upper case variables (such as Class-data and Object-data) and lowercase variables (such as class-data and object-data).

 (define Object #f) 
 (define Class 
   (let* (; small utility func: return last element of list 
          (getlast 
           (letrec ((getlast 
                     (lambda (l) (if (null? (cdr l)) 
                                     (car l) 
                                     (getlast (cdr l)))))) 
             getlast)) 
  
          ; create a new instance of a class: 
          ; return a function which calls the class with the object data 
          (create-instance 
           (lambda (call-method data class call-super args) 
             (letrec 
                 ((call-private 
                   (lambda (method . arg) 
                     (call-method method data call-private #t arg))) 
                  (call-instance 
                   (lambda (method . arg) 
                     (call-method method data call-private #f arg))) 
                  (call-super-class 
                   (lambda (method . arg) 
                     (call-super method (cdr data) call-private #t arg)))) 
                                         ;setup object-data 
               (let ((obj-data (getlast data))) 
                 (obj-data 'class class) 
                 (obj-data 'call-super call-super-class) 
                 (obj-data 'self call-instance)) 
               (call-method 'init data call-private #t args) 
               call-instance))) 
  
          ; return a function that will lookup the method 
          ; in the class and apply the object to it 
          (create-class-method-call 
           (lambda (method-alist private-method-alist call-super) 
             (lambda (method data call-obj call-private? args) 
                                         ; lookup method 
               (let ((m (assq method (cdr method-alist)))) 
                 (if (and (not m) call-private?) 
                     (set! m (assq method (cdr private-method-alist)))) 
                                         ;apply method 
                 (if m (apply (cdr m) (append (list call-obj (car data)) args)) 
                                         ;or lookup method deeper 
                     (call-super method (cdr data) 
                                 call-obj #t args)))))) 
  
          ; return a function which creates a data object from params 
          (data-object-creator 
           (lambda (params super-data) 
             (lambda () 
               (let ((paramlist 
                      ; make association list from params 
                      (letrec ((loop 
                                (lambda (a l) 
                                  (cond 
                                   ((null? l) a) 
                                   ((symbol? (car l)) 
                                    (loop (append `((,(car l) . #f)) a) 
                                          (cdr l))) 
                                   (else (loop a (cdr l))))))) ;error 
                        (loop '() params)))) 
                 (cons 
                  (lambda (var . value) 
                    (let ((v (assq var paramlist))) 
                      (if (not v) #f ;(error) 
                          (cond ((null? value) 
                                 (cdr v)) ; get variable 
                                ((null? (cdr value)) 
                                 (set-cdr! v (car value))) ;set variable 
                                (else 
                                 (set-cdr! v value)))))) ;set variable as list 
                  (if super-data (super-data) '() )))))) 
  
  
          ;(Object-call-super (lambda (method class-name) 
          ;                    (error))) ; undefined method 
              (Object-call-super #f) 
  
          (Object-params '(class call-super self)) 
  
          (Object-data (data-object-creator Object-params  #f)) 
  
          (Object-method-alist 
           (let ((class 
                  (lambda (this data) 
                    (data 'class))) 
                 (self 
                  (lambda (this data) 
                    (data 'self)))) 
             `(methods (class . ,class) (self . ,self)))) 
  
          (Object-private-method-alist 
           (let ((init (lambda (this data) #f)) ; dummy, do nothing 
                 (call-super 
                  (lambda (this data . args) 
                    (apply (data 'call-super) args)))) 
             `(methods (init . ,init) (call-super . ,call-super)))) 
  
          (Object-call-method 
           (create-class-method-call Object-method-alist 
                                     Object-private-method-alist 
                                     Object-call-super)) 
  
                  ;define the methods for Class 
          (Class-private-method-alist 
           (let ((init-class-with-params 
                  ; fake init-method used to setup the class with 
                  ; precooked values 
                  (lambda (class-obj class-data method-alist 
                           private-method-alist data call-method 
                           call-super name superclass) 
                    (class-data 'method-alist method-alist) 
                    (class-data 'private-method-alist private-method-alist) 
                    (class-data 'create-data data) 
                    (class-data 'call-method call-method) 
                    (class-data 'call-super call-super) 
                    (class-data 'name name) 
                    (class-data 'superclass superclass)))) 
  
             `(method (init . ,init-class-with-params)))) 
  
            (Class-method-alist 
           (let ((name (lambda (class-obj class-data) 
                         (class-data 'name))) 
  
                 (new-instance 
                  ; create a new instance of the class: 
                  (lambda (class-obj class-data . args) 
                    (let ((call-method (class-data 'call-method)) 
                          (data (class-data 'create-data)) 
                          (call-super (class-data 'call-super))) 
                      (create-instance call-method (data) (class-obj 'self) 
                                       call-super args)))) 
  
                 (subclass 
                  (lambda (this data name params) 
                    ((this 'class) 'new (data 'call-method) 
                     (data 'create-data) (this 'self) name params))) 
  
                 (superclass 
                  (lambda (this data) 
                    (data 'superclass))) 
  
                 (add-method 
                  (lambda (this data method func) 
                    (let* ((mlist (data 'method-alist)) 
                           (key (assq method (cdr mlist)))) 
                      (if key 
                          (set-cdr! key func) 
                          (set-cdr! mlist (append (list (cons method func)) 
                                                  (cdr mlist))))))) 
  
                 (add-private-method 
                  (lambda (this data method func) 
                    (let* ((mlist (data 'private-method-alist)) 
                           (key (assq method (cdr mlist)))) 
                      (if key 
                          (set-cdr! key func) 
                          (set-cdr! mlist (append (list (cons method func)) 
                                                  (cdr mlist)))))))) 
  
  
             `(methods (new . ,new-instance) 
                       (name . ,name) 
                       (add-method . ,add-method) 
                       (add-private-method . ,add-private-method) 
                       (subclass . ,subclass)(superclass . ,superclass)))) 
  
          ; the params of class Class itself 
          (Class-params '(method-alist private-method-alist superclass 
                          create-data call-method name call-super)) 
          ; make a data-creator for class Class 
          (Class-data (data-object-creator Class-params Object-data)) 
          (Class-call-method (create-class-method-call 
                              Class-method-alist Class-private-method-alist 
                              Object-call-method)) 
  
          (class-data (Class-data)) 
  
          (object-data (Class-data)) 
  
           ;setup Class 
          (Class-itself 
           ; let Class be an instance of itself 
           (create-instance 
            Class-call-method class-data #f  Object-call-method 
            (list Class-method-alist Class-private-method-alist 
            Class-data Class-call-method Object-call-method 'Class #f))) 
  
          (Object-itself 
           (create-instance 
            Class-call-method object-data Class-itself Object-call-method 
            (list Object-method-alist Object-private-method-alist 
                  Object-data Object-call-method Object-call-super 'Object #f)))) 
  
    ; since we cannot refer to Class en Object when creating them, 
    ; we need to do some surgery to place the correct value in the 
    ; data 
    ;((cadr object-data) 'class Class-itself) 
     ((cadr object-data) 'self Object-itself) 
     ((car class-data) 'superclass Object-itself) 
     ((cadr class-data) 'class Class-itself) 
     ((cadr object-data) 'self Object-itself) 
  
     ;now we are ready we replace the fake init in the Class private method list 
     (let ((init-class 
            (lambda (class class-data call-super 
                     super-data superclass name params) 
                        (let ((method-alist (list 'methods)) 
                    (private-alist (list 'methods))) 
                (class-data 'method-alist method-alist) 
                (class-data 'private-method-alist private-alist) 
                (class-data 'create-data (data-object-creator params super-data)) 
                (class-data 'superclass superclass) 
                (class-data 'call-super call-super) 
                (class-data 'call-method 
                            (create-class-method-call 
                             method-alist private-alist 
                             call-super)) 
                (class-data 'name name))))) 
       ; replace the init-method 
       (set-cdr! (assq 'init (cdr Class-private-method-alist)) init-class)) 
  
     (set! Object Object-itself) 
     Class-itself)) 

category-object-oriented