Michael Tiedtke <michele.ti...@o2online.de>:
> 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
