Message Passing with GOOPS

Message Passing with GOOPS

[Michael Tiedtke]

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

(use-modules (oop goops))

GOOPS has some nice features (you can even use unexported methods with 
generics in 1.8) but there is no message passing paradigm. Objective-C 
has /tell/ Racket has /send/ but Guile/GOOPS is missing /call/.

This is a first "raw" definition where the parameter /message/ has to be 
a quoted symbol.

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


The class definition still looks like traditional GOOPS but it works.

An example:

(define-class <receiver> ()
   (msg #:init-value (lambda () 'hello-world)))

(define r (make <receiver>))
(call r 'msg) => 'hello-world


Now I'd like to have an easier syntax for describing the slot. The 
definition might be:

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

But the following example doesn't work in 1.8:

(define-class <house> ()
   (define-message (phone n)
     (repeat n (lambda () (bell) 'rang)) ))

GOOPS complains about malformed slots and *seems* to see the unexpanded 
form.*
I could use a little help here, anyone?* Even for the naming scheme: 
/send/ is already used by unix sockets and methods are part of the 
implementation of generics. Perhaps /message/ isn't that bad.


The missing symbols from my pretext:

(define (natural-number? n)
   (and (exact? n)
        (integer? n)  ; 'integer?' does not check for exactness ...
        (> n 0)))

(define-public (repeat n closure)
   "Execute closure n times."
   (if (not (or (natural-number? n) (= n 0)))
       (error "repeat: the parameter n must be an exact natural number 
or zero.")
       (let loop ((i 0))
         (if (< i n)
           (begin
             (closure)
             (loop (1+ i)))) )))


 From my pretext.rkt

(define-syntax *broadcast*
   (syntax-rules ()
     ((_ object-list method ...)
      (map {lambda (object) (send object method ...)}
           object-list))))
(define-syntax *broadcast**
   (syntax-rules ()
     ((_ object-list method ...)
      (map {lambda (object) (send* object method ...)}
           object-list))))

(define-syntax *define/on-delegate*
   (syntax-rules ()
     ((_ delegate-object (method-name ...))
      (define (method-name ...)
        (send delegate-object method-name ...)) )))


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


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

Re: Message Passing with GOOPS

[Marko Rauhamaa]

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

Re: Message Passing with GOOPS

[Michael Tiedtke]

[-- 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 --]

Re: Message Passing with GOOPS

[Marko Rauhamaa]

Michael Tiedtke <michele.titke@o2online.de>:

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

My "simpleton" doesn't have classes. It's *object* oriented, not *class*
oriented.

> Then you're missing /this/, too.

Not at all. It's very present in simpleton:

========================================================================
(define-public (<domain-client> .mux .peer-address)
  (define .this
    (let ((.super (<datagram-client> .mux .peer-address))
          (.opmap (make-hash-table))
          (.next-key 0))

      (define (query domain-name record-type listener xid)
        ; ...

      (define (handle-recv message)
        ; ...

    (make-object .super query handle-recv)))
  .this)
========================================================================

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

Multiple inheritance is there in simpleton, without classes.

> You're lookup table is just a table. You could use an environment or to
> keep the size of the structure to the ground:

In simpleton, each object has a unique dispatch table.


Marko

Re: Message Passing with GOOPS

[Michael Tiedtke]

[-- Attachment #1.1: Type: text/plain, Size: 3343 bytes --]



On 25/06/2015 11:07, Marko Rauhamaa wrote:
> Michael Tiedtke <michele.titke@o2online.de>:
>
>> 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)).
> My "simpleton" doesn't have classes. It's *object* oriented, not *class*
> oriented.

That reminds me of one chapter of /Structure and Interpretation of 
Computer Programs/:
/Modularity, Objects, and State/ 
(https://mitpress.mit.edu/sicp/full-text/book/book-Z-H-19.html#%_chap_3)
which comes right after /Systems with Generic Operations/.

My current references to step ahead and not get stuck include TinyCLOS. 
GOOPS is - according to the documentation - inspired by it. The nice 
thing about it is this: it's 886 lines of Scheme code in one file which 
can be distributed (see below).

For now I think I will do w/o message passing as GOOPS' /define-class/ 
is one long /letrec/ and of treating Scheme code as s-expressions with 
/cdddr/s. But with it's MOP / class system I can finally try to design 
an application framework with multiple inheritance.

RIght now I have three distinct classes plus a "flat" controller: 
<terminal>, <buffer-view>, <buffer> where buffer denotes a text file 
buffer because it's about a text editor. As the needed functionality and 
structure is building up I can already see <buffer-view> has to "shadow" 
a lot of the functionality from both <terminal> and <buffer> and it 
might turn out that it's hard to keep them synchronized. Let's take for 
example the generic /cursor-up/. The <terminal> is dumb and let's you 
call it as often as you want but it (the underlying VT) keeps the cursor 
on the screen. Now <buffer-view> needs a method /cursor-up/, too. It has 
to make sure it stays in the current region of the buffer on screen and 
it has to call /cursor-up/ for <terminal> explicitly or scroll the 
content or beep etc.

With multiple inheritance it should be enough to call next-method at the 
right moment because any real programmable vi needs an incorporated 
Snake game (often called Nibbles) to remind people of Viper and the 
Virtual Terminal era and the Visual Display Editor.



TinyCLOS
; **********************************************************************
; Copyright (c) 1992 Xerox Corporation.
; All Rights Reserved.
;
; Use, reproduction, and preparation of derivative works are permitted.
; Any copy of this software or of any derivative work must include the
; above copyright notice of Xerox Corporation, this paragraph and the
; one after it.  Any distribution of this software or derivative works
; must comply with all applicable United States export control laws.
;
; This software is made available AS IS, and XEROX CORPORATION DISCLAIMS
; ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING WITHOUT LIMITATION THE
; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
; PURPOSE, AND NOTWITHSTANDING ANY OTHER PROVISION CONTAINED HEREIN, ANY
; LIABILITY FOR DAMAGES RESULTING FROM THE SOFTWARE OR ITS USE IS
; EXPRESSLY DISCLAIMED, WHETHER ARISING IN CONTRACT, TORT (INCLUDING
; NEGLIGENCE) OR STRICT LIABILITY, EVEN IF XEROX CORPORATION IS ADVISED
; OF THE POSSIBILITY OF SUCH DAMAGES.
; **********************************************************************


[-- Attachment #1.2: Type: text/html, Size: 4608 bytes --]

[-- Attachment #2: tiny-clos.scm --]
[-- Type: text/x-scheme, Size: 28011 bytes --]

; Mode: Scheme
;
;
; **********************************************************************
; Copyright (c) 1992 Xerox Corporation.  
; All Rights Reserved.  
;
; Use, reproduction, and preparation of derivative works are permitted.
; Any copy of this software or of any derivative work must include the
; above copyright notice of Xerox Corporation, this paragraph and the
; one after it.  Any distribution of this software or derivative works
; must comply with all applicable United States export control laws.
;
; This software is made available AS IS, and XEROX CORPORATION DISCLAIMS
; ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING WITHOUT LIMITATION THE
; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
; PURPOSE, AND NOTWITHSTANDING ANY OTHER PROVISION CONTAINED HEREIN, ANY
; LIABILITY FOR DAMAGES RESULTING FROM THE SOFTWARE OR ITS USE IS
; EXPRESSLY DISCLAIMED, WHETHER ARISING IN CONTRACT, TORT (INCLUDING
; NEGLIGENCE) OR STRICT LIABILITY, EVEN IF XEROX CORPORATION IS ADVISED
; OF THE POSSIBILITY OF SUCH DAMAGES.
; **********************************************************************
;
; EDIT HISTORY:
;
;      10/**/92  Gregor  Originally Written
; 1.0  11/10/92  Gregor  Changed names of generic invocation generics.
;                        Changed compute-getters-and-setters protocol.
;                        Made comments match the code.
;                        Changed maximum line width to 72.
; 1.1  11/24/92  Gregor  Fixed bug in compute-method-more-specific?,
;                        wrt the use of for-each.
;                        Both methods on allocate instance failed to
;                        initialize fields properly.
;                        The specializers and procedure initargs are
;                        now required when creating a method, that is,
;                        they no longer default.  No working program
;                        should notice this change.
; 1.2  12/02/92  Gregor  Fix minor things that improve portability:
;                         - DEFINE needs 2 args in R4Rs
;                         - Conditionalize printer hooks.
;                         - () doesn't evaluate to ()
;
; 1.3  12/08/92  Gregor  More minor things:
;                         - () really doesn't evaluate to () damnit!
;                         - It turns out DEFINE-MACRO is never used.
;                         - Confusion over the "failure" return value
;                           of ASSQ -- ASSQ returns #f if the key is
;                           not found.
;                         - SEQUENCE   --> BEGIN
;                         - LAST-PAIR  --> last now in support
;                        Change instance rep to protect Schemes that
;                        don't detect circular structures when
;                        printing.
;                        A more reasonable error message when there
;                        are no applicable methods or next methods.
; 1.4  12/10/92  Gregor  Flush filter-in for collect-if.  Add news
;                        classes <input-port> and <output-port>.
;                        Also add 
;
; 1.5  12/17/92  Gregor  Minor changes to class of and primitive
;                        classes to try and deal with '() and #f
;                        better.
;
; 1.6   9/9/93   Gregor  Fix a monstrous bug in the bootstrap of
;                        compute-apply-generic which sometimes ran
;                        user methods on this generic function when
;                        it shouldn't.
;
; 1.7   8/9/94   Gregor  Add Scheme 48 to support.scm.
;
;
;       
(define tiny-clos-version "1.7")

'(;Stuff to make emacs more reasonable.

  (put 'letrec 'lisp-indent-hook 1)

  (put 'make-method  'lisp-indent-hook 1)
  (put 'add-method   'lisp-indent-hook 'defun)

 )
;
; A very simple CLOS-like language, embedded in Scheme, with a simple
; MOP.  The features of the default base language are:
;
;   * Classes, with instance slots, but no slot options.
;   * Multiple-inheritance.
;   * Generic functions with multi-methods and class specializers only.
;   * Primary methods and call-next-method; no other method combination.
;   * Uses Scheme's lexical scoping facilities as the class and generic
;     function naming mechanism.  Another way of saying this is that
;     class, generic function and methods are first-class (meta)objects.
;
; While the MOP is simple, it is essentially equal in power to both MOPs
; in AMOP.  This implementation is not at all optimized, but the MOP is
; designed so that it can be optimized.  In fact, this MOP allows better
; optimization of slot access extenstions than those in AMOP.
; 
;
;
; In addition to calling a generic, the entry points to the default base
; language are:
;
;   (MAKE-CLASS list-of-superclasses list-of-slot-names)
;   (MAKE-GENERIC)
;   (MAKE-METHOD list-of-specializers procedure)
;   (ADD-METHOD generic method)
;
;   (MAKE class . initargs)
;   (INITIALIZE instance initargs)            ;Add methods to this,
;                                             ;don't call it directly.
;   
;   (SLOT-REF  object slot-name)
;   (SLOT-SET! object slot-name new-value)
;
;
; So, for example, one might do:
;
;   (define <position> (make-class (list <object>) (list 'x 'y)))
;   (add-method initialize
;       (make-method (list <position>)
;         (lambda (call-next-method pos initargs)
;           (for-each (lambda (initarg-name slot-name)
;                       (slot-set! pos
;                                  slot-name
;                                  (getl initargs initarg-name 0)))
;                     '(x y)
;                     '(x y)))))
;
;   (set! p1 (make <position> 'x 1 'y 3))
;
;
;
; NOTE!  Do not use EQUAL? to compare objects!  Use EQ? or some hand
;        written procedure.  Objects have a pointer to their class,
;        and classes are circular structures, and ...
;
;
;
; The introspective part of the MOP looks like the following.  Note that
; these are ordinary procedures, not generics.
;
;   CLASS-OF
;
;   CLASS-DIRECT-SUPERS
;   CLASS-DIRECT-SLOTS
;   CLASS-CPL
;   CLASS-SLOTS
;
;   GENERIC-METHODS
;
;   METHOD-SPECIALIZERS
;   METHOD-PROCEDURE
;
;
; The intercessory protocol looks like (generics in uppercase):
;
;   make                        
;     ALLOCATE-INSTANCE
;     INITIALIZE                   (really a base-level generic)
;
;   class initialization
;     COMPUTE-CPL
;     COMPUTE-SLOTS
;     COMPUTE-GETTER-AND-SETTER
;
;   add-method                     (Notice this is not a generic!)
;     COMPUTE-APPLY-GENERIC
;       COMPUTE-METHODS
;         COMPUTE-METHOD-MORE-SPECIFIC?
;       COMPUTE-APPLY-METHODS
;

;
; OK, now let's get going.  But, as usual, before we can do anything
; interesting, we have to muck around for a bit first.  First, we need  
; to load the support library.
;
; Note that there is no extension on the filename in the following load,
; in particular, it isn't "support.scm" even though that is the name of
; the file in the distribution at PARC.  The idea is that when people
; install the code at their site, they should rename all the files to
; the appropriate extension, and then not change the load.  This should
; also make things work with binary files and the like.  This comes from
; my understanding of the CL world...  I hope it is right.
;
;
(load "support")

;
; Then, we need to build what, in a more real implementation, would be
; the interface to the memory subsystem: instances and entities.  The
; former are used for instances of instances of <class>; the latter
; are used for instances of instances of <entity-class>.  In this MOP,
; none of this is visible to base- or MOP-level programmers.
;
; A few things to note, that have influenced the way all this is done:
;  
;   - R4RS doesn't provide a mechanism for specializing the
;     behavior of the printer for certain objects.
;     
;   - Some Scheme implementations bomb when printing circular
;     structures -- that is, arrays and/or lists that somehow
;     point back to themselves.
;
; So, the natural implementation of instances -- vectors whose first
; field point to the class -- is straight on out.  Instead, we use a
; procedure to `encapsulate' that natural representation.
;
; Having gone that far, it makes things simpler to unify the way normal
; instances and entities are handled, at least in the lower levels of
; the system.  Don't get faked out by this -- the user shouldn't think
; of normal instances as being procedures, they aren't. (At least not
; in this language.)  If you are using this to teach, you probably want
; to hide the implementation of instances and entities from people.
;
;
(define %allocate-instance
    (lambda (class nfields)
      (%allocate-instance-internal
       class
       #t
       (lambda args
	 (error "An instance isn't a procedure -- can't apply it."))
       nfields)))

(define %allocate-entity
    (lambda (class nfields)
      (%allocate-instance-internal
       class
       #f
       (lambda args
	 (error "Tried to call an entity before its proc is set."))
       nfields)))

(define %allocate-instance-internal ???)
(define %instance?                  ???)
(define %instance-class             ???)
(define %set-instance-class-to-self ???)   ;This is used only once
                                           ;as part of bootstrapping
                                           ;the braid.
(define %set-instance-proc!  ???)
(define %instance-ref        ???)
(define %instance-set!       ???)

(letrec ((instances '())
	 (get-vector
	  (lambda (closure)
	    (let ((cell (assq closure instances)))
	      (if cell (cdr cell) #f)))))

  (set! %allocate-instance-internal
	(lambda (class lock proc nfields)
	  (letrec ((vector (make-vector (+ nfields 3) #f))
		   (closure (lambda args
			      (apply (vector-ref vector 0) args))))
	    (vector-set! vector 0 proc)
	    (vector-set! vector 1 lock)
	    (vector-set! vector 2 class)
	    (set! instances (cons (cons closure vector) instances))
	    closure)))
		   
  (set! %instance?
        (lambda (x) (not (null? (get-vector x)))))

  (set! %instance-class
	(lambda (closure)
	  (let ((vector (get-vector closure)))
	    (vector-ref vector 2))))

  (set! %set-instance-class-to-self
	(lambda (closure)
	  (let ((vector (get-vector closure)))
	    (vector-set! vector 2 closure))))
		   
  (set! %set-instance-proc!
        (lambda (closure proc)
	  (let ((vector (get-vector closure)))
	    (if (vector-ref vector 1)
		(error "Can't set procedure of instance.")
		(vector-set! vector 0 proc)))))
	
  (set! %instance-ref
        (lambda (closure index)
	  (let ((vector (get-vector closure)))
	    (vector-ref vector (+ index 3)))))
		  
  (set! %instance-set!
        (lambda (closure index new-value)
	  (let ((vector (get-vector closure)))
	    (vector-set! vector (+ index 3) new-value))))
  )


;
; %allocate-instance, %allocate-entity, %instance-ref, %instance-set!
; and class-of are the normal interface, from the rest of the code, to
; the low-level memory system.  One thing to take note of is that the
; protocol does not allow the user to add low-level instance
; representations.  I have never seen a way to make that work.
;
; Note that this implementation of class-of assumes the name of a the
; primitive classes that are set up later.
; 
(define class-of
    (lambda (x)
      (cond ((%instance? x)  (%instance-class x))

	    ((pair? x)        <pair>)         ;If all Schemes were IEEE 
	    ((null? x)        <null>)         ;compliant, the order of
	    ((boolean? x)     <boolean>)      ;these wouldn't matter?
	    ((symbol? x)      <symbol>)
	    ((procedure? x)   <procedure>)
	    ((number? x)      <number>)
	    ((vector? x)      <vector>)
	    ((char? x)        <char>)
	    ((string? x)      <string>)
	    (( input-port? x)  <input-port>)
	    ((output-port? x) <output-port>)
	    

	    )))


;
; Now we can get down to business.  First, we initialize the braid.
;
; For Bootstrapping, we define an early version of MAKE.  It will be
; changed to the real version later on.  String search for ``set! make''.
;

(define make
    (lambda (class . initargs)
      (cond ((or (eq? class <class>)
		 (eq? class <entity-class>))
	     (let* ((new (%allocate-instance
			  class
			  (length the-slots-of-a-class)))
		    (dsupers (getl initargs 'direct-supers '()))
		    (dslots  (map list
				  (getl initargs 'direct-slots  '())))
		    (cpl     (let loop ((sups dsupers)
					(so-far (list new)))
				  (if (null? sups)
				      (reverse so-far)
				      (loop (class-direct-supers
					     (car sups))
					    (cons (car sups)
						  so-far)))))
		    (slots (apply append
				  (cons dslots
					(map class-direct-slots
					     (cdr cpl)))))
		    (nfields 0)
		    (field-initializers '())
		    (allocator
		      (lambda (init)
			(let ((f nfields))
			  (set! nfields (+ nfields 1))
			  (set! field-initializers
				(cons init field-initializers))
			  (list (lambda (o)   (%instance-ref  o f))
				(lambda (o n) (%instance-set! o f n))))))
		    (getters-n-setters
		      (map (lambda (s)
			     (cons (car s)
				   (allocator (lambda () '()))))
			   slots)))

	       (slot-set! new 'direct-supers      dsupers)
	       (slot-set! new 'direct-slots       dslots)
	       (slot-set! new 'cpl                cpl)
	       (slot-set! new 'slots              slots)
	       (slot-set! new 'nfields            nfields)
	       (slot-set! new 'field-initializers (reverse
						   field-initializers))
	       (slot-set! new 'getters-n-setters  getters-n-setters)
	       new))
	    ((eq? class <generic>)
	     (let ((new (%allocate-entity class
					  (length (class-slots class)))))
	       (slot-set! new 'methods '())
	       new))
	    ((eq? class <method>)
	     (let ((new (%allocate-instance
			 class
			 (length (class-slots class)))))
	       (slot-set! new
			  'specializers
			  (getl initargs 'specializers))
	       (slot-set! new
			  'procedure
			  (getl initargs 'procedure))
	       new)))))


;
; These are the real versions of slot-ref and slot-set!.  Because of the
; way the new slot access protocol works, with no generic call in line,
; they can be defined up front like this.  Cool eh?
;
;
(define slot-ref
    (lambda (object slot-name)
      (let* ((info   (lookup-slot-info (class-of object) slot-name))
	     (getter (list-ref info 0)))
	(getter object))))

(define slot-set!
    (lambda (object slot-name new-value)
      (let* ((info   (lookup-slot-info (class-of object) slot-name))
	     (setter (list-ref info 1)))
	(setter object new-value))))

(define lookup-slot-info
    (lambda (class slot-name)
      (let* ((getters-n-setters
	       (if (eq? class <class>)           ;* This grounds out
		   getters-n-setters-for-class   ;* the slot-ref tower.
		   (slot-ref class 'getters-n-setters)))
	     (entry (assq slot-name getters-n-setters)))
	(if entry
	    (cdr entry)
	    (error "No slot" slot-name "in instances of" class)))))



;
; Given that the early version of MAKE is allowed to call accessors on
; class metaobjects, the definitions for them come here, before the
; actual class definitions, which are coming up right afterwards.
;
;
(define class-direct-slots
    (lambda (class) (slot-ref class 'direct-slots)))
(define class-direct-supers
    (lambda (class) (slot-ref class 'direct-supers)))
(define class-slots
    (lambda (class) (slot-ref class 'slots)))
(define class-cpl
    (lambda (class) (slot-ref class 'cpl)))

(define generic-methods
    (lambda (generic) (slot-ref generic 'methods)))

(define method-specializers
    (lambda (method) (slot-ref method 'specializers)))
(define method-procedure
    (lambda (method) (slot-ref method 'procedure)))


;
; The next 7 clusters define the 6 initial classes.  It takes 7 to 6
; because the first and fourth both contribute to <class>.
;
(define the-slots-of-a-class     ;
    '(direct-supers              ;(class ...)        
      direct-slots               ;((name . options) ...)
      cpl                        ;(class ...) 
      slots                      ;((name . options) ...) 
      nfields                    ;an integer
      field-initializers         ;(proc ...)
      getters-n-setters))        ;((slot-name getter setter) ...)
                                 ;
(define getters-n-setters-for-class      ;see lookup-slot-info
    ;
    ; I know this seems like a silly way to write this.  The
    ; problem is that the obvious way to write it seems to
    ; tickle a bug in MIT Scheme!
    ;
    (let ((make-em (lambda (s f)
		     (list s
			   (lambda (o)   (%instance-ref  o f))
			   (lambda (o n) (%instance-set! o f n))))))
      (map (lambda (s)
	     (make-em s (position-of s the-slots-of-a-class)))
	   the-slots-of-a-class)))
(define <class> (%allocate-instance #f (length the-slots-of-a-class)))
(%set-instance-class-to-self <class>)

(define <top>          (make <class>
			     'direct-supers (list)
			     'direct-slots  (list)))

(define <object>       (make <class>
			     'direct-supers (list <top>)
			     'direct-slots  (list)))

;
; This cluster, together with the first cluster above that defines
; <class> and sets its class, have the effect of:
;
;   (define <class>
;     (make <class>
;           'direct-supers (list <object>)
;           'direct-slots  (list 'direct-supers ...)))
;
(slot-set! <class> 'direct-supers      (list <object>))
(slot-set! <class> 'direct-slots       (map list the-slots-of-a-class))
(slot-set! <class> 'cpl                (list <class> <object> <top>))
(slot-set! <class> 'slots              (map list the-slots-of-a-class))
(slot-set! <class> 'nfields            (length the-slots-of-a-class))
(slot-set! <class> 'field-initializers (map (lambda (s)
					      (lambda () '()))
					    the-slots-of-a-class))
(slot-set! <class> 'getters-n-setters  '())


(define <procedure-class> (make <class>
				'direct-supers (list <class>)
				'direct-slots  (list)))

(define <entity-class>    (make <class>
			        'direct-supers (list <procedure-class>)
			        'direct-slots  (list)))

(define <generic>         (make <entity-class>
			        'direct-supers (list <object>)
			        'direct-slots  (list 'methods)))

(define <method>          (make <class>
			        'direct-supers (list <object>)
			        'direct-slots  (list 'specializers
						     'procedure)))



;
; These are the convenient syntax we expose to the base-level user.
;
;
(define make-class
    (lambda (direct-supers direct-slots)
      (make <class>
	    'direct-supers direct-supers
	    'direct-slots  direct-slots)))

(define make-generic
    (lambda ()
      (make <generic>)))

(define make-method
    (lambda (specializers procedure)
      (make <method>
	    'specializers specializers
	    'procedure    procedure)))




;
; The initialization protocol
;
(define initialize (make-generic))
	    

;
; The instance structure protocol.
;
(define allocate-instance (make-generic))
(define compute-getter-and-setter (make-generic))


;
; The class initialization protocol.
;
(define compute-cpl   (make-generic))
(define compute-slots (make-generic))

;
; The generic invocation protocol.
;
(define compute-apply-generic         (make-generic))
(define compute-methods               (make-generic))
(define compute-method-more-specific? (make-generic))
(define compute-apply-methods         (make-generic))




;
; The next thing to do is bootstrap generic functions.
; 
(define generic-invocation-generics (list compute-apply-generic
					  compute-methods
					  compute-method-more-specific?
					  compute-apply-methods))

(define add-method
    (lambda (generic method)
      (slot-set! generic
		 'methods
		 (cons method
		       (collect-if
			(lambda (m)
			  (not (every eq?
				      (method-specializers m)
				      (method-specializers method))))
			(slot-ref generic 'methods))))
      (%set-instance-proc! generic (compute-apply-generic generic))))

;
; Adding a method calls COMPUTE-APPLY-GENERIC, the result of which calls
; the other generics in the generic invocation protocol.  Two, related,
; problems come up.  A chicken and egg problem and a infinite regress
; problem.
;
; In order to add our first method to COMPUTE-APPLY-GENERIC, we need
; something sitting there, so it can be called.  The first definition
; below does that.
; 
; Then, the second definition solves both the infinite regress and the
; not having enough of the protocol around to build itself problem the
; same way: it special cases invocation of generics in the invocation
; protocol.
;
;
(%set-instance-proc! compute-apply-generic
     (lambda (generic)
       (let ((method (car (generic-methods generic))))
	 ((method-procedure method) #f generic))))

(add-method compute-apply-generic
    (make-method (list <generic>)
      (lambda (call-next-method generic)
	(lambda args
	  (if (and (memq generic generic-invocation-generics)     ;* G  c
		   (memq (car args) generic-invocation-generics)) ;* r  a
	      (apply (method-procedure                            ;* o  s
		      (last (generic-methods generic)))           ;* u  e
		     (cons #f args))                              ;* n
	                                                          ;* d
	      ((compute-apply-methods generic)
	       ((compute-methods generic) args)
	       args))))))


(add-method compute-methods
    (make-method (list <generic>)
      (lambda (call-next-method generic)
	(lambda (args)
	  (let ((applicable
		 (collect-if (lambda (method)
			       ;
			       ; Note that every only goes as far as the
			       ; shortest list!
			       ;
			       (every applicable?
				      (method-specializers method)
				      args))
			     (generic-methods generic))))
	    (gsort (lambda (m1 m2)
		     ((compute-method-more-specific? generic)
		      m1
		      m2
		      args))
		   applicable))))))


(add-method compute-method-more-specific?
    (make-method (list <generic>)
      (lambda (call-next-method generic)
	(lambda (m1 m2 args)
	  (let loop ((specls1 (method-specializers m1))
		     (specls2 (method-specializers m2))
		     (args args))
	    (cond ((and (null? specls1) (null? specls2))
                   (error
                     "Two methods are equally specific."))
                  ((or  (null? specls1) (null? specls2))
                   (error
                     "Two methods have a different number of specializers."))
		  ((null? args)
		   (error
                     "Fewer arguments than specializers."))
		  (else
		   (let ((c1  (car specls1))
			 (c2  (car specls2))
			 (arg (car args)))
		     (if (eq? c1 c2)
			 (loop (cdr specls1)
			       (cdr specls2)
			       (cdr args))
			 (more-specific? c1 c2 arg))))))))))


(add-method compute-apply-methods
    (make-method (list <generic>)
      (lambda (call-next-method generic)
	(lambda (methods args)
	  (letrec ((one-step
		     (lambda (tail)
		       (lambda ()
			 (if (null? tail)
			     (error "No applicable methods/next methods.")
			     (apply (method-procedure (car tail))
				    (cons (one-step (cdr tail)) args)))))))
	    ((one-step methods)))))))

(define applicable?
    (lambda (c arg)
      (memq c (class-cpl (class-of arg)))))

(define more-specific?
    (lambda (c1 c2 arg)
      (memq c2 (memq c1 (class-cpl (class-of arg))))))



(add-method initialize
    (make-method (list <object>)
      (lambda (call-next-method object initargs) object)))

(add-method initialize
    (make-method (list <class>)
      (lambda (call-next-method class initargs)
	(call-next-method)
	(slot-set! class
		   'direct-supers
		   (getl initargs 'direct-supers '()))
	(slot-set! class
		   'direct-slots
		   (map (lambda (s)
			  (if (pair? s) s (list s)))
			(getl initargs 'direct-slots  '())))
	(slot-set! class 'cpl   (compute-cpl   class))
	(slot-set! class 'slots (compute-slots class))
	(let* ((nfields 0)
	       (field-initializers '())
	       (allocator
		(lambda (init)
		  (let ((f nfields))
		    (set! nfields (+ nfields 1))
		    (set! field-initializers
			  (cons init field-initializers))
		    (list (lambda (o)   (%instance-ref  o f))
			  (lambda (o n) (%instance-set! o f n))))))
	       (getters-n-setters
		(map (lambda (slot)
		       (cons (car slot)
			     (compute-getter-and-setter class
							slot
							allocator)))
		     (slot-ref class 'slots))))
	  (slot-set! class 'nfields nfields)
	  (slot-set! class 'field-initializers field-initializers)
	  (slot-set! class 'getters-n-setters getters-n-setters)))))

(add-method initialize
    (make-method (list <generic>)
      (lambda (call-next-method generic initargs)
	(call-next-method)
	(slot-set! generic 'methods '())
	(%set-instance-proc! generic
			   (lambda args (error "Has no methods."))))))

(add-method initialize
    (make-method (list <method>)
      (lambda (call-next-method method initargs)
	(call-next-method)
	(slot-set! method 'specializers (getl initargs 'specializers))
	(slot-set! method 'procedure    (getl initargs 'procedure)))))



(add-method allocate-instance
    (make-method (list <class>)
      (lambda (call-next-method class)
	(let* ((field-initializers (slot-ref class 'field-initializers))
	       (new (%allocate-instance
		      class
		      (length field-initializers))))
	  (let loop ((n 0)
		     (inits field-initializers))
	    (if (pair? inits)
		(begin
		 (%instance-set! new n ((car inits)))
		 (loop (+ n 1)
		       (cdr inits)))
		new))))))

(add-method allocate-instance
    (make-method (list <entity-class>)
      (lambda (call-next-method class)
	(let* ((field-initializers (slot-ref class 'field-initializers))
	       (new (%allocate-entity
		      class
		      (length field-initializers))))
	  (let loop ((n 0)
		     (inits field-initializers))
	    (if (pair? inits)
		(begin
		 (%instance-set! new n ((car inits)))
		 (loop (+ n 1)
		       (cdr inits)))
		new))))))


(add-method compute-cpl
    (make-method (list <class>)
      (lambda (call-next-method class)
	(compute-std-cpl class class-direct-supers))))


(add-method compute-slots
    (make-method (list <class>)
      (lambda (call-next-method class)
	(let collect ((to-process (apply append
					 (map class-direct-slots
					      (class-cpl class))))
		      (result '()))
	  (if (null? to-process)
	      (reverse result)
	      (let* ((current (car to-process))
		     (name (car current))
		     (others '())
		     (remaining-to-process
		      (collect-if (lambda (o)
				    (if (eq? (car o) name)
					(begin
					 (set! others (cons o others))
					 #f)
					#t))
				  (cdr to-process))))
		(collect remaining-to-process
			 (cons (append current
				       (apply append (map cdr others)))
			       result))))))))


(add-method compute-getter-and-setter
    (make-method (list <class>)
      (lambda (call-next-method class slot allocator)
	(allocator (lambda () '())))))



;
; Now everything works, both generic functions and classes, so we can
; turn on the real MAKE.
;
;
(set! make
      (lambda (class . initargs)
	(let ((instance (allocate-instance class)))
	  (initialize instance initargs)
	  instance)))

;
; Now define what CLOS calls `built in' classes.
;
;
(define <primitive-class>
    (make <class>
	  'direct-supers (list <class>)
	  'direct-slots  (list)))

(define make-primitive-class
    (lambda class
      (make (if (null? class) <primitive-class> (car class))
	    'direct-supers (list <top>)
	    'direct-slots  (list))))


(define <pair>        (make-primitive-class))
(define <null>        (make-primitive-class))
(define <symbol>      (make-primitive-class))
(define <boolean>     (make-primitive-class))
(define <procedure>   (make-primitive-class <procedure-class>))
(define <number>      (make-primitive-class))
(define <vector>      (make-primitive-class))
(define <char>        (make-primitive-class))
(define <string>      (make-primitive-class))
(define  <input-port> (make-primitive-class))
(define <output-port> (make-primitive-class))


;
; All done.
;
;

'tiny-clos-up-and-running

Re: Message Passing with GOOPS

[Ralf Mattes]

On Wed, Jun 24, 2015 at 10:21:44PM +0200, Michael Tiedtke wrote:
> (use-modules (oop goops))
> 
> GOOPS has some nice features (you can even use unexported methods with
> generics in 1.8) but there is no message passing paradigm. 

Guile's GOOPS is a (rather impressive) clone of CLOS, the Common Lisp Object 
System. I such a system functions/methods don't  "belong" to a class. 

> Objective-C has
> /tell/ Racket has /send/ but Guile/GOOPS is missing /call/.

Message passing only exists in object systems where methods belong to 
a class/object. Generic functions don't "belong" to a class/object.
If you really want to use a far inferior OO system you might want to port
Common Lisp's Flavour system :-)

> 
> This is a first "raw" definition where the parameter /message/ has to be a
> quoted symbol.
> 
> (define-method (call (receiver <object>) message . arguments)
>   (apply (slot-ref receiver message) arguments))
> 
> 
> The class definition still looks like traditional GOOPS but it works.
> 
> An example:
> 
> (define-class <receiver> ()
>   (msg #:init-value (lambda () 'hello-world)))
> 
> (define r (make <receiver>))
> (call r 'msg) => 'hello-world
> 
> 
> Now I'd like to have an easier syntax for describing the slot. The
> definition might be:
> 
> (define-syntax define-message
>   (syntax-rules ()
>     ((_ (message-name arguments ... ) body ...)
>      (message-name #:init-value (lambda (arguments ...) body ...)))))
> 
> But the following example doesn't work in 1.8:
> 
> (define-class <house> ()
>   (define-message (phone n)
>     (repeat n (lambda () (bell) 'rang)) ))
> 
> GOOPS complains about malformed slots and *seems* to see the unexpanded
> form.*

Here:

 $ guile-1.8 
 guile> (use-modules (oop goops))
 guile> define-class
 #<macro! define-class>

Why would you expect a macro to evaluate its arguments? :-)

> I could use a little help here, anyone?* Even for the naming scheme: /send/
> is already used by unix sockets and methods are part of the implementation
> of generics. Perhaps /message/ isn't that bad.

That's what modules are for. 

guile> (define-module (ios) #:export (send))  ; ios = Inferior Object System

and then:

guile> (ios:send ....)

> [...]
> PS
> 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 ...

Why, 3000 lines of C code seems like a rather lean codebase for an objet system.

Just my 0.2 $

 Ralf Mattes

Re: Message Passing with GOOPS

[Marko Rauhamaa]

Ralf Mattes <rm@seid-online.de>:

> Guile's GOOPS is a (rather impressive) clone of CLOS, the Common Lisp
> Object System. I such a system functions/methods don't "belong" to a
> class.
>
> [...]
>
> Message passing only exists in object systems where methods belong to 
> a class/object. Generic functions don't "belong" to a class/object.
> If you really want to use a far inferior OO system you might want to port
> Common Lisp's Flavour system :-)

No doubt GOOPS/CLOS is impressive. Unfortunately, it ultimately left me
cold.

Really, classification is at the root of GOOPS's problems. What I want
is a constructor that gives me objects that can do some interesting
things. The "class" of that object is not that interesting.

GOOPS also, surprisingly, seems to be decades behind in trying to
present objects as collections of slots.

I once heard this story. The French king had a royal ball in honor of
the birthday of the French queen. When some lordly guests presented
their gift, a pair of fancy stockings, the king drew a fit, declaring:
"The Queen of France does not have legs!"

Similarly, in my mind, objects don't have slots, they interact.


Marko

Re: Message Passing with GOOPS

[Pascal J. Bourguignon]

Marko Rauhamaa <marko@pacujo.net> writes:

> GOOPS also, surprisingly, seems to be decades behind in trying to
> present objects as collections of slots.
>
> I once heard this story. The French king had a royal ball in honor of
> the birthday of the French queen. When some lordly guests presented
> their gift, a pair of fancy stockings, the king drew a fit, declaring:
> "The Queen of France does not have legs!"
>
> Similarly, in my mind, objects don't have slots, they interact.

You are right.  Slots are an implementation detail.  Notice that you
have them in all (common) OO systems.  But the difference with CLOS,
with the MOP, (I don't know if GOOPS implements the MOP, Meta Object
Protocol), slots are reified as first class objects, and can be added or
removed from a class (therefore, to all its instances).

This allows you to forget slots as features of classes, but instead, as
an implementation mechanism for certain kinds of relationships.  So you
can define a macro define-associations and use it to describe how your
objects interrelate and interact with others, and this macro will add
slots as needed to implement those associations:

https://github.com/informatimago/abnotation/blob/master/src/core/model.lisp
https://github.com/informatimago/lisp/blob/master/clext/association.lisp#L575


-- 
__Pascal Bourguignon__                 http://www.informatimago.com/
“The factory of the future will have only two employees, a man and a
dog. The man will be there to feed the dog. The dog will be there to
keep the man from touching the equipment.” -- Carl Bass CEO Autodesk

Re: Message Passing with GOOPS

[Marko Rauhamaa]

"Pascal J. Bourguignon" <pjb@informatimago.com>:

> Marko Rauhamaa <marko@pacujo.net> writes:
>
>> Similarly, in my mind, objects don't have slots, they interact.
>
> You are right. Slots are an implementation detail. Notice that you
> have them in all (common) OO systems. But the difference with CLOS,
> with the MOP, (I don't know if GOOPS implements the MOP, Meta Object
> Protocol), slots are reified as first class objects, and can be added
> or removed from a class (therefore, to all its instances).
>
> This allows you to forget slots as features of classes, but instead,
> as an implementation mechanism for certain kinds of relationships. So
> you can define a macro define-associations and use it to describe how
> your objects interrelate and interact with others, and this macro will
> add slots as needed to implement those associations:
>
> https://github.com/informatimago/abnotation/blob/master/src/core/model.lisp
> https://github.com/informatimago/lisp/blob/master/clext/association.lisp#L575

GOOPS seems to have much of that machinery. I don't know if I find it
all that useful. I'm fine with the notion that the object itself decides
what methods it offers. Amending classes or objects from the outside or
after the fact might come in handy but is not high on my shopping list.

However, GOOPS doesn't seem to allow me to control the object
construction as simply as the "lesser" OO systems do. What's more, GOOPS
programs don't look "Schemey" any more.

That's why I have turned away from GOOPS and returned to the basics:

   <URL: https://www.gnu.org/software/guile/manual/html_node/OO-Closur
   e.html#OO-Closure>

The simpleton.scm object system I posted the other day adds only a
thin sugar coating on this approach.


Marko

Re: Message Passing with GOOPS

[Michael Tiedtke]

On 26/06/2015 10:18, Ralf Mattes wrote:
> ...
>> This is a first "raw" definition where the parameter /message/ has to be a
>> quoted symbol.
>>
>> (define-method (call (receiver <object>) message . arguments)
>>    (apply (slot-ref receiver message) arguments))
>>
>>
>> The class definition still looks like traditional GOOPS but it works.
>>
>> An example:
>>
>> (define-class <receiver> ()
>>    (msg #:init-value (lambda () 'hello-world)))
>>
>> (define r (make <receiver>))
>> (call r 'msg) => 'hello-world
>>
>>
>> Now I'd like to have an easier syntax for describing the slot. The
>> definition might be:
>>
>> (define-syntax define-message
>>    (syntax-rules ()
>>      ((_ (message-name arguments ... ) body ...)
>>       (message-name #:init-value (lambda (arguments ...) body ...)))))
>>
>> But the following example doesn't work in 1.8:
>>
>> (define-class <house> ()
>>    (define-message (phone n)
>>      (repeat n (lambda () (bell) 'rang)) ))
>>
>> GOOPS complains about malformed slots and *seems* to see the unexpanded
>> form.*
> Here:
>
>   $ guile-1.8
>   guile> (use-modules (oop goops))
>   guile> define-class
>   #<macro! define-class>
>
> Why would you expect a macro to evaluate its arguments? :-)
The use of macros within macros is yet to be evaluated. But as syntax 
transformers sometimes check their arguments before these expressions 
are expanded if they are macros - one should really think about Scheme's 
macro expansion model.

Do you think syntax transformers have in any way anything to do with the 
evaluation of code?


>
>> I could use a little help here, anyone?* Even for the naming scheme: /send/
>> is already used by unix sockets and methods are part of the implementation
>> of generics. Perhaps /message/ isn't that bad.
> That's what modules are for.
>
> guile> (define-module (ios) #:export (send))  ; ios = Inferior Object System
>
> and then:
>
> guile> (ios:send ....)

Yes, just call it r-0b-delta-36x7 and let people rename it to find out 
what it means.


>
>> [...]
>> PS
>> 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 ...
> Why, 3000 lines of C code seems like a rather lean codebase for an objet system.

Seems like your sentence is not a valid expression in Scheme.