SOS: Simple Object System

["Maciek Godek" <pstrychuj@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 2266 bytes --]

Hi,
Using some hints you gave me, I've implemented a really tiny
object system -- and I would like to know your opinion ("why
it's still better to use goops" :D)

The notation for defining classes is following (using example of a sphere):

(define sphere
   (class
    '(x y radius)
    '((move (dx dy)
               (set! x (+ x dx))
               (set! y (+ y dy)))
      (scale (factor)
               (set! radius (* factor radius))))))

To make an instance, you simply use instance-of:
(let ((S (instance-of sphere))) ... )
you can supply initial values to the object's props
and call it's methods
(let ((S (instance-of sphere 1 2 3)))
    (in S '(move 1 1)) ;move the sphere from (1 2) to (2 3)
    (in S '(scale 5))
    (get S 'radius)) ; returns 15


The implementation is very simple: every object is
a vector. Its first field is always a reference to the class,
and the remaining fields are object's state (in the example,
the values of x, y and radius of S)

A class definition is a vector consisting of:
hashmap N from property names to vector indices (in object)
hashmap M from member function names to their indices in F
vector F of member functions

There's nothing surprising in here, and won't be. It has, as I can
tell, a few advantages over goops -- mainly, storing objects
as vectors allows for an efficient and convenient object treating
from C level, so boatmen should be satisfied.
Secondly, people accustomed to the object.method() notation
(like myself) won't feel lost and the global namespace will be
kept clean.

The system certainly isn't as complex as goops and doesn't
handle types (in general) so exquisitely. Also, it's unable to
support multiple inheritance efficiently (single inheritance isn't
supported as well, but this could be done quite easily if needed),
but that's not my point.

I just wanted to ask if you have any comments or remarks
to share with (I know I'm not the first guy to implement a thing
like this). I am currently using this system to implement another
system (for networked objects -- I wrote about it in another post)
and so far it caused no trouble.

I attach the working implementation (if anyone's interested).
For those who got this far (yes, that would be... you!), thanks for
your attention :D

M.

[-- Attachment #2: sos.scm --]
[-- Type: application/octet-stream, Size: 3845 bytes --]


(use-modules (srfi srfi-1))
(use-modules (srfi srfi-17))
(use-syntax (ice-9 syncase))


(define-syntax let-alias 
  (syntax-rules () 
    ((_ ((id alias) ...) body ...) 
     (let-syntax ((helper (syntax-rules () 
			    ((_ id ...) (begin body ...))))) 
       (helper alias ...)))))

;; the `class' function creates a new class. `private' and `public' are lists
;; of symbols (variable names), and `member-functions' is a list of member function
;; definitions of a shape: (name (args) body). 
(define (class member-vars member-functions)
  (let ((definition (make-vector 3))
	(properties (append '(class) member-vars))
	;; symbols->hashed-indices transforms a list of symbols into a hash table
	;; containing integers ranging from 0 to length(symbols)-1, for instance,
	;; (symbols->hashed-indices '(a b c)) returns a hash map such that
	;; for key 'a' the value is 0, for 'b' 1, for 'c' 2 in other words it
	;; returns a hash map X such that for every symbol 
	;; (eq? (list-ref symbols (hash-ref X symbol)) symbol
	(symbols->hashed-indices
	 (lambda(symbols) (let ((h (make-hash-table (length symbols)))
				(count (let((c -1))(lambda()(set! c (+ c 1))c))))
			    (map (lambda(symbol)(hash-set! h symbol (count))) symbols)
			    h))))
    (let-alias ((state-indices (vector-ref definition 0))
		(method-indices (vector-ref definition 1))
		(methods (vector-ref definition 2)))
					; set the names of state variables into a hash table
      (set! state-indices (symbols->hashed-indices properties))
					; set the names of member functions into a hash table
      (set! method-indices (symbols->hashed-indices (map car member-functions)))
	
      (let* ((build-context (lambda(property)(list property (list 'vector-ref 'self (hash-ref state-indices property)))))
	     (context (map build-context properties))
	     ;; method->lambda transforms member function definitions into appropreate lambdas. It builds
	     ;; a lexical closure that aliases all properties of a given class as references to a vector "self".
	     ;; for instance, member function 'a=b+n' in the following class definition:
	     ;; (class '() '(a b) '((a=b+n (n) (set! a (+ b n)))))
	     ;; will be transformed to:
	     ;; (lambda (self n) (let-alias ((class (vector-ref self 0)) (a (vector-ref self 1)) (b (vector-ref self 2)))
	     ;;                     (set! a (+ b n))))
	     (method->lambda (lambda(method-definition)
			       (let ((arglist (cons 'self (cadr method-definition))) ; list of method's arguments
				     (body (cddr method-definition))) ; body of the function
				 ;; we `primitive-eval', because we don't want to have a function
				 ;; definition (a list), but a function itself. This is guile-specific solution.
				 (primitive-eval `(lambda ,arglist (let-alias ,context ,@body)))))))     
	(set! methods (list->vector (map method->lambda member-functions)))))
    definition))


(define-macro (in object method)
  `(let* ((class (vector-ref ,object 0))
	  (name-to-method-map (vector-ref class 1))
	  (methods (vector-ref class 2))
	  (method-index (hash-ref name-to-method-map (car ,method)))
	  (member-function (vector-ref methods method-index)))
     (apply member-function (cons ,object (cdr ,method)))))

(define-macro (get object property)
  `(let* ((class (vector-ref ,object 0))
	  (name-to-value-map (vector-ref class 0))
	  (property-index (hash-ref name-to-value-map ,property)))
     (vector-ref ,object property-index)))

(define (instance-of class . initial)
  (let* ((l (length (hash-map->list cons (vector-ref class 0))))
	 (object (make-vector l)))
    (vector-set! object 0 class)
    (if (> (length initial) (- l 1)) 
	(set! initial (list-head initial (- l 1))))
    (let* ((count (let ((c 0)) (lambda () (set! c (+ c 1)) c))))
      (map (lambda(value)(vector-set! object (count) value)) initial))
    object))