Journal Le système objet de Common Lisp (tutoriel CLOS)

Posté par  . Licence CC By‑SA.
Étiquettes :
28
4
oct.
2018

Sommaire

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

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 (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:

voyez aussi

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.

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

(defclass person ()
  ((name
    :initarg :name
    :accessor name)
   (lisper
    :initform nil
    :accessor lisper)))

les name et lisper sont deux "slots".

(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:

(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:

(defvar p1 (make-instance 'person :name "me" ))

En général on va s'écrire un constructeur:

(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 <object> <slot-name>) permet toujours d'accéder à un slot, qui n'aurait pas défini de getter ou de setter.

(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:

(slot-value pt 'x) ;; => condition: the slot is unbound

On peut utiliser setf surslot-value pour "setter" une valeur:

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

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

(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:

(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:

(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:

(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:

(defclass person ()
  ((name
    :initarg :name
    :accessor name)
   (lisper
    :initform nil
    :accessor lisper)))

(setf p1 (make-instance 'person :name "me" ))
(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.

(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):

(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:

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:

(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:

(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):

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
est coole mais est peu utilisée.

Cette classe:

(defclass/std example ()
  ((slot1 slot2 slot3)))

est transformée en:

(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:

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

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

(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:

(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>):

(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>):

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

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

Contrôler les setters (setf )

Pour un fonctionnement connu en Python avec le décorateur @property,
qui permet de contrôler comment on met à jour un slot:

(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 :)

(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:

(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:

(defgeneric foo (obj)
  (:method-combination progn))

(defmethod foo progn ((obj obj))
;;             ^^ ici aussi
   (...))

Exemple avec progn:

(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:

(list
  (method-1 args)
  (method-2 args)
  (method-3 args))
(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:

(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, 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.

Par exemple:

(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:

(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:

(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:

(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:

(defmethod closer-mop:validate-superclass ((class counted-class)
                                           (superclass standard-class))
  t)

Maintenant on a le contrôle sur make-instance pour les person:

(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:

(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

  • # cl-torrents

    Posté par  . Évalué à 4.

    En fait, le projet que j'aime bien: https://github.com/vindarel/cl-torrents/ pour chercher des torrents en ligne de commande, avec une interface readline (prochaine étape, en cours, un site web dynamique totalement en Lisp).

Suivre le flux des commentaires

Note : les commentaires appartiennent à celles et ceux qui les ont postés. Nous n’en sommes pas responsables.