Библиотека функций к Script-fu

Введение

В принципе реализация представленная в файле obj4.scm и описанная ранее, меня вполне устраивала. Я реализовал там всё что хотел от объектной системы: определения классов и обобщённых функций, множественное наследование, статические поля класса. Но вот какое-то маленькое зёрнышко сомнения, мешало мене оставить этот проект. А всё ли я сделал для ускорения работы системы? И дело даже не в том, что какие то нехорошие люди из проекта GIMPа обрезали возможность для Script-fu загружать расширения, что не даёт возможности быстро рассчитать хеш-код символов(а то и вовсе заменить хеш-таблицы сишной реализацией). Нет. Для себя я спокойно перекомпилирую Script-fu и буду пользоваться всеми преимуществами предоставляемыми настоящей tinyscheme. Но что же можно сделать ещё, чтобы улучшить скорость работы ОО системы?

Дело в том, что обращение к полям(слотам) в методах для объектов происходит через vfield, функцию обращения к виртуальному полю, т.к., при написании кода, невозможно заранее знать какой объект будет передан как аргумент метода(объявленный или один из его наследников). А статические методы доступа использовать нельзя, т.к поля у объектов классов наследников не совпадают с полями объектов родительских классов(и я в принципе не стремился обеспечить такое совпадение, т.к множественное наследование поломало бы любую схему). В питоне, джаваскрипте с этим не заморачиваются у них объект это хеш-таблица и никуда от них нельзя деться, а у нас вектор!

И тут я понял ошибочность своих рассуждений! Дело в том, что для того чтобы вызвать метод обобщённой функции, я всегда проверяю типы переданных в функцию аргументов(на этой основе и происходит вся диспетчеризация методов и обеспечивается полиморфное поведение). Т.е я всегда чётко знаю с каким набором типов объектов будет вызван тот или иной метод, или комплекс методов. А значит в методах МОЖНО(и даже нужно) применять статические функции(а вернее даже макросы) для доступа к полям объекта. А это радикально ускорит выполнение методов. Дело в том что пытающийся ускорить работу с полями макрос with-slots, лишь незначительно может ускорить работу с полями, т.к как правило в методах редко выполняются более одного обращения к полю.

Но пока наши методы могут принимать любые объекты потомки объявленных в параметрах классов. А надо сделать так, чтобы методы могли работать только с определёнными типами, и тогда мы сможем использовать статические макросы доступа к полю в методах обобщённых функций. Теперь для написания методов обобщённой функции программист будет писать ШАБЛОННЫЙ код, мы будем создавать не реально работающий код, а шаблон кода, и в процессе вызова обобщённой функции для каждого набора типов аргументов, мы эти шаблоны будем превращать в код конкретных методов, работающий с конкретными типами аргументов. Здесь я не открыл америку. так делают в С++. Да я при этом проиграю по памяти, работа по предварительному переводу кода из шаблонного в конкретный будет занимать немного времени, ведь она будет происходить во время работы программы при первом обнаружении ранее неизвестного набора типов аргументов вызываемой обобщённой функции. Зато сам код метода будет максимально быстрый(на сколько это можно для интерпретатора).

ну а синтаксисом для обозначения шаблонного кода может выступить тот же Dot синтаксис упомянутый мной в предыдущей статье.

Реализация.

Не смотря на заявленную глубину изменений в проекте, как это ни странно, определения макросов defgeneric и defmethod НЕ ИЗМЕНИЛИСЬ. Так же изменения не затронули и десяток других функций ответственных за создание функциональности обобщённых функций. Поменялась в сущности одна функция:

(define (build-applicable-methods methods shablon)
  (let* ((shablon-parents (build-shablon-parents shablon))
	 (acceptable-methods-primary (build-acceptable-method-list (qualifier-methods-primary methods) shablon-parents))
	 (acceptable-methods-before  (build-acceptable-method-list (qualifier-methods-before  methods) shablon-parents))
	 (acceptable-methods-after   (build-acceptable-method-list (qualifier-methods-after   methods) shablon-parents))
	 (acceptable-methods-around  (build-acceptable-method-list (qualifier-methods-around  methods) shablon-parents))
	 (compare-func (make-compare-shablon-call shablon-parents))
	 (rez (qualifier-methods! '() '() '() '())))
    (qualifier-methods-around!  rez (build-concrete-methods-list-primary-by-shablon  (sort-c compare-func acceptable-methods-around) shablon))
    (qualifier-methods-before!  rez (build-concrete-methods-list-by-shablon          (sort-c compare-func acceptable-methods-before) shablon))
    (qualifier-methods-primary! rez (build-concrete-methods-list-primary-by-shablon  (sort-c compare-func acceptable-methods-primary) shablon))
    (qualifier-methods-after!   rez (build-concrete-methods-list-by-shablon (reverse (sort-c compare-func acceptable-methods-after)) shablon))
    rez))

;какой она была в obj4

(define (build-applicable-methods methods shablon)
  (let* ((shablon-parents (build-shablon-parents shablon))
	 (acceptable-methods-primary (build-acceptable-method-list (qualifier-methods-primary methods) shablon-parents))
	 (acceptable-methods-before  (build-acceptable-method-list (qualifier-methods-before  methods) shablon-parents))
	 (acceptable-methods-after   (build-acceptable-method-list (qualifier-methods-after   methods) shablon-parents))
	 (acceptable-methods-around  (build-acceptable-method-list (qualifier-methods-around  methods) shablon-parents))
	 (compare-func (make-compare-shablon-call shablon-parents))
	 (rez (qualifier-methods! '() '() '() '())))
    (qualifier-methods-around!  rez (sort-c compare-func acceptable-methods-around))
    (qualifier-methods-before!  rez (sort-c compare-func acceptable-methods-before))
    (qualifier-methods-primary! rez (sort-c compare-func acceptable-methods-primary))
    (qualifier-methods-after!   rez (reverse (sort-c compare-func acceptable-methods-after)))
    rez))

Т.е в момент создания комплекса применимых методов, подходящих набору типов аргументов вызываемой обобщённой функции, добавились вызовы функций: build-concrete-methods-list-primary-by-shablon и build-concrete-methods-list-by-shablon, которые как раз и преобразуют шаблонный код методов, в код подходящий для конкретного набора типов аргументов.

(define-m (build-concrete-methods-list-by-shablon methods shablon)
  (map (lambda (m) (list (car m) (build-concrete-method-by-shablon (cadr m) shablon))) methods))

(define-m (build-concrete-methods-list-primary-by-shablon methods shablon)
  (map (lambda (m) (list (car m) (build-concrete-method-primary-by-shablon (cadr m) shablon))) methods))

А они в свою очередь, представляют обработку списка функций с помощью функций:

(define-m (build-concrete-method-by-shablon method shablon)
  (let ((code      (get-closure-code method)))
    (eval (our-macro-expand1 (list 'lambda (cadr code)
                              (tree-expr-replace-vars-dot-fields (caddr code)
                                                                 (make-var-stru-by-shablon (cadr code) shablon)))))))

;;первичный метод(и окружающий) имеет в начале незадекларированный аргумент!!! он не входит в шаблон!
(define-m (build-concrete-method-primary-by-shablon method shablon)
  (let ((code      (get-closure-code method)))
    (eval (our-macro-expand1 (list 'lambda (cadr code)
                              (tree-expr-replace-vars-dot-fields (caddr code)
                                                                 (make-var-stru-by-shablon (cdr (cadr code)) shablon)))))))
(define-m (make-var-stru-by-shablon args shablon)
  (let ((rez '()))
    (do ((cur-args    args    (cdr cur-args))
         (cur-shablon shablon (cdr cur-shablon)))
        ((or (null? cur-args) (null? cur-shablon))  (reverse rez))
      (unless (eq? (car cur-shablon) :unspec)
        (set! rez (cons (var-stru-def! (car cur-args) (car cur-shablon)) rez))))))

функции преобразующие код шаблонных методов используют функцию make-var-stru-by-shablon создающую по шаблону и аргументам определения полей использующихся в макросе обрабатывающим дот синтаксис для структур with-stru! Но вместо использования этого макроса я напрямую вызываю функцию: tree-expr-replace-vars-dot-fields которая и выполняет все замены в коде.

функция tree-expr-replace-vars-dot-fields

(define-m (tree-expr-replace-vars-dot-fields expr var-list)
   (let ((aliases     (make-hash 16))
         (tree-expr-replace-get-set-rec #f)
         (is-alias-fields #f)
         (fd              #f) ;;переменная определения поля
         (in-var-list (lambda (var var-list) (find (lambda (x) (eq? ( var-stru-def-var x ) var)) var-list)))
         (exclude-params (lambda (var-list params)
                            (remove-if (lambda (var)
                                          (cdr (find (lambda (elem) (eq? (var-stru-def-var var) elem)) params))) var-list))))
      (set! is-alias-fields
         (lambda (expr var-list)
            (if (symbol? expr)
                (let ((rez (hash-ref aliases expr))) ;;проверяем хеш.
                   (if (car rez)
                       (cdr rez) ;;вернём результат, он пригодиться функциям построения get и set
                       (let ((var-field (split-dot-symbol expr))) ;;попробуем "разбить" символ.
                          (if var-field
                              (let ((in-var (in-var-list (car var-field)  var-list)))
                                 (if (cdr in-var)
                                     (let* ((getter-name  (make-symbol
                                                           (var-stru-def-type (car in-var))
                                                           "-" (cdr var-field)))
                                            (setter-name  (make-symbol
                                                           (var-stru-def-type (car in-var))
                                                           "-" (cdr var-field) "!"))
                                            (fd (field-def! expr (cdr var-field) (car var-field)
                                                            getter-name
                                                            setter-name)))
                                        (hash-set! aliases expr fd)
                                        fd);;вернём полученное описание поля
                                     #f)) ;;это не наша пара!!! мы такой переменной не задавали!
                              #f))));;не смогли разбить на пару переменная-поле
                #f))) ;;это даже не символ!
      (set! tree-expr-replace-get-set-rec
         (lambda (expr var-list) 
            (cond ((null? expr) '())
                  ((lambda? expr) ;;возможно в лямбде есть что заменить, например в замыкании, свободную переменную
                   (let* ((params  (lambda-parameters expr))
                          (local-var-list (exclude-params var-list params)))
                      (if (null? local-var-list)
                          expr ;;нет свободных переменных из var-list, дальше замену не делаем
                          (make-lambda params ;;возможно какие то переменные будут свободными, попробуем их заменить
                                       (tree-expr-replace-get-set-rec (lambda-body expr) local-var-list)))
                      ))
                  ((begin
                      (set! fd (is-alias-fields expr var-list))
                      fd)
                   (list (field-def-name-get fd) (tree-expr-replace-get-set-rec (field-def-var fd) var-list)))
                  ((and (pair? expr)   ;;(list? expr)
                        (= (length expr) 3)
                        (eq? 'set! (car expr))
                        (begin
                           (set! fd (is-alias-fields (cadr expr) var-list))
                           fd))
                   (list (field-def-name-set fd)
                         (tree-expr-replace-get-set-rec (field-def-var fd) var-list)
                         (tree-expr-replace-get-set-rec (caddr expr) var-list)))
                  ((pair? expr) ;;(list? expr)
                   (cons (tree-expr-replace-get-set-rec (car expr) var-list)
                         (tree-expr-replace-get-set-rec (cdr expr) var-list)))
                  (#t
                   expr))))
      (let ((rez (tree-expr-replace-get-set-rec expr var-list)))
         rez)
      ))

вот и ВСЁ!!! Теперь осталось продемонстрировать новый синтаксис.

Пример работы.

подготовка к работе.

;;(define path-home "D:")
(define path-home (getenv "HOME"))
(define path-lib (string-append path-home "/work/gimp/lib/"))
(define path-work (string-append path-home "/work/gimp/"))
(load (string-append path-lib "util.scm"))
(load (string-append path-lib "defun.scm"))
(load (string-append path-lib "struct2.scm"))
(load (string-append path-lib "storage.scm"))
(load (string-append path-lib "cyclic.scm"))
(load (string-append path-lib "hashtable3.scm")) ;;хеш который может работать с объектами в качестве ключей!
(load (string-append path-lib "sort2.scm"))
(load (string-append path-lib "tsort.scm"))
;;(load (string-append path-lib "cpl-sbcl.scm"))
(load (string-append path-lib "cpl-mro.scm"))
;;(load (string-append path-lib "cpl-topext.scm"))
(load (string-append path-lib "struct2ext.scm"))
(load (string-append path-lib "queue.scm"))
(load (string-append path-lib "obj5.scm"))
(load (string-append path-lib "obj/object.scm"))

Простенький класс с одной переменной и одной статической переменной.

(defclass Test (Object)
  ((v1 5))
  (shared-val))

(define t1 (make-Test))
(define t2 (make-Test :v1 12))
(sfield! t1 :shared-val 123)
(sfield! t2 :shared-val 321)

(sfield t1 :shared-val) ;321 ;;установив переменну для t2 оказалось что её значение поменялось и для t1

Переопределим метод to-s для класса Test

(defmethods Test
  (to-s ()                                ;;      v----- вот он Дот синтаксис для доступа к полям объекта!!!
        (join-to-str (call-next-method) " v1: " self.v1 ", shared-val: " self.shared-val))
  )

(to-s t1) ;;"#Test[:v1: 5] v1: 5, shared-val: 321"
(to-s t2) ;;"#Test[:v1: 12] v1: 12, shared-val: 321"

Наконец то мы увидели результат наших трудов, дот-синтаксис при доступе к полям класса. Как посмотреть код метода, исполняемый при вызове обобщённой функции?

(get-closure-code (cadar (qualifier-methods-primary (cdr (to-s-get-methods '(Test))))))
;; (lambda (gensym-552 self)
;;   (let* ((next-method-p (lambda () (not (null? (qm-get gensym-552 :primary)))))
;; 	 (call-next-method (lambda () (call-methods-rec gensym-552 self))))
;;     (join-to-str (call-next-method) "v1: " (vector-ref self 1) ", shared-val: " (Test-shared-val self))))

(get-closure-code Test-shared-val)
;;(lambda (gensym-470) (vector-ref Test 0))

Где функция to-s-get-methods автоматически создаётся при определении обобщённой функции to-s, а qualifier-methods-primary - автоматически создаётся как геттер для поля primary структуры qualifier-methods.

Простенький пример с наследованием, реализация "смертельного ромба".

Реализуем четыре класса образующих ромбовидное наследование, ну и до кучи в базовом классе укажем одну статическую переменную.

(defclass Test1 (Object)
  (v11 v12)
  (shared-val))

(defclass Test2 (Test1)
  ((v21 121) (v22 122)))

(defclass Test3 (Test1)
  ((v31 331)))

(defclass Test4 (Test3 Test2)
  (v41))

(define t1 (make-Test1 :v11 12 :v12 13))
(define t2 (make-Test4 :v11 41 :v12 42 :v41 141 :v22 1))
(sfield! t1 :shared-val 123)
(sfield! t2 :shared-val 421)
(sfield! 'Test2 :shared-val 221)
(sfield! 'Test3 :shared-val 321)

(sfield t2 :shared-val) ;421 - статические значения переменных работают попрежнему.

Переопределим (он уже определён для класса Object) метод to-s для базового класса Test1 и пару объектов разных классов.

(defmethods Test1
  (to-s ()
      (join-to-str (call-next-method) " ,v11: " self.v11 ", v21: "  self.v12 ", shared-val: " self.shared-val))
  )

(define t12 (make-Test2 :v11 212 :v12 213)) 
(define t13 (make-Test3 :v11 312 :v12 313))

Испытаем как работает метод, в начале строки отрабатывает метод для Object, он использует интроспекцию, поэтому выводит все переменные. А метод для класса Test1 может обращаться к переменным только тем которые определены в нём.

(for-list (t (list t1 t12 t13 t2))
    (prn (to-s t) "\n"))

;; #Test1[:v11: 12, :v12: 13] ,v11: 12, v21: 13, shared-val: 123
;; #Test2[:v11: 212, :v12: 213, :v21: 121, :v22: 122] ,v11: 212, v21: 213, shared-val: 221
;; #Test3[:v11: 312, :v12: 313, :v31: 331] ,v11: 312, v21: 313, shared-val: 321
;; #Test4[:v11: 41, :v12: 42, :v21: 121, :v22: 1, :v31: 331, :v41: 141] ,v11: 41, v21: 42, shared-val: 421

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

(defmethods Test4
  (to-s ()
	(join-to-str "v11: "   self.v11 ", v21: "  self.v12
		     ", v21: " self.v21 ", v31: "  self.v31
		     ", v41: " self.v41 ", shared-val: " self.shared-val))
  )


(for-list (t (list t1 t12 t13 t2))
    (prn (to-s t) "\n"))
;; #Test1[:v11: 12, :v12: 13] ,v11: 12, v21: 13, shared-val: 123
;; #Test2[:v11: 212, :v12: 213, :v21: 121, :v22: 122] ,v11: 212, v21: 213, shared-val: 221
;; #Test3[:v11: 312, :v12: 313, :v31: 331] ,v11: 312, v21: 313, shared-val: 321
;; v11: 41, v21: 42, v21: 121, v31: 331, v41: 141, shared-val: 421

В последней строке видна работа полиморфизма обобщённой функции, был вызван переопределённый метод для класса Test4.

Опять же можно посмотреть, насколько эффективный код был сгенерирован для этого метода:

(get-closure-code (cadar (qualifier-methods-primary (cdr (to-s-get-methods '(Test4))))))
;; (lambda (gensym-479 self)
;;   (let* ((next-method-p (lambda () (not (null? (qm-get gensym-479 :primary)))))
;; 	    (call-next-method (lambda () (call-methods-rec gensym-479 self))))
;;     (join-to-str "v11: "   (vector-ref self 3)   ", v21: "        (vector-ref self 2)
;; 		    ", v21: " (vector-ref self 1)   ", v31: "        (vector-ref self 5)
;; 		    ", v41: " (vector-ref self 4)   ", shared-val: " (Test4-shared-val self))))

Обратите внимание, в исполняемом коде функции используются прямые ссылки к полям вектора, без каких бы то нибыло поисков в хеш-таблицах.

Ещё один пример простого наследования.

Этот пример я взял из видео ролика "ООП на простых примерах". Сам пример довольно таки тривиальный, но что здесь заслуживает внимание это создание конструкторов и виртуальной функции инициализации объектов и виртуальной функции изменения состояния объектов. Пример рассматривает иерархию трёх классов: Personal, Employee, Developer.

Опишем класс Personal и функцию изменения объекта.

(defclass Person (Object)
  (first-name last-name age))


(defmethods Person
  (change  (data)
     (let ((parsed (keyargs-to-pairs data)))
       (awhen (assq :first-name parsed) (set! self.first-name (cdr it)))
       (awhen (assq :last-name parsed)  (set! self.last-name  (cdr it)))
       (awhen (assq :age parsed)
	   (set! self.age  (if (&lt; (cdr it) 0)
			               (let ((delta (+ self.age (cdr it))))
			                  (if (&lt; delta 0) 0 delta))
			               (cdr it))))
       )
     self)
  )

Для чего нужна функция change? Что бы консистентно изменять состояние объекта. Нет, конечно мы можем изменить поля объекта класса и без этой функции, но это не хорошо. Ай-яй-яй! так делать. В самом деле бывает необходимо наложить ограничения на прямое измение полей объектов класса, например для того чтобы поддержать какой-то консистентное состояние класса. Например треугольника и имеющейся в объекте поля площади. Такое поведение обычно навешивают на аццессоры, вернее сеттеры. Но так делать не правильно, ибо изменение одной точки вызовет пересчёт этой площади, но ведь мы можем просто переместить весь треугольник, при этом изменятся все три точки, а поскольку состояние объекта мы не можем изменить кроме как вызвав сеттеры, произойдёт тройной пересчёт площади. И то что казалось хорошей идеей для поддержания консистентного состояния объекта(через сеттеры) обернётся двойной лишней работой. Возможность контролировать консистентное состояние объекта через логику сеттеров рациональна, но применима лишь в самых простейших случаях.

Обобщённая функция change позволяет изменить сразу все поля объекта и навесить логику контроля состояния консистентности на отдельное поле или на весь объект.

пример работы

(define p1 (make-Person :age 31 :first-name "Вася" :last-name "Васильев"))
(to-s p1) ;;"#Person[:age: 31, :first-name: Вася, :last-name: Васильев]"

(change p1 (list :age -5 :first-name "Саша"))
(to-s p1) ;;"#Person[:age: 26, :first-name: Саша, :last-name: Васильев]"

(change p1 (list :age -55 :last-name "Сидоров"))
(to-s p1) ;;"#Person[:age: 0, :first-name: Саша, :last-name: Сидоров]"

(to-s (change p1 (list :age 25))) ;;#Person[:age: 25, :first-name: Саша, :last-name: Сидоров]"

К сожалению формат передачи параметров не очень хороший, надо явно формировать список ключевых параметров. К тому же, если в последствии я буду перегружать эту функцию(а я это обязательно сделаю) то мне придётся заново вызывать разбор ключевых параметров и хоть это и дёшево, но это лишняя работа, поэтому предлагаю переписать эту функцию, для работы с уже разобранными ключевыми параметрами, а внешний интерфейс к ней организовать через "ОБЫЧНУЮ" функцию.

(define-m (change obj . data)
  (parsed-change obj (keyargs-to-pairs data)))

(defmethods Person
  (parsed-change  (parsed)
     (awhen (assq :first-name parsed) (set! self.first-name (cdr it)))
     (awhen (assq :last-name parsed)  (set! self.last-name  (cdr it)))
     (awhen (assq :age parsed)
	 (set! self.age  (if (< (cdr it) 0)
			     (let ((delta (+ self.age (cdr it))))
			       (if (< delta 0) 0 delta))
			     (cdr it))))
     self)
  (:after parsed-change (parsed)
     (prn "work after all Person changes\n"))
  )

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

посмотрим как работает переопределённая функция.

(define p1 (make-Person :age 31 :first-name "Вася" :last-name "Петров"))
(to-s p1) ;;"#Person[:age: 31, :first-name: Вася, :last-name: Петров]"

(change p1 :age 28 :first-name "Никита") ;;#(Person 28 "Никита" "Петров")#<EOF>

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

(defclass Employee (Person)
  (inn number snils))


(defmethods Employee
  (parsed-change  (parsed)
      (if (next-method-p) (call-next-method))
      (awhen (assq :inn parsed) (if self.inn
				                    (error (join-to-str  "Can't set INN: " (cdr it) "object has inn: " self.inn))
				                    (set! self.inn (cdr it))))
      (awhen (assq :number parsed)  (set! self.number  (cdr it)))
      (awhen (assq :snils parsed)
	     (if self.snils
		     (error (join-to-str  "Can't set SNILS: " (cdr it) "object has SNILS: " self.snils))
		     (set! self.snils (cdr it))))
      self)
  (:after parsed-change (parsed)
     (prn "work after all Employee changes\n"))
  )

Здесь мы полагаемся на метод контролирующий изменения полей базового класса и дополняем логику контроля изменения полей определённых в текущем классе. Т.е добавляем логику о неизменности установленных полей snils и inn.

Мы можем создать специальный инициализирующий конструктор для данного класса использующий виртуальный метод parsed-change

(define-m (Employee! . args)
  (let ((tmp (make-Employee-create)))
    (make-Employee-initialize tmp :age 0) ;;нужно инициализировать поле иначе не правильно будет работать change
    (apply change tmp args)
    tmp))

;Как работает конструктор класса и метод change

(define emp1 (Employee! :first-name "Саша" :last-name "Сидоров" :age 32 :inn 1213223234 :snils 999999999999 :number 1))
(to-s emp1) ;;#Employee[:age: 32, :first-name: Саша, :inn: 1213223234, :last-name: Сидоров, :number: 1, :snils: 999999999999]"

(change emp1 :first-name "Коля" :inn 1000000)
;;->Error: Can't set INN: 1000000object has inn: 1213223234 

(to-s emp1)
;;"#Employee[:age: 32, :first-name: Коля, :inn: 1213223234, :last-name: Сидоров, :number: 1, :snils: 999999999999]"

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

Реализуем класс Разработчик:

(defclass Developer (Employee)
  (level language))


(defmethods Developer
  (parsed-change  (parsed)
      (if (next-method-p) (call-next-method))
      (awhen (assq :level parsed)     (set! self.level (cdr it)))
      (awhen (assq :language parsed)  (set! self.language  (cdr it)))
      self)
  (:after parsed-change (parsed)
     (prn "work after all Developer changes\n"))
  )


(define-m (Developer! . args)
  (let ((tmp (make-Developer-create)))
    (make-Developer-initialize tmp :age 0)
    (apply change tmp args)
    tmp))

посмотрим как работает класс разработчика

(define dev1 (Developer! :first-name "Саша" :last-name "Козлов" :age 19 :level 'junior :language "java"))
(to-s dev1)
;;"#Developer[:age: 19, :first-name: Саша, :inn: #f, :language: java, :last-name: Козлов, :level: junior, :number: #f, :snils: #f]"

А теперь определим функцию приветствия для базового класса:

(defmethods Person
  (greeting ()
      (prn "Привет я человек " self.first-name " " self.last-name ", мой возраст: " self.age "\n"))
  )

демонстрация работы приветствия функции базового класса:

(for-list (el (list p1 emp1 dev1))
    (greeting el))

;; Привет я человек Никита Васильев, мой возраст: 28
;; Привет я человек Коля Сидоров, мой возраст: 32
;; Привет я человек Саша Козлов, мой возраст: 19

Ясно, что базовая функциональность приветствия нас не устраивает, давайте переопределим методы для потомков.

(defmethods Employee
  (greeting ()
      (prn "Привет я работник " self.first-name " " self.last-name ", мой возраст: " self.age ", ИНН: " self.inn "\n"))
  )

(defmethods Developer
  (greeting ()
     (prn "Привет я программист " self.first-name " " self.last-name ", я знаю " self.language " на уровне " self.level "\n"))
  )

Запускаем повторные тесты.

(for-list (el (list p1 emp1 dev1))
    (greeting el))
;; Привет я человек Никита Васильев, мой возраст: 28
;; Привет я работник Коля Сидоров, мой возраст: 32, ИНН: 1213223234
;; Привет я программист Саша Козлов, я знаю java на уровне junior

наблюдаем полностью полиморфное поведение.

На самом деле мы можем перегрузить функцию приветствия дополнительным параметром.

(defmethods Developer
  (greeting (message)
     (prn message " я программист " self.first-name " " self.last-name ", я знаю "
          self.language " на уровне " self.level "\n"))
  )

(greeting dev1 "Добрый вечер:")
;;Добрый вечер: я программист Саша Козлов, я знаю java на уровне junior

Что конечно же приведёт к неработоспособности кода, когда мы попытаемся применить данный интерфейс к объектам базовых классов:

(for-list (el (list p1 emp1 dev1))
    (greeting el "Добрый вечер:"))
;;Error: Can't find applicable method: greeting, params:  (#(Person 28 "Никита" "Васильев") "Добрый вечер:") "\n"

Как это можно поправить? Давайте определим метод по умолчанию для любых двух аргументов функции greeting.

(defmethod (greeting p1 p2)
  (prn "Метод не поддерживается для " p1 " и " p2 "\n"))

(for-list (el (list p1 emp1 dev1))
   (greeting el "Добрый вечер:"))
;; Метод не поддерживается для #(Person 28 Никита Васильев) и Добрый вечер:
;; Метод не поддерживается для #(Employee 1 32 1213223234 999999999999 Коля Сидоров) и Добрый вечер:
;; Добрый вечер: я программист Саша Козлов, я знаю java на уровне junior

Это уже лучше, но можно ещё сделать и так, конвертировать вызов с двумя переменными в вызов с одной переменной:

(defmethod (greeting p1 p2)
  (greeting p1))

(for-list (el (list p1 emp1 dev1))
  (greeting el "Добрый вечер:"))
;; Привет я человек Никита Васильев, мой возраст: 28
;; Привет я работник Коля Сидоров, мой возраст: 32, ИНН: 1213223234
;; Добрый вечер: я программист Саша Козлов, я знаю java на уровне junior

Заключение.

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

GIMP Script-Fu ООП. Небольшой рефакторинг объектной системы. Изюминка всего проекта