Meta Protocol Common Lisp for example the implementation of a prototype object system

Introduction

Common Lisp, or rather, its object system, CLOS gives the language user an absolutely wonderful mechanism, namely, the meta Protocol.

Unfortunately, very often this component of language remains unfairly neglected, and in this article I will try to compensate for some.

Anyway, what is meta Protocol? Obviously, this layer is the object system, which, judging by the title, in any way, operates on her and controls her.

What is it for? In fact, depending on the language and the object system, the list of uses can be almost limitless. It's like adding declarative code(annotations in Java and attributes in C#), and a variety of code generation and the runtime class(here we can recall various persistance frameworks and ORM) and more.

From my personal point of view, the best meta protocols established from the consolidation of design patterns at the level of the object system. Such patterns, like the singleton, which in languages without sufficiently developed the PLO have again and again to implement the method of copy-n-paste, in my favorite Common Lisp are generated from literally a couple of dozen lines of code and pereobulsya in the future exclusively to the indication of the metaclass^[1].

However, in the following text I want to focus on something more interesting — namely, a change in the rules of the object system, its fundamentals. It is the addition of such changes was the key goal of the developers of the meta Protocol for Common Lisp.

So, the further text will focus on creating a prototype object system like JavaScript, Common Lisp, using the meta Protocol and integration of it in CLOS. Full project code is available on github^[2].

the

Gone

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

the

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

That's so simple. Actually, class classes, we need only to override the default mechanisms work with slots(i.e., fields of the class) at our facilities, and discuss this in more detail.

At the CLOS MOP each slot object in the class is the so-called slot-definition. Slot-definition, as the name implies, define meta-information about the class fields, and they are of two types:

the

the
• direct-slot-definition in Fact, as perhaps the name implies, they represent what we directly pointed at the class definition, for example using forms defclass.
the
• effective-slot-definition — "Determining the actual slot". They describe slots that there are, roughly speaking, the objects of our class.

The difference was clear, it should describe in greater detail the Protocol class initialization.

In CLOS, when creating(defining) a class in it(in its metaObject) until a certain time is stored directly, only the information that we have specified(for example, in defclass). This is some information about certain fields in it(direct-slot-definition) is a list of classes from which it inherits, and various other things that we, once again, pointed directly at creation. After creating the class, we are some time later unable to edit it.

At a certain point, with a metaObject class is some thing called finalization. Usually it happens automatically, mostly when you first create the class object, but it can also be called hands.

In principle, it is possible to draw some Parallels with the static constructors of classes in languages like C#. Finalized, roughly speaking, is completing the class. At this point, calculated the so-called Class Precedence List(as if in Russian, "list of succession" of a class, roughly speaking, a topological sorting of all classes from which our inherited), and based on this information, determined by the "actual" slots that the objects of our class will be stored.
So, "define the direct slot" keeps only the most General information about the slot, while the definition of "actual" stores including information about the index of the slot in the memory of the object, which cannot be calculated prior to the finalization of the class.

In principle, all the described mechanisms can be overridden using the meta Protocol, but we confine ourselves to a few.

Let's create our classes definitions of slots.

the

(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 override two generalized functions of the MOP that indicate what classes of definitions of slots our metaclass must use them, definitions of slots you create.

the

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

Above shows that metaobjects definitions of slots accept the argument :allocation. What is it? This specifier indicating where is allocated a place under object fields. The CL standard mentions two types of specifiers. The first — :class, which means that the seat will stand out in the class, i.e. it is the analogue of the static fields from other languages, and the second :instance place will be allocated for each object class, typically in a array connected with it. We have also pointed out your specifier — a hash. Why? And then, by default, the fields are to be stored in some hash label associated with the object, like in JavaScript.

Where do we define the slot with a hash sign? And, we're somewhere else you want to store the object prototype. We will proceed in the following way: we define the class prototype object, which we will have the top of the hierarchy of all classes that work with our system. As seen below, the slots with the prototype and with fields, we define instance allocation.

Before we create this class, we have to allow our classes of the form prototype-class to inherit from standard classes and back. The validate-superclass is invoked in the finishing process, which is described above. If at least one of the embodiments, the heir-parent, for any of the inherited classes, returned to nil, a standard mechanism for CLOS signals an exception.

the

(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 "the prototype Object or NIL."))
(:metaclass prototype-class)
(:default-initargs :prototype nil)
(:documentation "Base class for all prototype objects"))

Let us further define two functions to be similar in standard CLOS. What they are doing, I think it is clear:

the

(defun prototype-of (object)
"Retrieves the prototype of an OBJECT"
(let ((class (class-of object)))
(when (typep class 'prototype-class)
(prototype object))))

(defgeneric change-prototype (object new-prototype)
(:documentation "Changes the 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 defclass did not indicate any of the parent class is standard-object and the metaclass of our class — normal standard-class, then the class itself standard-object, will inject into a list of classes from which we inherit. We will do the same with our prototype-class and prototype object. For this you need to override the default functions used by the designer.

the

(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 is c) (setf c (class-name c)))
(subtypep 'c' prototype-object))
dscs))

(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 to work with slots of objects went through a hash sign stored in our objects, we need to override classes for our four standard operations of slots — namely, taking the value of the slot, the installation thereof, the check for connectivity slot with a value and the removal of such communication. All these operations are implemented perfectly, the hash sign, inside of these operations we check whether :allocation slot :hash, which indicates that our slot is stored in it, and if not — then use the standard mechanism to access fields of the object CLOS.

the

(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 the prototype chain. If a field in the object does not recursively complete the whole hierarchy, and in the absence of fields from any object, it returns undefined. At the same time, in JS there is a mechanism called "overlap" fields. This means that if the object is set/is determined by the field with the same name as a field name any of the objects in the hierarchy of prototypes, the next time you access this field, the value will be taken out of it, without any repetition of the hierarchy.

We implement the same functionality. For this we need to override the aggregate function slot-missing. It is invoked when functions with slots(slot-value, (setf slot-value), slot-boundp, slot-makunbound) show the absence of a field with the requested name in the class object. This aggregate function takes an extremely convenient set of arguments — the class metaObject of the object, the object itself, the field name, the name of the "failure" of the surgery, and for the operation of the set value — the new value of the field.

We proceed as follows. To override this functionality, create an additional class of signals(an exception is Common Lisp), the objects of which are to be discarded in case of detecting the lack of the prototype. Also, create additional analogue videopreteen function prototype of.

the

(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 (instance prototype) (signal 'prototype-missing))
(signal 'prototype-missing)))

Now define our method. The scheme works as follows: for two of the four operations, we recursively go around a hierarchy of prototypes, and ultimately throw the exception prototype-missing. On top of the call stack we install a handler that, intercepting the signal, returns a default value — in this case, nil. Two other operations, as explained above, in the recursive bypass of prototypes is not needed.

the

(defvar *prototype-handler* nil
"Non-NIL when PROTOTYPE IS MISSING handler is already installed on the call stack.")

(defun %slot-missing (class instance slot op new-value)
"Internal function for performing hash-based lookup slot 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

value
(slot-value slot prototype)))
(slot-boundp
(if present
t
(slot-boundp slot prototype))))))))))

(defmethod slot-missing ((class prototype-class) (instance prototype-object) slot op &optional new-value)
(if *prototype the handler*
(%slot-missing class instance slot op new-value)
(handler-case
(let ((*prototype the handler* t))
(%slot-missing class instance slot op new-value))
(prototype-missing () nil))))

Ready! In fact, 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, for example, the participation of "ordinary" objects in a hierarchy of prototypes. Another feature is that we can not create its object classes, and to do only one prototype object, if we want from her behavior, is identical to JS.

What can I add? Probably on top of this system using the reader-macro you can make a JSON-like syntax. But that's a topic for another article.

Finally, a few examples:

the

(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
;;; The 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

Article based on information from habrahabr.ru