Introduction

Common Lisp, more specifically, its object system, CLOS , provides the user with a language with a completely wonderful mechanism, namely, the meta-object protocol.

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

In general, what is a metaobject protocol? Obviously, this is a layer of the object system, which, judging by the name, in some way operates on it and controls it.
')
What is it for? In fact, depending on the language and the object system, the list of applications can be almost limitless. This includes adding declarative code (annotations in Java and attributes in C #), as well as various code and class generation 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 recommended themselves to consolidate design patterns at the object system level. Patterns like, say, singleton, which in languages ​​without a sufficiently developed OOP have to be implemented again and again using the copy-n-paste method, in my favorite Common Lisp are created literally from a couple dozen lines of code and are reused later on by indicating the metaclass ^[1] .

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

So, the following text will be devoted to creating a prototype object system, similar to JavaScript, in Common Lisp, using the 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 create a metaclass for all classes participating in our prototype system.

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

This is how simple it is. In fact, we need the class of classes only to redefine the standard mechanisms for working with slots (that is, class fields) in our objects, and more on that.

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

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

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

In CLOS, when creating (defining) a class, up to a certain time, only the information we specified (say, in defclass ) is stored in it (in its metaobject). 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, I repeat, directly indicated during creation. After creating the class, we can edit it some time later.

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

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

So, the “definition of the direct slot” stores only the most general information about the slot, while the definition of “actual” stores including information about the slot index in the object memory, which cannot be calculated until the finalization of the class.

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

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 will redefine two generalized functions from MOP, which indicate which classes of definitions of slots our metaclass should use when defining slots, creation.

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

As seen above, the metaobjects of slot definitions accept an argument : allocation . What is it? This is a specifier that indicates where space is allocated for the object fields. The CL standard mentions two kinds of such specifiers. The first is : class , which means that space will be allocated in the class itself, i.e. this is an analogue of static fields from other languages, and the second is :: instance — space will be allocated for each class object, 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 label associated with the object, just like it is done in JavaScript.

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

Before we create this class, we must allow our classes of the type prototype-class to inherit from standard classes and back. The validate-superclass function is called during the finalization process, which is described above. In the event that at least one of the variants, the heir-parent, for any of the inherited classes, returns nil , the 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 is 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 small hack. In the standard CLOS, if we did not specify a single parent class that is standard-object in defclass , and the metaclass of our class is the usual standard-class , then such a class, the 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 go through a hash label stored in our objects, we need to redefine four standard operations for working with slots for our classes - namely, taking the slot value, setting it, checking the slot for connectivity with the value, and deleting such a connection. All these operations are perfectly implemented by a hash table; inside these operations, we check whether the : allocation slot : hash , which indicates that our slot is stored in it, and if not - then use the standard CLOS object access mechanism.

 (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 the prototypes. As you know, in JavaScript, the value of the field is searched by a chain of prototypes. If there is no field in the object, the entire hierarchy is recursively bypassed, 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 for "overlapping" of fields. This means that if an object is set / determined 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 following the hierarchy.

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

We proceed as follows. Prior to redefining this function, we will create an additional class of signals (including Common Lisp inclusions) whose objects will be thrown out if there is a lack of a prototype for the object. Also, create an additional analog 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 scheme of work is as follows: for two of the four operations, we recursively go around the prototype hierarchy, and eventually throw out the prototype-missing exception. At the top of the call stack, we install a handler, which, intercepting the signal, returns us some default value - in this case nil . Two other operations, as explained above, do not need recursive traversal of 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, 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 standard CLOS, and allows, say, the participation of “ordinary” objects in the prototype hierarchy. Another peculiarity is that we can not create our own classes of objects at all, but manage with only one prototype-object , in case we want a behavior from it that is completely identical to JS.

What can I add? Probably, on top of such a system with the help of reader macros you can make a JSON-like syntax. But this is a topic for 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 #<QUUX {255A4C89}>. ;;; [Condition of type SIMPLE-ERROR] 

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