Re: Message Passing with GOOPS

[Michael Tiedtke <michele.titke@o2online.de>]

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

On 25/06/2015 00:07, Marko Rauhamaa wrote:
> Michael Tiedtke <michele.titke@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
>

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".

[-- Attachment #2: Type: text/html, Size: 7964 bytes --]