Метаобъектный протокол Common Lisp на примере реализации прототипной объектной системы

    Введение


    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
    • +23
    • 6,4k
    • 4
    Поделиться публикацией
    Похожие публикации
    AdBlock похитил этот баннер, но баннеры не зубы — отрастут

    Подробнее
    Реклама
    Комментарии 4
    • 0
      вот всегда было интересно – а как со скоростью?
      • +2
        CLOS вряд ли будет использоваться для написания критических частей числодробилок, где важна эта самая «скорость», а в остальных случаях её оверхед вполне стоит приобретаемой выразительности.
        • +1
          Стандартный CLOS в таких реализациях, как SBCL и CCL, работает достаточно шустро.
          Но когда начинается использование кастомных метаклассов, целый ряд оптимизаций
          отключается. У меня в одном проекте (встраиваемая система контроля и управления
          ускорителя электронов) пришлось от активного использования MOP'а отказаться,
          когда понадобилось запускать штуковину на 600MHz ARM'е (Cortex-A8).
        • 0
          Некоторые виды использования метаобъектного протокола могут вносить достаточно значительные издержки, но при этом же его можно использовать и для повышения производительности стандартной CLOS(один из вариантов того, что можно сделать с его помощью — собственно структуры (structure-object) стандартного CL, которые сильно лучше по производительности чем standard-object).

          При этом, если сравнивать со скриптовыми языками вроде Python, или же, скажем, с языками с несовершенными на данный момент компиляторами(вроде Go), то производительность CLOS и MOP в топовых реализациях CL(том же SBCL), дает им огромную фору.

        Только полноправные пользователи могут оставлять комментарии. Войдите, пожалуйста.