Re: Message Passing with GOOPS

[Michael Tiedtke]

On 25/06/2015 00:07, Marko Rauhamaa wrote:

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

Nice! What about (define-class <stack> (<list>) ...)? In GOOPS every primitive type is (or should be) a class that can be used with multiple inheritance. It's enough to (use-modules (oop goops)).

Then you're missing this, too. Same as my implementation from yesterday. How do we add this magical reference to self called this. It should be available in every method/message definition? Here it is:

(define-method (call (receiver <object>) message . arguments)
  (apply (slot-ref receiver message) receiver arguments))

(define-syntax define-message
  (syntax-rules ()
    ((_ (message-name arguments ... ) body ...)
     (message-name #:init-value (lambda (this arguments ...) body ...)))))

Now this is defined to be the first argument in each and every message (method call in your case) but it can only be accessed by using this.

BTW Perhaps my define-message macro doesn't work in GOOPS right now because its define-class checks it's "lexical contents" too thoroughly. I think I'll try to "register" define-message as a valid slot description.

PS
You're delegate is usually called super.  Usually delegation means delegating the work to sb else. One half of an interface might be implemented by you're class implementation. The other half is just delegated to another object where changing the reference to the object is enough to change the behavior. Las time I used this was in Open Flowers where you change the rule set of the card game during a game. You can always circumvent this kind of delegation with good design but when your Application is already there in its shiny glory with all of it's framework implement a simple define/on-delegate might save some time.

 But super is missing in my implementation. What should it do with multiple inheritance?  How should it know about the inherited definitions?

You're lookup table is just a table. You could use an environment or to keep the size of the structure to the ground: a self-referencing directed graph - sometimes they use these to create automatons for dictionary/orthography checks. Sometimes they use it to index the world wide web. Sometimes they use it to store "symbols" and their "definitions".