Skip to content

Instantly share code, notes, and snippets.



Created Dec 15, 2011
What would you like to do?
; bos.scm is -*- Scheme -*-
; Bryan's Object System
; (C) 1994 Bryan O'Sullivan <>
; A simple object system for R4RS (with a few tweaks) Scheme, based on
; generics and multiple inheritance.
(define (fold op base list)
(let loop ((result base)
(list list))
(if (null? list)
(loop (op (car list) result) (cdr list)))))
; Slot names should come last in the vector which represents a class.
(define *superclasses-offset* 0)
(define *specialised-methods-offset* 1)
(define *name-offset* 2)
(define *slot-names-offset* 3)
; We keep all superclasses of a class in one list; this makes generic
; function dispatch and calling overridden methods easier.
; Since we do things this way, to create the list of superclasses for
; a new class, we just glom its superclass' lists together (with the
; superclasses appearing in the list too, of course). The upshot of
; this is that superclasses are maintained in `depth-first' order,
; with duplicates removed (otherwise methods should be idempotent for
; safety, which is hard to do).
(define (flatten superclasses)
(let loop ((new-superclasses '())
(superclasses superclasses))
(if (null? superclasses)
(loop (append new-superclasses
(let ((superclass (car superclasses)))
(if (equal? superclass <class>)
(list superclass)
(cons superclass
(vector-ref superclass
(cdr superclasses)))))
(define (remove-from elt list)
((null? list)
((eq? elt (car list))
(remove-from elt (cdr list)))
(cons (car list) (remove-from elt (cdr list))))))
(define (uniquify list)
(if (null? list)
(let ((head (car list)))
(cons head (uniquify (remove-from head (cdr list)))))))
; Right now, a class consists of a vector with the following elements:
; - its entire list of parents, in depth-first order
; - an a-list of methods specialised on the class
; - the names of all of its slots
(define (i-make-class name superclasses slot-names)
(let* ((slots (append superclasses (list (list->vector
(class-vector (make-vector (fold (lambda (v r)
(+ (vector-length v)
(- r *slot-names-offset*)))
*slot-names-offset* slots))))
(vector-set! class-vector *superclasses-offset* (uniquify (flatten superclasses)))
(vector-set! class-vector *specialised-methods-offset* '())
(vector-set! class-vector *name-offset* name)
(let loop ((slots slots)
(slot-offset *slot-names-offset*)
(vector-offset *slot-names-offset*))
(if (null? slots)
(let ((slot (car slots)))
(if (< slot-offset (vector-length slot))
(vector-set! class-vector vector-offset
(vector-ref slot slot-offset))
(loop slots (+ 1 slot-offset) (+ 1 vector-offset)))
(loop (cdr slots) *slot-names-offset* vector-offset)))))))
; The root class must contain entries for everything *except* slots.
(define <class> '#(() () "<class>"))
(define *class-offset* 0)
(define *slots-offset* 1)
(define (make-object class . args)
(let ((object (make-vector (+ *slots-offset* (- (vector-length class)
(vector-set! object *class-offset* class)
(apply initialise (cons object args))
; The generic function interface depends on each class (*not* each
; object) carrying around its own methods. This could possibly be
; made faster using hash tables instead of a-lists, but I don't know
; whether it would be worth the effort.
(define *unspecific* (if #f #f))
(define (make-generic)
(letrec ((this-function
(lambda (object . arguments)
(let* ((class (vector-ref object *class-offset*))
(classes (cons class
(vector-ref class
(have-specialised #f)
(my-classes classes))
(letrec ((call-next-method
(lambda ()
(if (null? my-classes)
(if have-specialised
(error "method not specialised"))
(let* ((class (car my-classes))
class *specialised-methods-offset*))
(assq this-function
(set! my-classes (cdr my-classes))
(if this-method
(set! have-specialised #t)
(apply (cdr this-method)
(cons call-next-method
(cons object arguments))))
(set! have-specialised #f)
(set! my-classes classes)
; Specialise a generic method with respect to a particular class.
(define (specialise! generic class procedure)
(let* ((specialised-methods (vector-ref class
(this-method (assq generic specialised-methods)))
(if this-method
(set-cdr! this-method procedure)
(vector-set! class *specialised-methods-offset*
(cons (cons generic procedure) specialised-methods)))))
; I prefer to do slot accessing dynamically rather than statically; it
; costs a little in terms of runtime and `opacity', but what the hell.
(define (slot-ref object slot-name)
(let* ((class (vector-ref object *class-offset*))
(top (vector-length class)))
(let loop ((offset *slot-names-offset*))
((= offset top)
(error "no such slot"))
((equal? slot-name (vector-ref class offset))
(vector-ref object (+ (- offset *slot-names-offset*) *slots-offset*)))
(loop (+ 1 offset)))))))
(define (slot-set! object slot-name value)
(let* ((class (vector-ref object *class-offset*))
(top (vector-length class)))
(let loop ((offset *slot-names-offset*))
((= offset top)
(error "no such slot"))
((equal? slot-name (vector-ref class offset))
(vector-set! object (+ (- offset *slot-names-offset*)
*slots-offset*) value))
(loop (+ 1 offset)))))))
; For the static safety diehards, here are faster and `safer' variants
; of the above, which return closures to do the necessary work.
(define (member-accessor class slot-name)
(let ((top (vector-length class)))
(let loop ((offset *slot-names-offset*))
((= offset top)
(error "no such slot"))
((equal? slot-name (vector-ref class offset))
(lambda (object)
(vector-ref object (+ (- offset *slot-names-offset*)
(loop (+ 1 offset)))))))
(define (member-mutator class slot-name)
(let ((top (vector-length class)))
(let loop ((offset *slot-names-offset*))
((= offset top)
(error "no such slot"))
((equal? slot-name (vector-ref class offset))
(lambda (object value)
(vector-set! object (+ (- offset *slot-names-offset*)
*slots-offset*) value)))
(loop (+ 1 offset)))))))
; I have no idea whether this may be useful or not (I've never used
; such a thing myself), but it was easy to write and Every Object
; System Should Have One.
(define (is-a? object class)
(let ((real-class (vector-ref object *class-offset*)))
(or (eq? real-class class)
(let loop ((superclasses (vector-ref real-class
((null? superclasses) #f)
((eq? (car superclasses) class) #t)
(else (loop (cdr superclasses))))))))
(define (class-of object)
(vector-ref object *class-offset*))
; Bootstrap me, baby. Specialise the INITIALISE generic for each
; class you define *before* you create objects of that class, or
; you'll be in trouble.
(define initialise (make-generic))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.