Введение

Common Lisp, а точнее, его объектная система, CLOS, предоставляет пользователю языка совершенно замечательный механизм, а именно, метаобъектный протокол.

К сожалению, очень часто этот компонент языка незаслуженно обходится без должного внимания, и в данной статье я постараюсь это несколько компенсировать.

Вообще, что такое метаобъектный протокол? Очевидно, это слой объектной системы, который, судя по названию, каким-либо образом оперирует над ней самой, и управляет ей.

Для чего он нужен? На самом деле, в зависимости от языка и объектной системы, список применений может быть практически безграничен. Это как добавление коду декларативности(аннотации в Java и аттрибуты в C#), так и разнообразная генерация кода и классов в рантайме(здесь можно вспомнить разнообразные persistance и ORM фреймворки), так и многое другое.

С моей лично точки зрения, лучше всего метаобъектные протоколы себя зарекомендовали со стороны закрепления паттернов проектирования на уровне объектной системы. Такие паттерны, как, скажем, синглтон, которые в языках без достаточно развитого ООП приходится снова и снова реализовывать методом copy-n-paste, в моем любимом Common Lisp создаются буквально из пары десятков строчек кода и переиспользуются в дальнейшем исключительно указанием метакласса^[1].

Тем не менее, в нижеследующем тексте я хочу сосредоточиться на кое-чем более интересном, а именно — на изменении правил работы самой объектной системы, самих ее основ. Именно добавление возможностей подобного изменения и было ключевой целью разработчиков метаобъектного протокола для Common Lisp.

Итак, дальнейший текст будет посвящен созданию прототипной объектной системы, подобной JavaScript, в Common Lisp, с использованием метаобъектного протокола и интеграцией ее в CLOS. Полный код проекта доступен на github^[2].

Поехали

Собственно первое, что нужно сделать, это создать метакласс для всех классов, участвующих в нашей прототипной системе.

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

Вот так вот просто. На самом деле, класс классов нам нужен исключительно для переопределения стандартных механизмов работы со слотами(т.е. полями класса) у наших объектов, и об этом чуть подробнее.

В CLOS MOP каждый слот объекта в классе представляется так называемыми slot-definition. Slot-definition, как понятно из названия, определяют метаинформацию о полях класса, а бывают они двух видов:

• direct-slot-definiton Собственно, как, возможно, понятно из названия, представляют собой они то, что мы непосредственно указали при определении класса, скажем с помощью формы defclass.
• effective-slot-definition — «Определение фактического слота». Они описывают слоты, которые существуют, грубо говоря, в объектах нашего класса.

Чтобы разница была понятна, стоит подробнее описать протокол инициализации классов.

В CLOS, при создании(определении) класса в нем(в его метаобъекте) до определенного времени хранится непосредственно только та информация, которую мы указали(скажем, в defclass). Это какая-то информация об определенных в нем полях(direct-slot-definition), это список классов от которых он наследуется, и разные другие вещи которые мы, еще раз повторюсь, непосредственно указали при создании. После создания класса, мы некоторое время спустя можем его редактировать.

В определенный момент, с метаобъектом класса происходит некоторая вещь, называемая финалазацией. Обычно она происходит автоматически, в основном при создании первого объекта класса, но может также быть вызывана руками.

В принципе, можно провести некоторые параллели со статическими конструкторами классов в языках вроде C#. Финализация, грубо говоря, завершает создание класса. В этот момент высчитывается так называемый Class Precedence List(а если по-русски, «список порядка наследования» класса, грубо говоря топологическая сортировка всех классов, от которых наш наследуется), и на основе этой информации определяются «фактические» слоты, которые объекты нашего класса будут хранить.

Так вот, «определение непосредственного слота» хранит только самую общую информацию о слоте, в то время как определение «фактического» хранит в том числе информацию об индексе слота в памяти объекта, которая не может быть вычислена до финализации класса.

В принципе, все описанные механизмы можно переопределить через метаобъектный протокол, но мы ограничимся лишь несколькими.

Создадим наши классы определений слотов.

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

Теперь переопределим две обобщенные функции из MOP, которые указывают, классы каких определений слотов наш метакласс должен использовать, при их, определений слотов, создании.

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

Выше видно, что метаобъекты определений слотов принимают аргумент :allocation. Что это? Это спецификатор, указывающий, где выделяется место под поля объектов. Стандарт CL упоминает о двух видах таких спецификаторов. Первый — :class, который означает что место будет выделяться в самом классе, т.е. это аналог статических полей из других языков, и второй — :instance — место будет выделяться для каждого объекта класса, обычно в некотором массиве связаным с ним. Мы же указали свой спецификатор — :hash. Зачем? А затем, что по дефолту, поля у нас будут храниться в некоторой хэш-табличке, связанной с объектом, подобно тому как это делается в JavaScript.

Где же мы определим слот с хэш-табличкой? И, мы ведь где-то еще хотим хранить прототип объекта. Мы поступим следующим образом — мы определим класс prototype-object, который будет у нас вершиной иерархии всех классов, работающих с нашей системой. Как видно ниже, слоты с прототипом и с полями мы определим с instance allocation.

Прежде, чем мы создадим этот класс, мы должны разрешить нашим классам вида prototype-class наследоваться от стандартных классов и обратно. Функция validate-superclass вызывается в процессе финализации, который описан выше. В случае если хотя бы один из вариантов наследник-родитель, для любого из наследуемых классов, вернул nil, стандартный механизм CLOS сигнализирует исключение.

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

Давайте дополнительно определим две функции, подобные аналогичным из стандартной CLOS. Что они делают, думаю понятно:

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

Теперь небольшой хак. В стандартной CLOS в случае, если мы в defclass не указали ни одного класса-родителя являющегося standard-object, а метакласс нашего класса — обычный standard-class, то такой класс, собственно сам standard-object, инжектится в список классов, от которых мы наследуемся. Мы поступим так же с нашими prototype-class и prototype-object. Для этого нужно переопределить стандартные функции, используемые конструктором объектов.

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

Теперь самое интересное.

Первое — чтобы работа со слотами объектов шла через хэш-табличку, хранящуюся у нас в объектах, нам нужно переопределить для наших классов четыре стандартных операции работы со слотами — а именно: взятие значения слота, установка оного, проверка на связанность слота со значением и удаление такой связи. Все эти операции прекрасно реализуются хэш-табличкой; внутри этих операций, мы проверяем, является ли :allocation слота :hash, что указывает на то что наш слот хранится именно в ней, и если нет — то используем стандартный механизм доступа к полям объекта CLOS.

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

Теперь прототипы. Как известно, в JavaScript значение поля ищется по цепочке прототипов. В случае, если поля в объекте нет, рекурсивно обходится вся иерархия, и в случае отсутствия поля у какого-либо из объектов, возвращается undefined. В то же время, в JS существует механизм «перекрытия» полей. Это значит, что если в объекте устанавливается/определяется поле с именем, аналогичным имени из полей какого-либо из объектов в иерархии прототипов, то при следующем доступе к этому полю, значение будет браться именно из него, без какого-либо следования по иерархии.

Мы реализуем аналогичную функциональность. Для этого нам потребуется переопределить обобщенную функцию slot-missing. Вызывается она тогда, когда функции работы со слотами(slot-value, (setf slot-value), slot-boundp, slot-makunbound) обнаруживают отсутствия поля с запрашиваемым именем в классе объекта. Эта обобщенная функция принимает крайне удобный набор аргументов — метаобъект класса объекта, сам объект, имя поля, имя «провалившейся» операции, и, для операции установки значения — новое значение поля.

Поступим следующим образом. До переопределения этой функции, создадим дополнительный класс сигналов(иключений Common Lisp), объекты которого будут выбрасываться в случае обнаружения отсутствия прототипа у объекта. Также, создадим дополнительный аналог вышеопределенной функции prototype-of.

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

Теперь определим наш метод. Схема работы следующая: для двух из четырех операций, мы рекурсивно обходим иерархию прототипов, и в конечном итоге выбрасываем исключение prototype-missing. Сверху стека вызовов мы устанавливаем обработчик, который, перехватывая сигнал, возвращает нам некоторое дефолтное значение — в данном случае nil. Две другие операции, как было объяснено выше, в рекурсивном обходе прототипов не нуждаются.

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

Готово! Собственно, не более чем за 150 строк кода мы получили работающую прототипную объектно-ориентированную систему, подобную таковой в JavaScript. Более того, эта система полностью интегрирована со стандартной CLOS, и допускает, скажем, участие «обычных» объектов в иерархии прототипов. Другая особенность — мы можем совсем не создавать своих классов объектов, а обходиться лишь одним prototype-object, в случае если мы хотим от нее поведения, полностью идентичного JS.

Что можно добавить? Наверное, поверх такой системы с помощью reader-макросов можно сделать JSON-подобный синтаксис. Но, это уже тема отдельной статьи 🙂

Напоследок несколько примеров:

(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