Введение
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
Автор: love5an
