Used SRFIs: 9, 23


In Python, objects are simple name->value dictionaries which can be extended at runtime (a meta-object-protocol). Methods are closures stored in this dictionary, and there's a special convention for calling methods: They are passed the object they belong to as the first argument (commonly called self).

Python does multiple inheritance, but uses a depth-first search for matches - this is implemented easily by using a list of parent objects, and passing them the message until one succeeds.

Let's start by defining a simple dictionary. We use an alist for simplicity here.

 ;; The object type 
 (define-record-type python-object 
   (make-python-object data parents) 
   (data object-data set-object-data!) 
   (parents object-parents)) 
 ;; Create an empty object 
 (define (make-object . parents) 
   (make-python-object '() 
 ;; Get the cons cell holding the value for NAME in OBJ, or #f if that 
 ;; does not exist. This implements all of the inheritance we need :-) 
 (define (object-assq obj name) 
    ((assq name (object-data obj)) 
     => (lambda (x) x)) 
     (let loop ((parents (object-parents obj))) 
        ((null? parents) 
        ((object-assq (car parents) name) 
         => (lambda (x) x)) 
         (loop (cdr parents)))))))) 
 ;; Get the value of NAME in OBJ. 
 (define (object-get obj name) 
    ((object-assq obj name) 
     => cdr) 
     (error "Instance has no attribute" name)))) 
 ;; Set the value named NAME of the object OBJ. If it doesn't exist, 
 ;; add it. 
 (define (object-set! obj name value) 
    ((assq name (object-data obj)) 
     => (lambda (pair) 
          (set-cdr! pair value))) 
     (set-object-data! obj 
                       (cons (cons name value) 
                             (object-data obj)))))) 

Now that we have this, we can go on to define a class definition similar to Pythons.

 ;; The main class definition 
 (define-syntax define-python-class 
   (syntax-rules () 
     ((_ class-name (parents ...) 
         (var val) 
      (define (class-name) 
        (let ((obj (make-object (parents) ...))) 
          (object-set! obj 'var val) 
 ;; Method invocation 
 (define-syntax <- 
   (syntax-rules () 
     ((_ obj method-name args ...) 
      ((object-get obj 'method-name) obj args ...)))) 

Now we can do:

 (define-python-class <point> () 
   (x 0) 
   (y 0) 
   (get-x (lambda (self) 
            (object-get self 'x))) 
   (set-x! (lambda (self new-x) 
             (object-set! self 'x new-x))) 
   (get-y (lambda (self) 
            (object-get self 'y))) 
   (set-y! (lambda (self new-y) 
             (object-set! self 'y new-y)))) 
 > (define p (<point>)) 
 ; no values returned 
 > (<- p get-x) 
 > (<- p set-x! 5) 
 > (<- p get-x) 
 ;; Testing inheritance 
 (define-python-class <colored-point> (<point>) 
   (color 'red) 
   (get-color (lambda (self) 
                (object-get self 'color))) 
   (set-color! (lambda (self new-color) 
                 (object-set! self 'color new-color)))) 
 > (define cp (<colored-point>)) 
 ; no values returned 
 > (<- cp get-color) 
 > (<- cp get-x) 
 > (<- cp set-x! 5) 
 > (<- cp get-x) 

Maybe some more syntax to hide the lambdas for method definitions would be in order. For better speed, something other then the alists would be needed. But else, have fun.

category-object-oriented logo design