вывод формулы классов аргументов из
|
(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)) ; значение поля объекта |
| Пример 10.1. Модель интерпретатора объектно-ориентированных программ |
| Закрыть окно |
|
;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 "шаг разбора")) |
| Пример 10.2. Модель компилятора объектно-ориентированных программ |
| Закрыть окно |
