URL: https://linuxfr.org/users/dzecniv/journaux/le-systeme-objet-de-common-lisp-tutoriel-clos
Title: Le système objet de Common Lisp (tutoriel CLOS)
Authors: dzecniv
Date: 2018年10月04日T22:47:06+02:00
License: CC By-SA
Tags: lisp, common_lisp, développement, tutoriel, objects et langage
Score: 29
Salut,
Je continue à bien apprécier le langage Lisp et un des plaisirs récurrents est de travailler avec son système objet. Je vais vous en donner une présentation complète, avec au passage une introduction à son protocole de méta-objet (MOP, meta-object protocole). Si ce faisant ça vous enlève des à priori sur Lisp de la tête ça aura valu le coup ;)
- le nouveau tuto sur le CL Cookbook (en anglais): https://lispcookbook.github.io/cl-cookbook/clos.html
- http://lisp-lang.org/
- bien démarrer: https://lispcookbook.github.io/cl-cookbook/getting-started.html (en 3 clics avec [Portacle](https://shinmera.github.io/portacle/))
- https://github.com/CodyReichert/awesome-cl
- librairies sur Quicklisp: http://quickdocs.org/
- liste non officielle de qui utilise Lisp aujourd'hui: https://github.com/azzamsa/awesome-lisp-companies
- https://lisp-journey.gitlab.io/ (pub perso)
Moi je me suis construit des petites applis pour le terminal, avec du webscraping, de la base de données, et ça roule bien depuis que j'ai trouvé les librairies et la documentation (j'ai tout documenté sur le cookbook ou la "awesome" liste, chanceux-ses). Rapidement (puisque ce n'est pas l'objet de cet article mais je tiens à faire le fanboy), les plaisirs indéniables sont: c'est un langage compilé et on construit donc un exécutable (compilé en langage machine), donc pour distribuer son logiciel ou son appli web c'est un soulagement incroyable (comparé à Python ou autres langage interprétés), les retours immédiats qu'on a grâce au REPL *fonction par fonction* c'est génial, l'inférence de types de SBCL marche bien, la malléabilité du langage est là comme prévu et les parenthèses, c'est très cosy. Et la stabilité n'a pas de prix.
Pour le web il n'y a pas de pratique vraiment établie mais j'y vois énormément de potentiel, notamment par l'activité sur le framework isomorphique [Weblocks](http://40ants.com/weblocks/index.html) (bon tutoriel inside, framework alpha).
Bref, place au CLOS.
# CLOS
CLOS a été ajouté dans le langage en 1988.
Ses fonctionnalités phares sont:
* il est **dynamique**, donc marche parfaitement avec le REPL. Changer la définition d'une classe va mettre à jour les objets existants, et selon un protocole bien défini dont on peut prendre le controle.
* dispatch multiple (polymorphisme, fonctions génériques) et inhéritance multiple
* les définitions de classes et de méthodes ne sont pas couplées
* bonne introspection
* le méta-object protocol permet de controler plein d'aspects du langage objet, et donc *in fine* de créer un autre système objet.
Je recommande deux livres:
- [Object-Oriented Programming in Common Lisp: a Programmer's Guide to CLOS](http://www.communitypicks.com/r/lisp/s/17592186046723-object-oriented-programming-in-common-lisp-a-programmer), by Sonya Keene,
- [the Art of the Metaobject Protocol](http://www.communitypicks.com/r/lisp/s/17592186045709-the-art-of-the-metaobject-protocol), by Gregor Kiczales, Jim des Rivières et al.
voyez aussi
- l'intro dans [Practical Common Lisp](http://www.gigamonkeys.com/book/object-reorientation-generic-functions.html) (online), by Peter Seibel.
- [Common Lisp, the Language](https://www.cs.cmu.edu/Groups/AI/html/cltl/clm/node260.html#SECTION003200000000000000000)
- les spécs [CLOS-MOP specifications](https://clos-mop.hexstreamsoft.com/).
# Classes et instances
## Examples
Ci-dessous on voit comment définir des classes, créer un objet, accéder aux "slots" et de l'héritage simple.
~~~lisp
(defclass person ()
 ((name
 :initarg :name
 :accessor name)
 (lisper
 :initform nil
 :accessor lisper)))
;; => #<standard-class PERSON>
(defvar p1 (make-instance 'person :name "me" ))
;; ^^^^ initarg
;; => #<person {1006234593}>
(name p1)
;;^^^ accessor
;; => "me"
(lisper p1)
;; => nil
;; ^^ initform (slot unbound by default)
(setf (lisper p1) t)
(defclass child (person)
 ())
(defclass child (person)
 ((can-walk-p
 :accessor can-walk-p
 :initform t)))
;; #<standard-class CHILD>
(can-walk-p (make-instance 'child))
;; T
~~~
## Définir des classes (defclass)
On utilise `defclass`.
~~~lisp
(defclass person ()
 ((name
 :initarg :name
 :accessor name)
 (lisper
 :initform nil
 :accessor lisper)))
~~~
les `name` et `lisper` sont deux "slots".
~~~lisp
(class-of p1)
#<standard-class PERSON>
(type-of p1)
PERSON
~~~
La forme générale de `defclass` est:
```
(defclass <class-name> (list of super classes)
 ((slot-1
 :slot-option slot-argument)
 (slot-2, etc))
 (:optional-class-option
 :another-optional-class-option))
```
On peut écrire des classes plus rapidement:
~~~lisp
(defclass point ()
 (x y z))
~~~
(dans ce cas-là, voir plus bas pour accéder aux slots)
ou même sans slots: `(defclass point () ())`.
## Création d'instances (make-instance)
On utilise `make-instance`:
~~~lisp
(defvar p1 (make-instance 'person :name "me" ))
~~~
En général on va s'écrire un constructeur:
~~~lisp
(defun make-person (name &key lisper)
 (make-instance 'person :name name :lisper lisper))
~~~
ainsi on a le contrôle sur les champs requis, etc. Il n'y a pas de
"constructeur" par défaut, mais `make-instance`.
## Slots
### slot-value
`(slot-value <slot-name>)` permet toujours d'accéder à un slot, qui n'aurait pas défini de getter ou de setter.
```lisp
(defvar pt (make-instance 'point))
(inspect pt)
The object is a STANDARD-OBJECT of type POINT.
0. X: "unbound"
1. Y: "unbound"
2. Z: "unbound"
```
Par défaut, un slot n'est pas initialisé, ce serait une erreur de l'accéder:
~~~lisp
(slot-value pt 'x) ;; => condition: the slot is unbound
~~~
On peut utiliser `setf` sur`slot-value` pour "setter" une valeur:
~~~lisp
(setf (slot-value pt 'x) 1)
(slot-value pt 'x) ;; => 1
~~~
sinon, cf plus bas les getter et setters.
### Valeurs par défaut (initarg, initform)
- `:initarg :foo`: mot-clef à utiliser avec `make-instance` pour donner une valeur au slot.
~~~lisp
(make-instance 'person :name "me")
~~~
- `:initform <val>` sert à donner une valeur par défaut, si on n'a pas d'initarg.
### Getters et setters (accessor, reader, writer)
- `:accessor foo`: un accesseur est à la fois un "getteur" et un
"setteur". Le nom donné devient une **fonction générique**.
~~~lisp
(name p1) ;; => "me"
(type-of #'name)
STANDARD-GENERIC-FUNCTION
~~~
- `:reader` et `:writer` sont sans surprise. Seul `:writer` est `setf`-able.
### Slots de classe
`:allocation` sert à dire si le slot est *local* ou *partagé*.
Ils sont locaux par défaut, le mettre à `shared` permet de créer un slot de classe, qui sera égal pour tous les objets de cette classe.
~~~lisp
(defclass person ()
 ((name :initarg :name :accessor name)
 (species
 :initform 'homo-sapiens
 :accessor species
 :allocation :class)))
;; Note that the slot "lisper" was removed in existing instances.
(inspect p1)
;; The object is a STANDARD-OBJECT of type PERSON.
;; 0. NAME: "me"
;; 1. SPECIES: HOMO-SAPIENS
;;> q
(defvar p2 (make-instance 'person))
(species p1)
(species p2)
;; HOMO-SAPIENS
(setf (species p2) 'homo-numericus)
;; HOMO-NUMERICUS
(species p1)
;; HOMO-NUMERICUS
(species (make-instance 'person))
;; HOMO-NUMERICUS
(let ((temp (make-instance 'person)))
 (setf (species temp) 'homo-lisper))
;; HOMO-LISPER
(species (make-instance 'person))
;; HOMO-LISPER
~~~
## Héritage
On a vu que `child` est une sous-classe de `person`.
Chaque objet `child` est aussi une instance de `person`.
~~~lisp
(type-of c1)
;; CHILD
(subtypep (type-of c1) 'person)
;; T
(ql:quickload "closer-mop")
;; ...
(closer-mop:subclassp (class-of c1) 'person)
;; T
~~~
Une sous-classe hérite de tous les slots de ses parents, avec quelques
règles que l'on donne ci-dessous.
La liste des classes qui composent `child` est donc, dans l'ordre de plus spécifique à moins spécifique:
 child <- person <-- standard-object <- t (`standard-object` et `t` sont héritées par défaut) On peut obtenir la liste avec: ~~~lisp (closer-mop:class-precedence-list (class-of c1)) ;; (#<standard-class child>
;; #<standard-class person>
;; #<standard-class standard-object>
;; #<sb-pcl::slot-class sb-pcl::slot-object>
;; #<sb-pcl:system-class t>)
~~~
La superclasse d'un `child` est:
~~~lisp
(closer-mop:class-direct-superclasses (class-of c1))
;; (#<standard-class person>)
~~~
L'héritage des slots respecte les règles suivantes:
- `:accessor` et `:reader` sont combinés (par *union*).
- `:initarg`: pareil, ils sont combinés (*union*).
- `:initform`: on obtient seulement **le plus spécifique** (selon la
 précédence des classes).
- `:allocation` n'est pas hérité.
## Héritage multiple
Facile:
~~~lisp
(defun baby (child person)
 ())
~~~
## Redéfinir une classe ou changer la classe d'un objet
(pour info, tout est configurable avec le MOP)
Quand on change une classe et qu'on l'évalue de nouveau, **toutes les
instances** de cette classe vont être modifées (quand on les accède de
nouveau), et donc certains champs mis à jour, ou ajoutés, ou
supprimés, etc. On peut facilement contrôler ce mécanisme au besoin
(voir la partie MOP).
Avoir cela dans son REPL... pensez-y, c'est ouf ! (en python, il
faudrait relancer son processus ipython et relancer les commandes qui
nous ont permis d'arriver dans un état donné...)
Exemple:
~~~lisp
(defclass person ()
 ((name
 :initarg :name
 :accessor name)
 (lisper
 :initform nil
 :accessor lisper)))
(setf p1 (make-instance 'person :name "me" ))
~~~
~~~lisp
(lisper p1)
;; NIL
(defclass person ()
 ((name
 :initarg :name
 :accessor name)
 (lisper
 :initform t ;; <-- from nil to t :accessor lisper))) (lisper p1) ;; NIL (of course!) (lisper (make-instance 'person :name "You")) ;; T (defclass person () ((name :initarg :name :accessor name) (lisper :initform nil :accessor lisper) (age :initarg :arg :initform 18 :accessor age))) (age p1) ;; => slot unbound error. This is different from "slot missing":
(slot-value p1 'bwarf)
;; => "the slot bwarf is missing from the object #<person...>"
(setf (age p1) 30)
(age p1) ;; => 30
(defclass person ()
 ((name
 :initarg :name
 :accessor name)))
(slot-value p1 'lisper) ;; => slot lisper is missing.
(lisper p1) ;; => there is no applicable method for the generic function lisper when called with arguments #(lisper).
~~~
Pour changer la classe d'un objet on a `change-class`, mais c'est une opération qu'on fera bien moins souvent.
~~~lisp
(change-class p1 'child)
;; we can also set slots of the new class:
(change-class p1 'child :can-walk-p nil)
(class-of p1)
;; #<standard-class CHILD>
(can-walk-p p1)
;; T
~~~
## Pretty printing
Voir un objet sous cette forme n'est pas satisfaisant:
 p1
 ; #<person {1006234593}>
on voudrait donc:
 ; #<person me lisper: t>
Il nous suffit de *spécialiser* la fonction générique `print-object` pour la classe `person` (voir la partie suivante):
~~~lisp
(defmethod print-object ((obj person) stream)
 (print-unreadable-object (obj stream :type t)
 (with-accessors ((name name)
 (lisper lisper))
 obj
 (format stream "~a, lisper: ~a" name lisper))))
~~~
ça donne:
~~~lisp
p1
;; #<person me, lisper: T>
~~~
`print-unreadable-object` affiche les `#<...>`, qui dit au "lecteur
lisp" (qui est programmable!) que cet objet n'est pas
sérialisable. `:type t` demande d'ajouter `PERSON`.
Le même, plus simple:
~~~lisp
(defmethod print-object ((obj person) stream)
 (print-unreadable-object (obj stream :type t)
 (format stream "~a, lisper: ~a" (name obj) (lisper obj))))
~~~
Attention aux slots qui sont `unbound` par défaut.
Le fonctionnement par défaut:
~~~lisp
(defmethod print-object ((obj person) stream)
 (print-unreadable-object (obj stream :type t :identity t)))
~~~
où `:identity` à `t` donne l'adresse `{1006234593}`.
## Introspection
On a va quelques fonctions, voici pour vous donner des idées (le tout avec la librairie portable pour les différentes implémentations du langage
[closer-mop](https://github.com/pcostanza/closer-mop)):
```
closer-mop:class-default-initargs
closer-mop:class-direct-default-initargs
closer-mop:class-direct-slots
closer-mop:class-direct-subclasses
closer-mop:class-direct-superclasses
closer-mop:class-precedence-list
closer-mop:class-slots
closer-mop:classp
closer-mop:extract-lambda-list
closer-mop:extract-specializer-names
closer-mop:generic-function-argument-precedence-order
closer-mop:generic-function-declarations
closer-mop:generic-function-lambda-list
closer-mop:generic-function-method-class
closer-mop:generic-function-method-combination
closer-mop:generic-function-methods
closer-mop:generic-function-name
closer-mop:method-combination
closer-mop:method-function
closer-mop:method-generic-function
closer-mop:method-lambda-list
closer-mop:method-specializers
closer-mop:slot-definition
closer-mop:slot-definition-allocation
closer-mop:slot-definition-initargs
closer-mop:slot-definition-initform
closer-mop:slot-definition-initfunction
closer-mop:slot-definition-location
closer-mop:slot-definition-name
closer-mop:slot-definition-readers
closer-mop:slot-definition-type
closer-mop:slot-definition-writers
closer-mop:specializer-direct-generic-functions
closer-mop:specializer-direct-methods
closer-mop:standard-accessor-method
```
## Annexes
### defclass/std: pour des définitions plus courtes
La libraire [defclass/std](https://github.com/EuAndreh/defclass-std)
est coole mais est peu utilisée.
Cette classe:
~~~lisp
(defclass/std example ()
 ((slot1 slot2 slot3)))
~~~
est transformée en:
~~~lisp
(defclass example ()
 ((slot1
 :accessor slot1
 :initarg :slot1
 :initform nil)
 (slot2
 :accessor slot2
 :initarg :slot2
 :initform nil)
 (slot3
 :accessor slot3
 :initarg :slot3
 :initform nil)))
~~~
# Fonctions génériques
## Exemples
On reprend nos classes:
~~~lisp
(defclass person ()
 ((name
 :initarg :name
 :accessor name)))
;; => #<standard-class PERSON>
(defclass child (person)
 ())
;; #<standard-class CHILD>
(setf p1 (make-instance 'person :name "me"))
(setf c1 (make-instance 'child :name "Alice"))
~~~
Ci-dessous on crée quelques fonctions génériques et on "spécialise" les méthodes pour nos classes, on utilise la combinaision de méthodes avec `before`, `after` et `around`, et des *qualificateurs*.
~~~lisp
(defmethod greet (obj)
 (format t "Are you a person ? You are a ~a.~&" (type-of obj)))
;; style-warning: Implicitly creating new generic function common-lisp-user::greet.
;; #<standard-method GREET (t) {1008EE4603}>
(greet :anything)
;; Are you a person ? You are a KEYWORD.
;; NIL
(greet p1)
;; Are you a person ? You are a PERSON.
(defgeneric greet (obj)
 (:documentation "say hello"))
;; STYLE-WARNING: redefining COMMON-LISP-USER::GREET in DEFGENERIC
;; #<standard-generic-function GREET (2)>
(defmethod greet ((obj person))
 (format t "Hello ~a !~&" (name obj)))
;; #<standard-method GREET (PERSON) {1007C26743}>
(greet p1) ;; => "Hello me !"
(greet c1) ;; => "Hello Alice !"
(defmethod greet ((obj child))
 (format t "ur so cute~&"))
;; #<standard-method GREET (CHILD) {1008F3C1C3}>
(greet p1) ;; => "Hello me !"
(greet c1) ;; => "ur so cute"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Method combination: before, after, around.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod greet :before ((obj person))
 (format t "-- before person~&"))
#<standard-method GREET :BEFORE (PERSON) {100C94A013}>
(greet p1)
;; -- before person
;; Hello me
(defmethod greet :before ((obj child))
 (format t "-- before child~&"))
;; #<standard-method GREET :BEFORE (CHILD) {100AD32A43}>
(greet c1)
;; -- before child
;; -- before person
;; ur so cute
(defmethod greet :after ((obj person))
 (format t "-- after person~&"))
;; #<standard-method GREET :AFTER (PERSON) {100CA2E1A3}>
(greet p1)
;; -- before person
;; Hello me
;; -- after person
(defmethod greet :after ((obj child))
 (format t "-- after child~&"))
;; #<standard-method GREET :AFTER (CHILD) {10075B71F3}>
(greet c1)
;; -- before child
;; -- before person
;; ur so cute
;; -- after person
;; -- after child
(defmethod greet :around ((obj child))
 (format t "Hello my dear~&"))
;; #<standard-method GREET :AROUND (CHILD) {10076658E3}>
(greet c1) ;; Hello my dear
;; call-next-method
(defmethod greet :around ((obj child))
 (format t "Hello my dear~&")
 (when (next-method-p)
 (call-next-method)))
;; #<standard-method greet :around (child) {100AF76863}>
(greet c1)
;; Hello my dear
;; -- before child
;; -- before person
;; ur so cute
;; -- after person
;; -- after child
;;;;;;;;;;;;;;;;;
;; Adding in &key
;;;;;;;;;;;;;;;;;
;; In order to add "&key" to our generic method, we need to remove its definition first.
(fmakunbound 'greet) ;; with Slime: C-c C-u (slime-undefine-function)
(defmethod greet ((obj person) &key talkative)
 (format t "Hello ~a~&" (name obj))
 (when talkative
 (format t "blah")))
(defgeneric greet (obj &key &allow-other-keys)
 (:documentation "say hi"))
(defmethod greet (obj &key &allow-other-keys)
 (format t "Are you a person ? You are a ~a.~&" (type-of obj)))
(defmethod greet ((obj person) &key talkative &allow-other-keys)
 (format t "Hello ~a !~&" (name obj))
 (when talkative
 (format t "blah")))
(greet p1 :talkative t) ;; ok
(greet p1 :foo t) ;; still ok
;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric greet (obj)
 (:documentation "say hello")
 (:method (obj)
 (format t "Are you a person ? You are a ~a~&." (type-of obj)))
 (:method ((obj person))
 (format t "Hello ~a !~&" (name obj)))
 (:method ((obj child))
 (format t "ur so cute~&")))
;;;;;;;;;;;;;;;;
;;; Specializers
;;;;;;;;;;;;;;;;
(defgeneric feed (obj meal-type)
 (:method (obj meal-type)
 (declare (ignorable meal-type))
 (format t "eating~&")))
(defmethod feed (obj (meal-type (eql :dessert)))
 (declare (ignorable meal-type))
 (format t "mmh, dessert !~&"))
(feed c1 :dessert)
;; mmh, dessert !
(defmethod feed ((obj child) (meal-type (eql :soup)))
 (declare (ignorable meal-type))
 (format t "bwark~&"))
(feed p1 :soup)
;; eating
(feed c1 :soup)
;; bwark
~~~
## Fonctions génériques (defgeneric, defmethod)
Une *fonction générique* est une fonction qui est associée à une liste
de méthodes. Lorsqu'elle est appelée elle *dispatch* son exécution à
la méthode la plus appropriée.
La forme de `defmethod` est identique à la définition de fonctions avec `defun`
On a des arguments optionnels, des mots-clefs et un `&rest`.
On peut écrire une `defmethod` directement, auquel cas le système crée la `defgeneric` associée.
~~~lisp
(defgeneric greet (obj)
 (:documentation "says hi")
 ;; implémentation par défaut pour tout type d'objet donnée en argument:
 (:method (obj)
 (format t "Hi")))
~~~
Les arguments peuvent être de trois formes:
1- une variable:
~~~lisp
(defmethod greet (foo)
 ...)
~~~
cette fonction marchera toujours avec n'importe quel type donnée en argument.
2- une variable avec son **spécialiseur**, sous la forme `(var <class>)`:
~~~lisp
(defmethod greet ((foo person))
 ...)
~~~
Cette méthode ne sera appelée que si `foo` est de type `person`. Ça
marche donc aussi pour les `child`.
Si on appelle cette fonction générique avec un type qui n'est pas *applicable* aux méthodes, on obtiendra une erreur:> there is no applicable method for the generic function xxx when called with arguments yyy"
Seuls les arguments obligatoires peuvent être spécialisés (donc, pas les arguments optionnels définis avec `&key`).
3- une variable et un **spécialiseur eql**, sous la forme `(var (eql <val>)`:
~~~lisp
(defmethod feed ((obj child) (meal-type (eql :soup)))
 (declare (ignorable meal-type))
 (format t "bwark~&"))
(feed c1 :soup)
;; "bwark"
~~~
Au lieu de `:soup`, qui est un simple symbole, on peut avoir toute forme Lisp.
Voilà, on peut avoir autant de méthodes du même nom que l'on va, tant
que leurs "lambda liste" (la définition des arguments) est similaire.
(note: le CL Cookbook est un peu plus fourni)
## Multiméthodes
Une multiméthode est une méthode qui spécialise plus d'un argument.
Par conséquent, elles n'appartiennent pas à une classe
particulière. C'est là une des différences d'avec les systèmes objet
traditionnels.
~~~lisp
(defgeneric hug (a b)
 (:documentation "Hug between two persons."))
;; #<standard-generic-function HUG (0)>
(defmethod hug ((a person) (b person))
 :person-person-hug)
(defmethod hug ((a person) (b child))
 :person-child-hug)
~~~
Cf [Practical Common Lisp](http://www.gigamonkeys.com/book/object-reorientation-generic-functions.html#multimethods).
## Contrôler les setters (setf <methode>)
Pour un fonctionnement connu en Python avec le décorateur `@property`,
qui permet de contrôler comment on met à jour un slot:
~~~lisp
(defmethod (setf name) (new-val (obj person))
 (if (equalp new-val "james bond")
 (format t "Dude that's not possible.~&")
 (setf (slot-value obj 'name) new-val)))
(setf (name p1) "james bond") ;; -> no rename
~~~
## Le mécanisme de dispatch
Peu de code, je vous réfère au Cookbook :)
~~~lisp
(defmethod greet ((obj child))
 (format t "ur so cute~&")
 (when (next-method-p)
 (call-next-method)))
;; STYLE-WARNING: REDEFINING GREET (#<standard-class CHILD>) in DEFMETHOD
;; #<standard-method GREET (child) {1003D3DB43}>
(greet c1)
;; ur so cute
;; Hello Alice !
~~~
## Qualificateurs de méthodes (before, after, around)
Dans nos exemples on a vu à quoi servaient `:before`, `:after` et `:around` (des *qualificateurs*):
- `(defmethod foo :before (obj) (...))`
- `(defmethod foo :after (obj) (...))`
- `(defmethod foo :around (obj) (...))`
Ces trois sont donnés par l'implémentation de CLOS par défaut, aussi
appelée la *la combinaison de méthodes standard*.
Les méthodes `before` ou `after` ne retournent pas de valeur, elles
sont utilisée uniquement pour leurs effets de bord. Une méthode
`around` remplace totalement la méthode par défaut, la plus
spécialisée qui allait être appelée (la méthode primaire), mais elle
peut utiliser `call-next-method` pour faire sa popote avant tout le
monde, puis déclencher les méthodes `before`, `after` et la méthode
primaire.
Je vous renvoie au Cookbook pour un résumé plus conséquent de ce mécanisme.
## Autres combinaisons de méthodes
Mais ces `before`, `after` et `around`, définie par la combinaision
*standard*, n'est pas la seule possible !
Les autres s'appellent
 progn + list nconc and max or append min
Vous remarquez donc qu'elles ont le même nom que des opérateurs
lisp. Et en effet, cela permet de cerner leur fonctionnement. La
méthode `progn` est équivalente à appeler **chaque méthode
applicable** l'une après l'autre:
~~~lisp
(progn
 (method-1 args)
 (method-2 args)
 (method-3 args))
~~~
Dans la combinaison standard, on n'aurait appelé uniquement la méthode
la plus spécialisée.
Pour changer la combinaison d'une classe:
~~~lisp
(defgeneric foo (obj)
 (:method-combination progn))
(defmethod foo progn ((obj obj))
;; ^^ ici aussi
 (...))
~~~
Exemple avec **progn**:
~~~lisp
(defgeneric dishes (obj)
 (:method-combination progn)
 (:method progn (obj)
 (format t "- clean and dry.~&"))
 (:method progn ((obj person))
 (format t "- bring a person's dishes~&"))
 (:method progn ((obj child))
 (format t "- bring the baby dishes~&")))
;; #<standard-generic-function DISHES (3)>
(dishes c1)
;; - bring the baby dishes
;; - bring a person's dishes
;; - clean and dry.
(greet c1)
;; ur so cute --> only the most applicable method was called.
~~~
C'est la même idée avec la combinaison `list`:
~~~lisp
(list
 (method-1 args)
 (method-2 args)
 (method-3 args))
~~~
~~~lisp
(defgeneric tidy (obj)
 (:method-combination list)
 (:method list (obj)
 :foo)
 (:method list ((obj person))
 :books)
 (:method list ((obj child))
 :toys))
;; #<standard-generic-function TIDY (3)>
(tidy c1)
;; (:toys :books :foo)
~~~
Les méthodes "around" sont accepétées:
~~~lisp
(defmethod tidy :around (obj)
 (let ((res (call-next-method)))
 (format t "I'm going to clean up ~a~&" res)
 (when (> (length res)
 1)
 (format t "that's too much !~&"))))
(tidy c1)
;; I'm going to clean up (toys book foo)
;; that's too much !
~~~
Et bien sûr, si vous sentez le besoin CLOS nous permet de définir notre propre moyen de combinaison... pingez-moi si vous avez des exemples :)
## Debugging: tracer les appels de méthodes
C'est aussi assez fou. L'outil [trace](http://www.xach.com/clhs?q=trace), défini par le standard, le permet, mais de manière spécifique par implémentation.
Avec SBCL, on a `(trace foo :methods t)`. Cf [cet article du développeur SBCL](http://christophe.rhodes.io/notes/blog/posts/2018/sbcl_method_tracing/).
Par exemple:
~~~lisp
(defgeneric foo (x)
 (:method (x) 3))
(defmethod foo :around ((x fixnum))
 (1+ (call-next-method)))
(defmethod foo ((x integer))
 (* 2 (call-next-method)))
(defmethod foo ((x float))
 (* 3 (call-next-method)))
(defmethod foo :before ((x single-float))
 'single)
(defmethod foo :after ((x double-float))
 'double)
~~~
On la trace:
~~~lisp
(trace foo :methods t)
(foo 2.0d0)
 0: (FOO 2.0d0)
 1: ((SB-PCL::COMBINED-METHOD FOO) 2.0d0)
 2: ((METHOD FOO (FLOAT)) 2.0d0)
 3: ((METHOD FOO (T)) 2.0d0)
 3: (METHOD FOO (T)) returned 3
 2: (METHOD FOO (FLOAT)) returned 9
 2: ((METHOD FOO :AFTER (DOUBLE-FLOAT)) 2.0d0)
 2: (METHOD FOO :AFTER (DOUBLE-FLOAT)) returned DOUBLE
 1: (SB-PCL::COMBINED-METHOD FOO) returned 9
 0: FOO returned 9
9
~~~
# MOP
*Évidemment, étant donné l'ampleur du sujet, ces quelques exemples ne
sont pas représentatifs*.
Vous n'avez pas non plus besoin de comprendre ce qui touche au MOP
pour écrire des classes ;)
## Métaclasses
Les métaclasses sont nécessaires pour contrôler le fonctionnement d'une autre classe.
La métaclasse standard est `standard-class`:
~~~lisp
(class-of p1) ;; #<standard-class PERSON>
~~~
On va la changer pour une des notre, qui va **compter le nombre
d'objets créés**. On peut utiliser ce mécanisme pour auto incrémenter
une clef primaire d'une base de données (cf Postmodern, Mito), logguer
la création d'objets,...
Notre métaclasse hérite de `standard-class`:
~~~lisp
(defclass counted-class (standard-class)
 ((counter :initform 0)))
#<standard-class COUNTED-CLASS>
(unintern 'person)
;; this is necessary to change the metaclass of person.
;; or (setf (find-class 'person) nil)
;; https://stackoverflow.com/questions/38811931/how-to-change-classs-metaclass#38812140
(defclass person ()
 ((name
 :initarg :name
 :accessor name)
 (:metaclass counted-class))) ;; <- metaclass ;; #<counted-class PERSON>
;; ^^^ not standard-class anymore.
~~~
Si vous avez un message à propos de
`validate-superclass`:
~~~lisp
(defmethod closer-mop:validate-superclass ((class counted-class)
 (superclass standard-class))
 t)
~~~
Maintenant on a le contrôle sur `make-instance` pour les `person`:
~~~lisp
(defmethod make-instance :after ((class counted-class) &key)
 (incf (slot-value class 'counter)))
;; #<standard-method MAKE-INSTANCE :AFTER (COUNTED-CLASS) {1007718473}>
~~~
On utilise une méthode `:after`, c'est plus sûr.
Le `&key` est nécessaire, parce que `make-instance` reçoit les `initargs` et cie.
Petit test:
~~~lisp
(defvar p3 (make-instance 'person :name "adam"))
#<person {1007A8F5B3}>
(slot-value p3 'counter)
;; => error. No, our new slot isn't on the person class.
(slot-value (find-class 'person) 'counter)
;; 1
(make-instance 'person :name "eve")
;; #<person {1007AD5773}>
(slot-value (find-class 'person) 'counter)
;; 2
~~~
Et voilà c'était facile !
Et il y a encore un peu plus dans le Cookbook.
# Conclusion
On ne fait pas nécessairement du neuf avec du neuf :p
</div><div class="naked_ctrl">
<form action="/index.cgi/contrast" method="get" name="gate">
<p><a href="http://altstyle.alfasado.net">AltStyle</a> によって変換されたページ <a href="httpS://linuxfr.org/users/dzecniv/journaux/le-systeme-objet-de-common-lisp-tutoriel-clos.md">(-&gt;オリジナル)</a>
/ <label>アドレス: <input type="text" name="naked_post_url" value="httpS://linuxfr.org/users/dzecniv/journaux/le-systeme-objet-de-common-lisp-tutoriel-clos.md" size="22" /></label> <label>モード: <select name="naked_post_mode">
<option value="default">デフォルト</option>
<option value="speech">音声ブラウザ</option>
<option value="ruby">ルビ付き</option>
<option value="contrast" selected="selected">配色反転</option>
<option value="larger-text">文字拡大</option>
<option value="mobile">モバイル</option>
</select>
<input type="submit" value="表示" />
</p>
</form>
</div>