Еще одна реализация
Более прозрачная модель ООП получается на базе обычных списков свойств, заодно иллюстрирующая глубинное родство ФП и ООП:
(defun classes (cl) (cond (cl (cons (cdar cl) (classes (cdr cl)))) ))
; вывод формулы классов аргументов из определения ; параметров метода ; Nil — произвольный класс
(defun argum (cl) (cond (cl (cons (caar cl) (argum (cdr cl)))) ))
; вывод списка имен аргументов из определения ; параметров метода
(defun defmet (FMN c-as expr) (setf (get FMN 'category) 'METHOD) (setq ML (cons(cons(cons FMN (classes c-as)) (list 'lambda (argum c-as) expr) ) ML)) FMN ) ; объявление метода и расслоение его определения ; для удобства сопоставления с классами аргументов
(defun defcl (NCL SCL FCL ) ; имя, суперкласс и поля/слоты класса (setq ALLCL (cons NCL ALLCL)) (set NCL (append FCL SCL)) )
; значением класса является список его полей, ; возможно, со значениями
(defun ev-cl (vargs) (cond
; вывод формата фактических аргументов для поиска ; метода их обработки
(vargs (cons (cond ((member (caar vargs) ALLCL) (caar vargs)) ) (ev-cl (cdr vargs)))) )) ; Nil если не класс
(defun m-assoc (pm meli) (cond (meli (cond ((equal (caar meli) pm)(cdar meli)) (T(m-assoc pm (cdr meli)))))))
; поиск подходящего метода, соответствующего ; формату классов данных
(defun method (MN args &optional c) (apply (m-assoc (cons mn (ev-cl args)) ML) args c))
; если метода не нашлось, в программе следует ; выполнить приведение ; параметров к нужному классу
(defun instance (class &optional cp) (cond
; подобно Let безымянная копия контекста
(class (cond ((atom (car class))(instance (cdr class) cp)) ((assoc (caar class) cp) (instance (cdr class) cp)) (T(instance (cdr class) (cons (car class) cp))) )) ) cp)
(defun slot (obj fld) (assoc fld obj))
; значение поля объекта
Остается лишь слегка подкорректировать определение Лисп-интерпретатора, заодно используя необязательные параметры, осовобождающие от простейших вспомогательных определений, например от обязательного вхождения накопителей типа ассоциативного списка.
(DEFUN evcon- (c &optional a) ; |_________ключ, объявляющий ; необязательные параметры (COND ((eval-p (car (car c)) a) (eval-p (car (cdr (car c))) a) ) ( T (evcon- (cdr c) a) ) ))
(DEFUN evlis- (m &optional a) (COND ((EQ m Nil) Nil) ( T (cons (eval-p (car m) a) (evlis- (cdr m) a) ) ) ))
(defun eval-p (e &optional c) (cond ((atom e) (value e c)) ((atom (car e))(cond
((eq (car e) 'QUOTE) (car (cdr e))) ((eq (car e) 'COND) (evcon- (cdr e) a)) ((get (car e) 'METHOD) (method (car e) (evlis(cdr e)) c) ) ( T (apply-p (car e)(evlis- (cdr e) c) c)) ) ) (T (apply-p (car e)(evlis- (cdr e) c) c)) )) (defun apply-p (f args &optional c) (cond ((atom f) (apply-p (function f c) args c)) ((atom (car f))(cond ((get (car f) 'macro) (apply-p (apply-p (get (car f) 'macro) ( cdr f) c) args c))
(T (apply-p (eval f c) args c)) ) ) (T (apply-p (eval f c) args c)) ))
(print (eval-p 1)) (print (eval-p 'a)) (print (eval-p '(quote b))) (print (eval-p '(cond (Nil 6)(T 88) ))) (print (eval-p '(car '(3 2))))
