Введение

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