Re: Message Passing with GOOPS

[Marko Rauhamaa]

Michael Tiedtke <address@hidden>:

> Perhaps it's better to recreate a clean object model without 3,000
> lines of C code like GOOPS. But then GOOPS really creates the illusion
> of an object oriented environment with a MOP ...

I'd stay away from GOOPS -- it's a leap away from functional
programming, IMO.

Here's a competing, complete object system I wrote last year:

===begin simpleton.scm==================================================
(define-module (pacujo simpleton))

;;; Return the unique serial number of the object.
(define-public (serial-number object)
  (procedure-property object '%serial-number))

;(define IMPL 'HTABLE)
(define IMPL 'ALIST)
(define make-lookup-table #f)
(define associate! #f)
(define look-up #f)
(define iterate #f)

(case IMPL
  ((HTABLE)
   (set! make-lookup-table make-hash-table)
   (set! associate! hashq-set!)
   (set! look-up hashq-ref)
   (set! iterate hash-for-each-handle))
  ((ALIST)
   (set! make-lookup-table (lambda () (cons #f '())))
   (set! associate! (lambda (table key value)
                      (set-cdr! table (assq-set! (cdr table) key value))))
   (set! look-up (lambda (table key) (assq-ref (cdr table) key)))
   (set! iterate (lambda (proc table) (for-each proc (cdr table)))))
  (else
   (throw 'Huh?)))

;;; Create and return an object. Parentage must be #f, a parent object
;;; (single inheritance), or a list of parent objects (multiple
;;; inheritance).
;;;
;;; Each of the procedures must have a name and becomes a method of the
;;; object. The methods can be invoked as follows:
;;;
;;;  (define object
;;;    (let ()
;;;      (define (my-method a b c) ...)
;;;      (make-object #f my-method)))
;;;  (object #:my-method 1 2 3)
;;;
;;; Any of the procedures may also be cons cells whose car is a keyword
;;; and cdr is a function. The keyword will then be used as the method
;;; name.
(define-public (make-object parentage . procedures)
  (let ((methods (make-lookup-table)))
    (define (object method . args)
      (let ((child (procedure-property object '%child-object)))
        (if child
            (apply child method args)
            (apply-method methods method args))))
    (set-procedure-property! object '%methods methods)
    (set-procedure-property! object '%serial-number (unique))
    (inherit object parentage)
    (let register-methods ((procedures procedures))
      (cond
       ((null? procedures) object)
       ((pair? (car procedures))
        (let ((procedure (cdar procedures))
              (method (caar procedures)))
          (associate! (methods-of object) method procedure)
          (register-methods (cdr procedures))))
       (else
        (let* ((procedure (car procedures))
               (method (symbol->keyword (procedure-name procedure))))
          (associate! (methods-of object) method procedure)
          (register-methods (cdr procedures))))))))

;;; Apply the parent's method, not the child object's implementation.
(define-public (delegate parent method . args)
  (apply-method (methods-of parent) method args))

;;;
;;; DESIGN
;;;
;;; A "class" simply a constructor function that calls make-object,
;;; which populates the object structure with methods.
;;;
;;; Each object is a procedure with associated procedure properties
;;; (metainformation):
;;;
;;;  * a lookup table ('%methods) containing the method procedures (with
;;;    keywords as method keys)
;;;
;;;  * an optional child object reference ('%child-object) for virtual
;;;    method dispatching
;;;
;;;  * a unique serial number ('%serial-number) for the potential
;;;    benefit of applications (debugging, logging)
;;;

(define unique
  (let ((uniq 0))
    (lambda ()
      (set! uniq (1+ uniq))
      uniq)))

(define (inherit object parentage)
  (cond
   ((not parentage) #f)
   ((list? parentage) (inherit-multi object parentage))
   (else (inherit-single object parentage))))

(define (inherit-single object parent)
  (iterate
   (lambda (handle)
     (associate! (methods-of object) (car handle) (cdr handle)))
   (methods-of parent))
  (set-procedure-property! parent '%child-object object))

(define (inherit-multi object parents)
  (or (null? parents)
      (let ((parent (car parents)))
        (inherit-single object parent)
        (inherit-multi object (cdr parents)))))

(define (methods-of object)
  (procedure-property object '%methods))

(define (apply-method methods method args)
  (let ((procedure (look-up methods method)))
    (if procedure
        (apply procedure args)
        (error "No such method" method))))
===end simpleton.scm====================================================

All you need is the make-object function.


Marko