Introduction

Common Lisp, or rather, its object system, CLOS , provides the user of the language with a completely remarkable mechanism, namely, the meta-object protocol.

Unfortunately, very often this component of the language is undeservedly left without due attention, and in this article I will try to compensate for this somewhat.

In general, what is a meta-object protocol? Obviously, this is a layer of the object system, which, judging by the name, somehow operates on it and controls it.

What is it for? In fact, depending on the language and object system, the list of applications can be almost unlimited. This is both adding declarative code (annotations in Java and attributes in C #), as well as various generation of code and classes in runtime (here you can recall various persistance and ORM frameworks), and much more.

From my personal point of view, the best meta-object protocols have proven themselves in terms of securing design patterns at the level of the object system. Such patterns as, say, singleton, which in languages ​​without a sufficiently developed OOP have to be implemented again and again using the copy-n-paste method, are created in my favorite Common Lisp from just a couple of dozen lines of code and are re-used in the future solely by indicating a metaclass ^[1] .

Nevertheless, in the following text I want to focus on something more interesting, namely, on changing the rules of the object system itself, its very foundations. It was the addition of the possibilities of such a change that was the key goal of the developers of the meta-object protocol for Common Lisp.

So, the rest of the text will be devoted to creating a prototype object system, similar to JavaScript, in Common Lisp, using a meta-object protocol and integrating it into CLOS. The full project code is available on github ^[2] .

Go

Actually, the first thing to do is to create a metaclass for all classes participating in our prototype system.

(defclass prototype-class (standard-class)
  ()
  (:documentation "Metaclass for all prototype classes"))

Just like that. In fact, we need a class of classes solely to redefine the standard mechanisms for working with slots (i.e. class fields) of our objects, and more on that.

In CLOS MOP, each slot in an object in a class is represented by a so-called slot-definition. Slot-definition, as the name implies, defines meta-information about the fields of the class, and they are of two types:

• direct-slot-definiton Actually, as the name implies, they are what we directly specified when defining the class, say using the defclass form .
• effective-slot-definition - "Definition of the actual slot." They describe the slots that exist, roughly speaking, in the objects of our class.

To make the difference understandable, it is worthwhile to describe in more detail the class initialization protocol.

In CLOS, when creating (defining) a class in it (in its meta-object), up to a certain time, only that information is directly stored that we specified (say, in defclass ). This is some information about the fields defined in it ( direct-slot-definition ), this is a list of classes from which it is inherited, and various other things that we, once again, directly indicated during creation. After creating the class, we can edit it some time later.

At some point, a thing happens to the meta object of the class, called finalization. Usually it happens automatically, mainly when creating the first object of the class, but can also be called by hand.

Basically, you can draw some parallels with static class constructors in languages ​​like C #. Finalization, roughly speaking, completes the creation of the class. At this moment, the so-called Class Precedence List is calculated (and if in Russian, the “inheritance order list” of the class, roughly speaking the topological sorting of all classes from which ours is inherited), and based on this information the “actual” slots that are objects of our class will be stored.

So, the “definition of an immediate slot” stores only the most general information about the slot, while the definition of “actual” stores, including information about the index of the slot in the object’s memory, which cannot be calculated until the class is finalized.

In principle, all the described mechanisms can be redefined through a meta-object protocol, but we will limit ourselves to just a few.

Let's create our slot definition classes.

(defclass direct-hash-slot-definition (standard-direct-slot-definition)
  ()
  (:default-initargs :allocation :hash))
(defclass effective-hash-slot-definition (standard-effective-slot-definition)
  ()
  (:default-initargs :allocation :hash))

Now we redefine two generalized functions from the MOP that indicate which classes of slot definitions our metaclass should use when creating slot definitions.

(defmethod direct-slot-definition-class ((class prototype-class) &rest initargs)
  (declare (ignore initargs))
  (find-class 'direct-hash-slot-definition))
(defmethod effective-slot-definition-class ((class prototype-class) &rest initargs)
  (declare (ignore initargs))
  (find-class 'effective-hash-slot-definition))

It can be seen above that the metaobjects of the slot definitions take the argument : allocation . What is it? This is a specifier indicating where space is allocated for the fields of objects. The CL standard mentions two kinds of such qualifiers. The first one is : class , which means that the place will be allocated in the class itself, i.e. it is an analogue of static fields from other languages, and the second - : instance - the place will be allocated for each object of the class, usually in some array associated with it. We specified our specifier - : hash . What for? And then, by default, the fields will be stored in some hash plate associated with the object, similar to how this is done in JavaScript.

Where do we define the hash slot? And, after all, somewhere else we want to store the prototype of the object. We will proceed as follows - we will define the prototype-object class , which will be the top of the hierarchy of all classes working with our system. As you can see below, we will define the slots with the prototype and with the fields with instance allocation .

Before we create this class, we must allow our prototype-class classes to inherit from standard classes and vice versa. The validate-superclass function is called during the finalization process described above. If at least one of the options is the parent-heir, for any of the inherited classes, it returns nilThe standard CLOS mechanism signals an exception.

(defmethod validate-superclass ((class prototype-class) (super standard-class))
  t)
(defmethod validate-superclass ((class standard-class) (super prototype-class))
  t)
(defclass prototype-object ()
  ((hash :initform (make-hash-table :test #'eq)
         :reader hash
         :allocation :instance
         :documentation "Hash table holding :HASH object slots")
   (prototype :initarg :prototype
              :accessor prototype
              :allocation :instance
              :documentation "Object prototype or NIL."))
  (:metaclass prototype-class)
  (:default-initargs :prototype nil)
  (:documentation "Base class for all prototype objects"))

Let's further define two functions similar to those of the standard CLOS. What they do, I think it’s clear:

(defun prototype-of (object)
  "Retrieves prototype of an OBJECT"
  (let ((class (class-of object)))
    (when (typep class 'prototype-class)
      (prototype object))))
(defgeneric change-prototype (object new-prototype)
  (:documentation "Changes prototype of OBJECT to NEW-PROTOTYPE")
  (:method ((object prototype-object) new-prototype)
    (setf (prototype object) new-prototype)))

Now a little hack. In the standard CLOS, if in defclass we did not specify a single parent class that is standard-object , and the metaclass of our class is an ordinary standard-class , then such a class, itself standard-object itself , is injected into the list of classes from which we inherited. We will do the same with our prototype-class and prototype-object . To do this, override the standard functions used by the object constructor.

(defun fix-class-initargs (class &rest args &key ((:direct-superclasses dscs) '()) &allow-other-keys)
"Fixup :DIRECT-SUPERCLASSES argument for [RE]INITIALIZE-INSTANCE gf
  specialized on prototype classes to include PROTOTYPE-OBJECT in
  superclass list"
  (remf args :direct-superclasses)
  (unless (or (eq class (find-class 'prototype-object))
              (find-if (lambda (c)
                         (unless (symbolp c) (setf c (class-name c)))
                         (subtypep c 'prototype-object))
                       dscs))
    (setf dscs (append dscs (list (find-class 'prototype-object)))))
  (list* :direct-superclasses dscs args))
(defmethod initialize-instance :around ((class prototype-class) &rest args &key &allow-other-keys)
  (apply #'call-next-method class (apply #'fix-class-initargs class args)))
(defmethod reinitialize-instance :around ((class prototype-class) &rest args &key &allow-other-keys)
  (apply #'call-next-method class (apply #'fix-class-initargs class args)))

Now the fun part.

The first is that in order to work with object slots through a hash plate stored in our objects, we need to redefine four standard operations for working with slots for our classes - namely, taking the value of a slot, setting it, checking that the slot is connected to the value and deleting such a connection. All these operations are perfectly implemented by the hash-tag; inside these operations, we check whether : allocation of the slot is hash , which indicates that our slot is stored in it, and if not, we use the standard mechanism for accessing the fields of the CLOS object.

(defmethod slot-boundp-using-class ((class prototype-class) (object prototype-object) slotd)
  (if (eq :hash (slot-definition-allocation slotd))
    (nth-value 1 (gethash (slot-definition-name slotd) (hash object)))
    (call-next-method)))
(defmethod slot-makunbound-using-class ((class prototype-class) (object prototype-object) slotd)
  (if (eq :hash (slot-definition-allocation slotd))
    (remhash (slot-definition-name slotd) (hash object))
    (call-next-method)))
(defmethod slot-value-using-class ((class prototype-class) (object prototype-object) slotd)
  (if (eq :hash (slot-definition-allocation slotd))
    (values (gethash (slot-definition-name slotd) (hash object)))
    (standard-instance-access object (slot-definition-location slotd))))
(defmethod (setf slot-value-using-class) (new-value (class prototype-class) (object prototype-object) slotd)
  (if (eq :hash (slot-definition-allocation slotd))
    (values (setf (gethash (slot-definition-name slotd) (hash object))
                  new-value))
    (setf (standard-instance-access object (slot-definition-location slotd))
          new-value)))

Now prototypes. As you know, in JavaScript, the value of a field is looked up by a prototype chain. If there is no field in the object, the entire hierarchy is recursively traversed, and in the absence of a field for any of the objects, undefined is returned. At the same time, in JS there is a mechanism of "overlapping" fields. This means that if a field is set / defined in the object with a name similar to the field name of any of the objects in the prototype hierarchy, then the next time you access this field, the value will be taken from it, without any hierarchy following.

We implement similar functionality. To do this, we need to override the generic slot-missing function . It is called when the functions for working with slots ( slot-value, (setf slot-value), slot-boundp, slot-makunbound) detect the absence of the field with the requested name in the class of the object. This generalized function takes an extremely convenient set of arguments — the metaobject of the object's class, the object itself, the name of the field, the name of the “failed” operation, and, for the value setting operation, the new field value.

We proceed as follows. Before overriding this function, we will create an additional class of signals (Common Lisp inclusions), the objects of which will be thrown out if the prototype is found to be missing. Also, create an additional analogue of the prototype-of function defined above .

(define-condition prototype-missing (condition)
  ()
  (:documentation
   "Signalled when an object is not associated with a prototype."))
(defun %prototype-of (class instance)
"Internal function used to retreive prototype of an object"
  (if (typep class 'prototype-class)
    (or (prototype instance) (signal 'prototype-missing))
    (signal 'prototype-missing)))

Now we define our method. The working scheme is as follows: for two of the four operations, we recursively traverse the prototype hierarchy, and ultimately throw a prototype-missing exception . At the top of the call stack, we install a handler that, intercepting the signal, returns us some default value - in this case nil . The other two operations, as explained above, do not need to recursively traverse prototypes.

(defvar *prototype-handler* nil
  "Non-NIL when PROTOTYPE-MISSING handler is already installed on call stack.")
(defun %slot-missing (class instance slot op new-value)
"Internal function for performing hash-based slot lookup in case
of it is missing from class definition."
  (let ((hash (hash instance)))
    (symbol-macrolet ((prototype (%prototype-of class instance)))
      (case op
        (setf
         (setf (gethash slot hash) new-value))
        (slot-makunbound
         (remhash slot hash))
        (t (multiple-value-bind
                 (value present) (gethash slot hash)
             (ecase op
               (slot-value
                (if present
                  value
                  (slot-value prototype slot)))
               (slot-boundp
                (if present
                  t
                  (slot-boundp prototype slot))))))))))
(defmethod slot-missing ((class prototype-class) (instance prototype-object) slot op &optional new-value)
  (if *prototype-handler*
    (%slot-missing class instance slot op new-value)
    (handler-case
        (let ((*prototype-handler* t))
          (%slot-missing class instance slot op new-value))
      (prototype-missing () nil))))

Done! Actually, in no more than 150 lines of code, we got a working prototype object-oriented system, similar to that in JavaScript. Moreover, this system is fully integrated with the standard CLOS, and allows, say, the participation of "ordinary" objects in the hierarchy of prototypes. Another feature - we can not create our own classes of objects at all, but get by with just one prototype-object , in case we want from it a behavior completely identical to JS.

What can be added? Probably on top of such a system using reader macros you can make JSON-like syntax. But, this is the topic of a separate article.

Finally, a few examples:

(defvar *proto* (make-instance 'prototype-object))
(defclass foo ()
  ((a :accessor foo-a))
  (:metaclass prototype-class))
(defvar *foo* (make-instance 'foo :prototype *proto*))
(defvar *bar* (make-instance 'prototype-object :prototype *foo*))
(setf (slot-value *proto* 'x) 123)
(slot-value *bar* 'x)
;;; ==> 123
(setf (foo-a *foo*) 456)
(slot-value *bar* 'a)
;;; ==> 456
(setf (slot-value *bar* 'a) 789)
(setf (foo-a *foo*) 'abc)
(slot-value *bar* 'a)
;;; ==> 789
;;; because we've introduced new property for *bar*
(defclass quux ()
  ((the-slot :initform 'the-value))
  (:documentation "Simple standard class"))
(defvar *quux* (make-instance 'quux))
(change-prototype *bar* *quux*)
(slot-value *bar* 'the-slot)
;;; ==> THE-VALUE
(slot-value *bar* 'x)
;;; When attempting to read the slot's value (slot-value), the slot
;;; X is missing from the object #.
;;;   [Condition of type SIMPLE-ERROR]

[1] http://love5an.livejournal.com/306670.html
[2] https://github.com/Lovesan/Prototype