Суперкласс
Нет необходимости все новые слоты создавать в каждом классе.
Пример: ОО-определение Лисп-компилятора.
;oop-compile
(defclass expr () ((type :accessor td) (sd :accessor ft)) (:documentation "C-expression"))
(defclass un (expr) ; \_____суперкласс для унарных форм
((type :accessor td) ;; можно убрать ??? (sd :accessor ft)) ;; можно убрать ??? (:documentation "quote car *other *adr"))
(defclass bin (expr) ((type :accessor td) (sd :accessor ft) (sdd :accessor sd) ) (:documentation "cons + lambda let"))
(defclass trio (expr) ((type :accessor td) (sd :accessor ft) ; (bin) ;; не объявлять sdd ??? (sdd :accessor sd) (sddd :accessor td) ) (:documentation "if label"))
(defmethod texrp ((x expr) (nt atom)) (setf (slot-value x 'type) nt) (setf (td x) nt) ;;--;; variant (:documentation "объявляем тип выражения"))
(defmethod spread ((hd (eql 'QUOTE)) (tl expr)) (let ( (x (make-instance 'un)) ) (setf (ft x) (car tl)) (setf (td x) hd) ) (:documentation "распаковка выражения"))
(defmethod compl ((hd (eql 'QUOTE)) (tl expr)) (list 'LDC tl) ) (:documentation "сборка кода"))
(defmethod compl ((hd (eql 'CAR)) (tl expr)) (append (compl(ft tl) N) '(CAR)) ) (:documentation "сборка кода"))
(defmethod spread ((hd (eql 'CONS)) (tl expr)) (let ( (x (make-instance 'bin)) ) (setf (ft x) ( car tl)) (setf (sd x) ( cadr tl)) (setf (td x) hd) ) (:documentation "распаковка выражения"))
(defmethod compl ((hd (eql 'CONS)) (tl bin) N ) (append (compl(sd tl) N) (compl(ft tl) N) '(CONS)) ) (:documentation "сборка кода")) (defmethod compl ((hd (eql '+)) (tl bin) N ) (append (compl(ft tl) N) (compl(sd tl) N) '(ADD)) ) (:documentation "сборка кода"))
(defmethod spread ((hd (eql 'IF)) (tl expr)) (let ( (x (make-instance 'trio)) ) (setf (ft x) ( car tl)) (setf (sd x) ( cadr tl)) (setf (td x) ( caddr tl)) (setf (td x) hd) ) (:documentation "распаковка выражения"))
(defmethod compl ((hd (eql 'IF)) (tl expr) N ) (let ( (then (list (compl(sd tl) N) '(JOIN))) (else (list (compl(td tl) N) '(JOIN))) ) (append (compl(ft tl) N) (list 'SEL then else) ) )(:documentation "сборка кода"))
(defmethod parh ((x expt)) (let (ftx (ft x)) (cond ((atom ftx) (spread 'ADR ftx)) ((member (car ftx) '(QUOTE CAR CONS + IF LAMBDA LABEL LET)) (spread (car ftx) (cdr ftx)) (T (spread 'OTHER ftx) )) )(:documentation "шаг разбора"))
;====test========== (setf test1 (make-instance 'expr)) (texpr test1 'expr) (setf (slot-value test1 'sd) (read)) ()
(setf e1 (make-instance 'expr)) (setf e2 (make-instance 'expr))
(setf e3 (make-instance 'expr)) (print (tf e2)) (setf (slot-value e3 'type) 'expr) (print (tf e3)) (setf (slot-value e3 'sd) '(quote const))
(defmethod ep ((x expr)) ((lambda (xt) (setf (slot-value x 'type) xt))(car (slot-value x 'sd) ))) (print (ep e3)) (print (tf e3)) (print (td e3)) (print (sd e3))
(defmethod ep-q ((x (eql 'quote)) (y expr)) (setf y (make-instance 'un))) (setf (slot-value y 'type) 'quote) (setf (slot-value y 'sd) y) ))
(print (tf (e3 'sd)))
(print (tf e1)) (print(setf (slot-value e1 'type) (tf e1))) (setf (slot-value e2 'sd) 'atom1) (print (tf (sd e2)))
(print(setf (slot-value e3 'sd) '(quote const))) (print (tf e3))
CLOS, естественно, использует модель обобщенных функций, но мы написали независимую модель, используя более старые представления, тем самым показав, что концептуально ООП — это не более чем перефразировка идей Лиспа. ООП — это одна из вещей, которую Лисп изначально умеет делать. Для функционального стиля программирования в переходе к ООП нет ничего неожиданного. Это просто небольшая конкретизация механизмов перебора ветвей функциональных объектов.
Более интересный вопрос, что же нам еще может дать функциональный стиль и лисповская традиция реализации систем программирования?
Ответу на этот вопрос посвящены три следующие лекции.
