Table of Contents

План работ

Теперь добавим к нашей реализации (динамические) окружения. Окружения связывают переменные (символы) с их значениями, и если мы хотим добавить символы в язык, то идея окружений нам пригодится. Для этого, у myeval появляется еще один параметр env. В параметре env передается окружение, которое будет реализовано как ассоциативный список вида:

((a . 1) (b . 42) (c . somesymbol))

Таким образом, myeval становится таким:

(defun myeval (lst env)
  (cond
    ;; Какие-то действия в зависимости от того какая форма
    ;; ...
    (t (error 'eval-unknown-form-error :form lst :env env))))

Соотвественно все вызовы myeval изменяются, чтобы использовать env. Кроме того мы добавим классы ошибок, чтобы упростить отладку.

Сейчас мы реализуем динамическое окружение и сможем создавать динамические переменные. О их различиях есть специальная статья: Переменные в CL

Самовычисляемые формы

Здесь ничего не меняется

((null lst)                  nil)
((equal t lst)               t)
((numberp lst)               lst)

Тесты используют нулевое окружение, потому что вычисление чисел, T и NIL не зависят от окружения. Технически мы могли бы не хардкодить T и NIL а иметь базовое окружение, в котором они были бы вычислялись как обычные переменные.

;; Тесты для самовычисляемых форм
(assert (equal T (myeval 'T nil)))
(assert (equal NIL (myeval 'NIL nil)))
(assert (equal 999 (myeval 999 nil)))

Цитирование

Без изменений

((equal (car lst) 'quote)    (cadr lst))

Без изменений, кроме дополнительного параметра - нулевого окружения

;; Тесты для QUOTE
(assert (equal '(+ 1 2) (myeval '(quote (+ 1 2)) nil)))

Работа с CONS-ячейками

Добавляем параметр env в вызовы myeval

((equal (car lst) 'car)      (car (myeval (cadr lst) env)))
((equal (car lst) 'cdr)      (cdr (myeval (cadr lst) env)))
((equal (car lst) 'cons)     (cons (myeval (cadr lst) env)
                                   (myeval (caddr lst) env)))

Добавляем тесты, которые работают с cons-ячейками, полученными из окружения

;; Тесты для cons-ячеек
(assert (equal '(1 . 2) (myeval '(cons 1 2) nil)))
(assert (equal '((1 . 2) 3 . 4) (myeval '(cons (cons 1 2) (cons 3 4)) nil)))
(assert (equal 2 (myeval '(car (cons 2 3)) nil)))
(assert (equal 3 (myeval '(cdr (cons 2 3)) nil)))
(assert (equal '(1 . 2) (myeval '(car (cons (cons 1 2) (cons 3 4))) nil)))
(assert (equal '(3 . 4) (myeval '(cdr (cons (cons 1 2) (cons 3 4))) nil)))
;; Тесты для cons-ячеек, вычисляемых в окружении
(assert (equal 1 (myeval '(car a) '((a . (1 . 2))))))
(assert (equal 2 (myeval '(cdr a) '((a . (1 . 2))))))
(assert (equal 3 (myeval '(car b) '((a . (1 . 2)) (b . (3 . 4))))))

NULL-предикат

Без изменений

((equal (car lst) 'null)     (null (myeval (cadr lst) env)))

Добавляем тесты, проверящие символ в окружении, равный nil и не nil

;; Тесты для NULL
(assert (equal T (myeval '(null ()) nil)))
(assert (equal T (myeval '(null nil) nil)))
(assert (equal NIL (myeval '(null T) nil)))
(assert (equal T (myeval '(null a) '((a . ())))))
;; Тесты для NULL, с аргументом, вычисляемым в окружении
(assert (equal NIL (myeval '(null a) '((a . T)))))
(assert (equal NIL (myeval '(null a) '((a . 1)))))

Условное выполнение IF

Без изменений

((equal (car lst) 'if)       (if (myeval (cadr lst) env)
                                 (myeval (caddr lst) env)
                                 (myeval (cadddr lst) env)))

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

;; Тесты для IF
(assert (equal 2 (myeval '(if () 1 2) nil)))
(assert (equal 1 (myeval '(if (null ()) 1 2) nil)))
;; Тесты для IF, где условие вычисляется в окружении
(assert (equal 2 (myeval '(if a 1 2) '((a . ())))))
(assert (equal 1 (myeval '(if a 1 2) '((a . 1)))))

COND

Добавляем параметр в определение evcond:

(defun evcond (lst env)
  (cond ((null lst)               nil)
        ((myeval (caar lst) env)  (myeval (cadar lst) env))
        (t                        (evcond (cdr lst) env))))

Добавляем тесты, где вычисление зависит от переменных, определенных в окружении

;; Тесты для EVCOND
(assert (equal 2   (evcond '((t 2)   (t 1)) nil)))
(assert (equal 1   (evcond '((nil 2) (t 1)) nil)))
(assert (equal nil (evcond '((nil 2) (nil 1)) env)))
;; Тесты для EVCOND, где участвует окружение
(assert (equal 2 (evcond '((a 2) (b 1))
                         '((a . 1) (b . ())))))
(assert (equal 1 (evcond '((a 2) (b 1))
                         '((a . nil) (b . T)))))

Без изменений

((equal (car lst) 'cond)     (evcond (cdr lst) env))

Добавляем тесты для окружений

;; Тесты для COND
(assert (equal 2 (myeval '(cond
                           (() 1)
                           (1 2))
                         nil)))
;; Тесты для COND в окружении
(assert (equal 2 (myeval '(cond
                         (a 1)
                         (b 2))
                       '((a . ()) (b . 1)))))
(assert (equal 1 (myeval '(cond
                           (a 1)
                           (b 2))
                         '((a . 1) (b . ())))))

PROGN

Добавляем параметр env:

(defun evprogn (lst env)
  (cond ((null lst)        nil)
        ((null (cdr lst))  (myeval (car lst) env))
        (t                 (myeval (car lst) env)
                           (evprogn (cdr lst) env))))

Добавляем тест в окружении

;; Тест для EVPROGN
(assert (equal 2 (evprogn '(1 2))))
;; Тест для EVPROGN в окружении
(assert (equal 3 (evprogn '(a b c) '((a . 1) (b . 2) (c . 3)))))

Без изменений

((equal (car lst) 'progn)    (evprogn (cdr lst) env))

Добавляем тесты в окружении

;; Тест для PROGN
(assert (equal 3 (myeval '(progn 1 2 3) nil)))
;; Тест для PROGN в окружении
(assert (equal 3 (myeval '(progn a b c) '((a . 1) (b . 2) (c . 3)))))

PRINT

Добавляем параметр env:

Добавляем тест в окружении

LIST

Добавляем параметр env:

(defun evlis (lst env)
  (cond ((null lst)  nil)
        (t           (cons (myeval (car lst) env)
                     (evlis (cdr lst) env)))))

Добавляем тесты в окружении

;; Тесты для EVLIS
(assert (equal '(3 6 42)
               (evlis '((+ 1 2) (* 2 3) 42) nil)))
;; Тесты для EVLIS в окружении
(assert (equal '(3 6 42)
               (evlis '((+ a b) (* b c) 42) '((a . 1) (b . 2) (c . 3) (d . 4)))))

LIST определяем почти без изменений:

((equal (car lst) 'list)     (evlis (cdr lst) env))

Протестируем list (добавляя тесты в окружении)

;; Тесты для LIST
(assert (equal '(3 6 42)
               (myeval '(list (+ 1 2) (* 2 3) 42) nil)))
;; Тесты для LIST в окружении
(assert (equal '(3 6 42)
               (myeval '(list (+ a b) (* b c) 42)
                       '((a . 1) (b . 2) (c . 3) (d . 4)))))

AND

Добавляем параметр env:

(defun evand (lst env)
  (cond ((null lst)        (and))
        ((null (cdr lst))  (and (myeval (car lst) env)))
        (t                 (and (myeval (car lst) env)
                                (evand (cdr lst) env)))))

Добавим тесты evand в окружении:

;; Тесты для EVAND
(assert (equal (and)           (evand '() nil)))
(assert (equal (and 1)         (evand '(1) nil)))
(assert (equal (and nil)       (evand '(nil) nil)))
(assert (equal (and 1 nil)     (evand '(1 nil) nil)))
(assert (equal (and 1 2 nil)   (evand '(1 2 nil) nil)))
(assert (equal (and 1 2 3)     (evand '(1 2 3) nil)))
;; Тесты для EVAND в окружении
(assert (equal (let ((a nil))
                 (and nil))
               (evand '(a) '((a . nil)))))
(assert (equal (let ((a 1))
                 (and a))
               (evand '(a) '((a . 1)))))
(assert (equal (let ((a 1)
                     (b nil))
                 (and a b))
               (evand '(a b) '((a . 1) (b . nil)))))
(assert (equal (let ((a 1)
                     (b 2)
                     (c nil))
                 (and a b c))
               (evand '(a b c) '((a . 1) (b . 2) (c . nil)))))
(assert (equal (let ((a 1)
                     (b 2)
                     (c 3))
                 (and a b c))
               (evand '(a b c) '((a . 1) (b . 2) (c . 3)))))

Теперь мы можем определить and:

((equal (car lst) 'and)      (evand (cdr lst) env))

Протестируем and:

;; Тесты для AND
(assert (equal (and)                (myeval '(and) nil)))
(assert (equal (and 1)              (myeval '(and 1) nil)))
(assert (equal (and nil)            (myeval '(and nil) nil)))
(assert (equal (and 1 nil)          (myeval '(and 1 nil) nil)))
(assert (equal (and 1 2 nil)        (myeval '(and 1 2 nil) nil)))
(assert (equal (and 1 2 3)          (myeval '(and 1 2 3) nil)))
(assert (equal (and 1 (and 1 2) 3)  (myeval '(and 1 (and 1 2) 3) nil)))
;; Тесты для AND в окружении
(assert (equal (let ((a nil))
                 (and nil))
               (myeval '(and a) '((a . nil)))))
(assert (equal (let ((a 1))
                 (and a))
               (myeval '(and a) '((a . 1)))))
(assert (equal (let ((a 1)
                     (b nil))
                 (and a b))
               (myeval '(and a b) '((a . 1) (b . nil)))))
(assert (equal (let ((a 1)
                     (b 2)
                     (c nil))
                 (and a b c))
               (myeval '(and a b c) '((a . 1) (b . 2) (c . nil)))))
(assert (equal (let ((a 1)
                     (b 2)
                     (c 3))
                 (and a b c))
               (myeval '(and a b c) '((a . 1) (b . 2) (c . 3)))))

OR

Определение or полностью аналогочно определению and:

(defun evor (lst env)
  (cond ((null lst)        (or))
        ((null (cdr lst))  (or (myeval (car lst) env)))
        (t                 (or (myeval (car lst) env)
                               (evor (cdr lst) env)))))

Тесты

;; Тесты для EVOR
(assert (equal (or)           (evor '() nil)))
(assert (equal (or nil 1)     (evor '(nil 1) nil)))
(assert (equal (or nil nil 1) (evor '(nil nil 1) nil)))
(assert (equal (or nil 1 2)   (evor '(nil 1 2) nil)))
(assert (equal (or 1 2 3)     (evor '(1 2 3) nil)))
;; Тесты для EVOR в окружении
(assert (equal (let ((a nil))
                 (or a))
               (evor '(a) '((a . nil)))))
(assert (equal (let ((a 1))
                 (or a))
               (evor '(a) '((a . 1)))))
(assert (equal (let ((a nil)
                     (b 1))
                 (or a b))
               (evor '(a b) '((a . nil) (b . 1)))))
(assert (equal (let ((a nil)
                     (b nil)
                     (c 3))
                 (or a b c))
               (evor '(a b c) '((a . nil) (b . nil) (c . 3)))))
(assert (equal (let ((a nil)
                     (b 1)
                     (c 2))
                 (or a b c))
               (evor '(a b c) '((a . nil) (b . 1) (c . 2)))))

Теперь мы можем определить or:

((equal (car lst) 'or)       (evor  (cdr lst) env))

Протестируем or:

;; Тесты для OR
(assert (equal (or)                  (myeval '(or) nil)))
(assert (equal (or nil 1)            (myeval '(or nil 1) nil)))
(assert (equal (or nil nil 1)        (myeval '(or nil nil 1) nil)))
(assert (equal (or nil 1 2)          (myeval '(or nil 1 2) nil)))
(assert (equal (or nil (or 3 2) 2)   (myeval '(or nil (or 3 2) 2) nil)))
;; Тесты для OR в окружении
(assert (equal (let ((a nil))
                 (or a))
               (myeval '(or a) '((a . nil)))))
(assert (equal (let ((a 1))
                 (or a))
               (myeval '(or a) '((a . 1)))))
(assert (equal (let ((a nil)
                     (b 1))
                 (or a b))
               (myeval '(or a b) '((a . nil) (b . 1)))))
(assert (equal (let ((a nil)
                     (b nil)
                     (c 3))
                 (or a b c))
               (myeval '(or a b c) '((a . nil) (b . nil) (c . 3)))))
(assert (equal (let ((a nil)
                     (b 1)
                     (c 2))
                 (or a b c))
               (myeval '(or a b c) '((a . nil) (b . 1) (c . 2)))))

Встроенные функции арифметики

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

(defun evadd (lst acc env)
  (cond ((null lst)        0)
        ((null (cdr lst))  (+ acc (myeval (car lst) env)))
        (t                 (evadd (cdr lst)
                                  (+ acc (myeval (car lst) env))
                                  env))))
(defun evmul (lst acc env)
  (cond ((null lst)        1)
        ((null (cdr lst))  (* acc (myeval (car lst) env)))
        (t                 (evmul (cdr lst)
                                  (* acc (myeval (car lst) env))
                                  env))))

Теперь нам нужно помнить, что начальное значение аккумулятора для evadd равно нулю, а для evmul - единице.

;; Тесты для EVADD
(assert (equal 0                (evadd '() 0 nil)))
(assert (equal 2                (evadd '(2) 0 nil)))
(assert (equal 5                (evadd '(2 3) 0 nil)))
(assert (equal (+ 2 3 4)        (evadd '(2 3 4) 0 nil)))
(assert (equal (+ 2 (+ 3 4))    (evadd '(2 (+ 3 4)) 0 nil)))
(assert (equal (+ 2 (+ 3 4) 5)  (evadd '(2 (+ 3 4) 5) 0 nil)))
;; Тесты для EVADD в окружении
(assert (equal (let ((a 2))
                 (+ a))
               (evadd '(a)
                      0
                      '((a . 2)))))
(assert (equal (let ((a 2) (b 3))
                 (+ a b))
               (evadd '(a b)
                      0
                      '((a . 2) (b . 3)))))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (+ a b c))
               (evadd '(a b c)
                      0
                      '((a . 2) (b . 3) (c . 4)))))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (+ a (+ b c)))
               (evadd '(a (+ b c))
                      0
                      '((a . 2) (b . 3) (c . 4)))))
(assert (equal (let ((a 2) (b 3) (c 4) (d 5))
                 (+ a (+ b c) d))
               (evadd '(a (+ b c) d)
                      0
                      '((a . 2) (b . 3) (c . 4) (d . 5)))))
;; Тесты для EVMUL
(assert (equal 1                (evmul '() 1 nil)))
(assert (equal 2                (evmul '(2) 1 nil)))
(assert (equal 6                (evmul '(2 3) 1 nil)))
(assert (equal (* 2 3 4)        (evmul '(2 3 4) 1 nil)))
(assert (equal (* 2 (* 3 4))    (evmul '(2 (* 3 4)) 1 nil)))
(assert (equal (* 2 (* 3 4) 5)  (evmul '(2 (* 3 4) 5) 1 nil)))
;; Тесты для EVMUL в окружении
(assert (equal (let ((a 2))
                 (* a))
               (evmul '(2)
                      1
                      '((a . 2)))))
(assert (equal (let ((a 2) (b 3))
                 (* a b))
               (evmul '(2 3)
                      1
                      '((a . 2) (b . 3)))))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (* a b c))
               (evmul '(2 3 4)
                      1
                      '((a . 2) (b . 3) (c . 4)))))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (* a (* b c)))
               (evmul '(a (* b c))
                      1
                      '((a . 2) (b . 3) (c . 4)))))
(assert (equal (let ((a 2) (b 3) (c 4) (d 5))
                 (* a (* b c) d))
               (evmul '(a (* b c) d)
                      1
                      '((a . 2) (b . 3) (c . 4) (d . 5)))))

Вызов в my-eval использует аккумулятор и дополнительный параметр env

((equal (car lst) '+)        (evadd (cdr lst) 0 env))
((equal (car lst) '*)        (evmul (cdr lst) 1 env))

К старым тестам (изменным, чтобы принимать пустое окружение) добавляем новые, которые используют окружение в виде ассоциативного списка, которое пока мы формируем вручную.

;; Тесты для сложения
(assert (equal 0                (myeval '(+) nil)))
(assert (equal (+ 2)            (myeval '(+ 2) nil)))
(assert (equal (+ 2 3)          (myeval '(+ 2 3) nil)))
(assert (equal (+ 2 3 4)        (myeval '(+ 2 3 4) nil)))
(assert (equal (+ 2 (+ 3 4))    (myeval '(+ 2 (+ 3 4)) nil)))
(assert (equal (+ 2 (+ 3 4) 5)  (myeval '(+ 2 (+ 3 4) 5) nil)))
;; Тесты для умножения
(assert (equal 1                (myeval '(*) nil)))
(assert (equal (* 2)            (myeval '(* 2) nil)))
(assert (equal (* 2 3)          (myeval '(* 2 3) nil)))
(assert (equal (* 2 3 4)        (myeval '(* 2 3 4) nil)))
(assert (equal (* 2 (* 3 4))    (myeval '(* 2 (* 3 4)) nil)))
(assert (equal (* 2 (* 3 4) 5)  (myeval '(* 2 (* 3 4) 5) nil)))
;; Тесты для сложения в окружении
(assert (equal 0
               (myeval '(+) nil)))
(assert (equal (let ((a 2))
                 (+ a))
               (myeval '(+ a)
                       '((a . 2)))))
(assert (equal (let ((a 2) (b 3))
                 (+ a b))
               (myeval '(+ a b)
                       '((a . 2) (b . 3)))))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (+ a b c))
               (myeval '(+ a b c)
                       '((a . 2) (b . 3) (c . 4)))))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (+ a (+ b c)))
               (myeval '(+ a (+ b c))
                       '((a . 2) (b . 3) (c . 4)))))
(assert (equal (let ((a 2) (b 3) (c 4) (d 5))
                 (+ a (+ b c) d))
               (myeval '(+ a (+ b c) d)
                       '((a . 2) (b . 3) (c . 4) (d . 5)))))
;; Тесты для умножения  в окружении
(assert (equal 1
               (myeval '(*) nil)))
(assert (equal (let ((a 2))
                 (* a))
               (myeval '(* a)
                       '((a . 2)))))
(assert (equal (let ((a 2) (b 3))
                 (* a b))
               (myeval '(* a b)
                       '((a . 2) (b . 3)))))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (* a b c))
               (myeval '(* a b c)
                       '((a . 2) (b . 3) (c . 4)))))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (* a (* b c)))
               (myeval '(* a (* b c))
                       '((a . 2) (b . 3) (c . 4)))))
(assert (equal (let ((a 2) (b 3) (c 4) (d 5))
                 (* a (* b c) d))
               (myeval '(* a (* b c) d)
                       '((a . 2) (b . 3) (c . 4) (d . 5)))))

Вычисление символов

Если мы встречаем символ, то мы должны найти его в нашем окружении. Мы можем достичь этого следующим образом:

((symbolp lst)               (cdr (assoc lst env)))

Важно поместить этот кусок ближе к началу myeval, чтобы избежать попыток выполнять над символом те операции, которые выполняются над списковыми формами.

Протестируем

;; Тесты для вычисления символов
(assert (equal 6 (myeval 'b '((a . 3) (b . 6)))))

LET

Теперь мы можем заняться более сложной частью - работой с окружениями. Чтобы добавить переменную в окружение нам понадобятся вспомогательных функции. Первая из них: EVLIS (Evaluate List) уже у нас есть (мы определили ее в разделе, где определен LIST).

Вторая вспомогательная функция: PAIRLIS. Мы будем использовать ее для работы с окружениями. Она принимает список ключей lst1, список значений lst2 и ассоциативный список результатов alist. В процессе своей работы из первых двух списков она формирует пары "ключ-значение" и добавляет их в alist.

(defun mypairlis (lst1 lst2 alist)
 (cond ((and (null lst1) (null lst2))  alist)
       ((or  (null lst1) (null lst2))  (error 'mypairlis-error :lst1 lst1 :lst2 lst2))
       (t                              (mypairlis (cdr lst1)
                                                  (cdr lst2)
                                                  (cons (cons (car lst1)
                                                              (car lst2))
                                                        alist)))))

Вариант с хвостовой рекурсией (написанный ниже) будет эффективнее. Кроме того есть различие в семантике, которое проявляется, если разрешены дубли в lambda-list. Если дубли запрещены, то неважно, какой pairlis использовать.

(define-condition mypairlis-error (error)
  ((lst1 :initarg :lst1  :reader lst1)
   (lst2 :initarg :lst2  :reader lst2))
  (:report
   (lambda (condition stream)
     (format stream "Error in MYPAIRLIS: wrong params:~%'~A~%'~A"
             (lst1 condition) (lst2 condition)))))

(defun mypairlis (lst1 lst2 alist)
  (cond ((and (null lst1) (null lst2))  alist)
        ((or  (null lst1) (null lst2))  (error 'mypairlis-error :lst1 lst1 :lst2 lst2))
        (t                              (cons (cons (car lst1)
                                                    (car lst2))
                                              (mypairlis (cdr lst1)
                                                         (cdr lst2)
                                                         alist)))))

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

;; Тест для MYPAIRLIS
(assert (equal '(( a . 1) (b . 2) ( c . 3) (z . 6) (y . 77))
               (mypairlis '(a b c) '(1 2 3) '((z . 6) (y . 77)))))
(assert (equal "error"
               (handler-case (mypairlis '(a b c) nil '((z . 6) (y . 77)))
                 (MYPAIRLIS-ERROR (condition) "error"))))
(assert (equal "error"
               (handler-case (mypairlis nil '(1 2 3) '((z . 6) (y . 77)))
                 (MYPAIRLIS-ERROR (condition) "error"))))

Имея эти функции мы можем определить LET:

((equal (car lst) 'let)      (evprogn (cddr lst) ; implicit progn
                                      (mypairlis (mapcar #'car (cadr lst))
                                                 (evlis (mapcar #'cadr (cadr lst))
                                                        env)
                                                 env)))

и проверить его:

;; Тест для LET
(assert (equal '(1 . 2) (myeval '(let ((a 1)
                                       (b 2))
                                  (cons a b)) nil)))

LET*

Определение LET* потребует одну дополнительную функцию, которую назовем EVLETSTAR. Она принимает три аргумента. Первый, varpairs, представляет собой пары "ключ-значение", которые на каждом шаге по одной будут добавлены в окружение env. Второй параметр, EXP, представляет собой тело выражения, которое должно быть вычислено, когда все varpairs будут добавлены в окончательное окружение.

(defun evletstar (varpairs exp env)
  (cond ((null varpairs)  (myeval exp env))
        (t                (evletstar (cdr varpairs)
                                     exp
                                     (cons (cons (caar varpairs)
                                                 (myeval (cadar varpairs) env))
                                           env)))))

Теперь мы можем определить LET*:

((equal (car lst) 'let*)     (evletstar (cadr lst)
                                        (caddr lst)
                                        env))

и протестировать его:

;; Тест для LET*
(assert (equal '(3 1 . 2) (myeval '(let* ((a 1)
                                          (b 2)
                                          (c (+ a b)))
                                    (cons c (cons a b))) nil)))

LAMBDA

Последняя форма, которую мы реализуем - LAMBDA. В нашем интерпретаторе она вычисляется при вызове, являясь первым аргументом вычисляемого списка: ((lambda (x) (cons x x)) 42) Кроме того, LAMBDA формирует свое окружение из своих параметров:

((equal (caar lst) 'lambda)  (myeval (car (cddar lst))
                                     (mypairlis (cadar lst)
                                                (evlis (cdr lst) env)
                                                env)))

Проверим работу LAMBDA:

;; Тест для LAMBDA
(assert (equal '(42 . 42) (myeval '((lambda (x)
                                      (cons x x))
                                    42) nil)))
(assert (equal '(42 . 17) (myeval '((lambda (x y)
                                      (cons x y))
                                    42 17) nil)))

Итоги

Добавляем обработку ошибок, чтобы получать более ясные сообщения при отладке.

Соберем простой интерпретатор из myeval и вспомогательных функций и запишем его файл:

<<evcond_1>>
<<evprogn_1>>
<<evlis_1>>
<<evand_1>>
<<evor_1>>
<<evaddmul_1>>
<<mypairlis_1>>
<<evletstar_1>>
(define-condition eval-unknown-form-error (error)
  ((form :initarg :form  :reader form)
   (env  :initarg :env   :reader env))
  (:report
   (lambda (condition stream)
     (format stream "Error in MYEVAL: Unknown form~%'~A~%can not be evaluated in environment~%'~A"
             (form condition) (env condition)))))

(defun myeval (lst env)
  (cond
    <<number_1>>
    <<symb_1>>
    <<quote_1>>
    <<car_cdr_cons_1>>
    <<null_1>>
    <<if_1>>
    <<cond_1>>
    <<progn_1>>
    <<print_1>>
    <<list_1>>
    <<and_1>>
    <<or_1>>
    <<ariph_1>>
    <<let_1>>
    <<letstar_1>>
    <<lambda_1>>
    (t (error 'eval-unknown-form-error :form lst :env env))))

<<symb_1_test>>
<<number_1_test>>
<<quote_1_test>>
<<car_cdr_cons_1_test>>
<<null_1_test>>
<<if_1_test>>
<<cond_1_test>>
<<evlis_1_test>>
<<list_1_test>>
<<evand_1_test>>
<<and_1_test>>
<<evor_1_test>>
<<or_1_test>>
<<evaddmul_1_test>>
<<ariph_1_test>>
<<mypairlis_1_test>>
<<let_1_test>>
<<letstar_1_test>>
<<lambda_1_test>>

Мы должны получить следующий результат:

(defun evcond (lst env)
  (cond ((null lst)               nil)
        ((myeval (caar lst) env)  (myeval (cadar lst) env))
        (t                        (evcond (cdr lst) env))))
(defun evprogn (lst env)
  (cond ((null lst)        nil)
        ((null (cdr lst))  (myeval (car lst) env))
        (t                 (myeval (car lst) env)
                           (evprogn (cdr lst) env))))
(defun evlis (lst env)
  (cond ((null lst)  nil)
        (t           (cons (myeval (car lst) env)
                           (evlis (cdr lst) env)))))
(defun evand (lst env)
  (cond ((null lst)        (and))
        ((null (cdr lst))  (and (myeval (car lst) env)))
        (t                 (and (myeval (car lst) env)
                                (evand (cdr lst) env)))))
(defun evor (lst env)
  (cond ((null lst)        (or))
        ((null (cdr lst))  (or (myeval (car lst) env)))
        (t                 (or (myeval (car lst) env)
                               (evor (cdr lst) env)))))
(defun evadd (lst acc env)
  (cond ((null lst)        0)
        ((null (cdr lst))  (+ acc (myeval (car lst) env)))
        (t                 (evadd (cdr lst)
                                  (+ acc (myeval (car lst) env))
                                  env))))
(defun evmul (lst acc env)
  (cond ((null lst)        1)
        ((null (cdr lst))  (* acc (myeval (car lst) env)))
        (t                 (evmul (cdr lst)
                                  (* acc (myeval (car lst) env))
                                  env))))
(define-condition mypairlis-error (error)
  ((lst1 :initarg :lst1  :reader lst1)
   (lst2 :initarg :lst2  :reader lst2))
  (:report
   (lambda (condition stream)
     (format stream "Error in MYPAIRLIS: wrong params:~%'~A~%'~A"
             (lst1 condition) (lst2 condition)))))

(defun mypairlis (lst1 lst2 alist)
  (cond ((and (null lst1) (null lst2))  alist)
        ((or  (null lst1) (null lst2))  (error 'mypairlis-error :lst1 lst1 :lst2 lst2))
        (t                              (cons (cons (car lst1)
                                                    (car lst2))
                                              (mypairlis (cdr lst1)
                                                         (cdr lst2)
                                                         alist)))))
(defun evletstar (varpairs exp env)
  (cond ((null varpairs)  (myeval exp env))
        (t                (evletstar (cdr varpairs)
                                     exp
                                     (cons (cons (caar varpairs)
                                                 (myeval (cadar varpairs) env))
                                           env)))))
(define-condition eval-unknown-form-error (error)
  ((form :initarg :form  :reader form)
   (env  :initarg :env   :reader env))
  (:report
   (lambda (condition stream)
     (format stream "Error in MYEVAL: Unknown form~%'~A~%can not be evaluated in environment~%'~A"
             (form condition) (env condition)))))

(defun myeval (lst env)
  (cond
    ((null lst)                  nil)
    ((equal t lst)               t)
    ((numberp lst)               lst)
    ((symbolp lst)               (cdr (assoc lst env)))
    ((equal (car lst) 'quote)    (cadr lst))
    ((equal (car lst) 'car)      (car (myeval (cadr lst) env)))
    ((equal (car lst) 'cdr)      (cdr (myeval (cadr lst) env)))
    ((equal (car lst) 'cons)     (cons (myeval (cadr lst) env)
                                       (myeval (caddr lst) env)))
    ((equal (car lst) 'null)     (null (myeval (cadr lst) env)))
    ((equal (car lst) 'if)       (if (myeval (cadr lst) env)
                                     (myeval (caddr lst) env)
                                     (myeval (cadddr lst) env)))
    ((equal (car lst) 'cond)     (evcond (cdr lst) env))
    ((equal (car lst) 'progn)    (evprogn (cdr lst) env))
    ((equal (car lst) 'print)    (print (myeval (cadr lst)  env)))
    ((equal (car lst) 'list)     (evlis (cdr lst) env))
    ((equal (car lst) 'and)      (evand (cdr lst) env))
    ((equal (car lst) 'or)       (evor  (cdr lst) env))
    ((equal (car lst) '+)        (evadd (cdr lst) 0 env))
    ((equal (car lst) '*)        (evmul (cdr lst) 1 env))
    ((equal (car lst) 'let)      (evprogn (cddr lst) ; implicit progn
                                          (mypairlis (mapcar #'car (cadr lst))
                                                     (evlis (mapcar #'cadr (cadr lst))
                                                            env)
                                                     env)))
    ((equal (car lst) 'let*)     (evletstar (cadr lst)
                                            (caddr lst)
                                            env))
    ((equal (caar lst) 'lambda)  (myeval (car (cddar lst))
                                         (mypairlis (cadar lst)
                                                    (evlis (cdr lst) env)
                                                    env)))
    (t (error 'eval-unknown-form-error :form lst :env env))))

;; Тесты для вычисления символов
(assert (equal 6 (myeval 'b '((a . 3) (b . 6)))))
;; Тесты для самовычисляемых форм
(assert (equal T (myeval 'T nil)))
(assert (equal NIL (myeval 'NIL nil)))
(assert (equal 999 (myeval 999 nil)))
;; Тесты для QUOTE
(assert (equal '(+ 1 2) (myeval '(quote (+ 1 2)) nil)))
;; Тесты для cons-ячеек
(assert (equal '(1 . 2) (myeval '(cons 1 2) nil)))
(assert (equal '((1 . 2) 3 . 4) (myeval '(cons (cons 1 2) (cons 3 4)) nil)))
(assert (equal 2 (myeval '(car (cons 2 3)) nil)))
(assert (equal 3 (myeval '(cdr (cons 2 3)) nil)))
(assert (equal '(1 . 2) (myeval '(car (cons (cons 1 2) (cons 3 4))) nil)))
(assert (equal '(3 . 4) (myeval '(cdr (cons (cons 1 2) (cons 3 4))) nil)))
;; Тесты для cons-ячеек, вычисляемых в окружении
(assert (equal 1 (myeval '(car a) '((a . (1 . 2))))))
(assert (equal 2 (myeval '(cdr a) '((a . (1 . 2))))))
(assert (equal 3 (myeval '(car b) '((a . (1 . 2)) (b . (3 . 4))))))
;; Тесты для NULL
(assert (equal T (myeval '(null ()) nil)))
(assert (equal T (myeval '(null nil) nil)))
(assert (equal NIL (myeval '(null T) nil)))
(assert (equal T (myeval '(null a) '((a . ())))))
;; Тесты для NULL, с аргументом, вычисляемым в окружении
(assert (equal NIL (myeval '(null a) '((a . T)))))
(assert (equal NIL (myeval '(null a) '((a . 1)))))
;; Тесты для IF
(assert (equal 2 (myeval '(if () 1 2) nil)))
(assert (equal 1 (myeval '(if (null ()) 1 2) nil)))
;; Тесты для IF, где условие вычисляется в окружении
(assert (equal 2 (myeval '(if a 1 2) '((a . ())))))
(assert (equal 1 (myeval '(if a 1 2) '((a . 1)))))
;; Тесты для COND
(assert (equal 2 (myeval '(cond
                           (() 1)
                           (1 2))
                         nil)))
;; Тесты для COND в окружении
(assert (equal 2 (myeval '(cond
                           (a 1)
                           (b 2))
                         '((a . ()) (b . 1)))))
(assert (equal 1 (myeval '(cond
                           (a 1)
                           (b 2))
                         '((a . 1) (b . ())))))
;; Тесты для EVLIS
(assert (equal '(3 6 42)
               (evlis '((+ 1 2) (* 2 3) 42) nil)))
;; Тесты для EVLIS в окружении
(assert (equal '(3 6 42)
               (evlis '((+ a b) (* b c) 42) '((a . 1) (b . 2) (c . 3) (d . 4)))))
;; Тесты для LIST
(assert (equal '(3 6 42)
               (myeval '(list (+ 1 2) (* 2 3) 42) nil)))
;; Тесты для LIST в окружении
(assert (equal '(3 6 42)
               (myeval '(list (+ a b) (* b c) 42)
                       '((a . 1) (b . 2) (c . 3) (d . 4)))))
;; Тесты для EVAND
(assert (equal (and)           (evand '() nil)))
(assert (equal (and 1)         (evand '(1) nil)))
(assert (equal (and nil)       (evand '(nil) nil)))
(assert (equal (and 1 nil)     (evand '(1 nil) nil)))
(assert (equal (and 1 2 nil)   (evand '(1 2 nil) nil)))
(assert (equal (and 1 2 3)     (evand '(1 2 3) nil)))
;; Тесты для EVAND в окружении
(assert (equal (let ((a nil))
                 (and nil))
               (evand '(a) '((a . nil)))))
(assert (equal (let ((a 1))
                 (and a))
               (evand '(a) '((a . 1)))))
(assert (equal (let ((a 1)
                     (b nil))
                 (and a b))
               (evand '(a b) '((a . 1) (b . nil)))))
(assert (equal (let ((a 1)
                     (b 2)
                     (c nil))
                 (and a b c))
               (evand '(a b c) '((a . 1) (b . 2) (c . nil)))))
(assert (equal (let ((a 1)
                     (b 2)
                     (c 3))
                 (and a b c))
               (evand '(a b c) '((a . 1) (b . 2) (c . 3)))))
;; Тесты для AND
(assert (equal (and)                (myeval '(and) nil)))
(assert (equal (and 1)              (myeval '(and 1) nil)))
(assert (equal (and nil)            (myeval '(and nil) nil)))
(assert (equal (and 1 nil)          (myeval '(and 1 nil) nil)))
(assert (equal (and 1 2 nil)        (myeval '(and 1 2 nil) nil)))
(assert (equal (and 1 2 3)          (myeval '(and 1 2 3) nil)))
(assert (equal (and 1 (and 1 2) 3)  (myeval '(and 1 (and 1 2) 3) nil)))
;; Тесты для AND в окружении
(assert (equal (let ((a nil))
                 (and nil))
               (myeval '(and a) '((a . nil)))))
(assert (equal (let ((a 1))
                 (and a))
               (myeval '(and a) '((a . 1)))))
(assert (equal (let ((a 1)
                     (b nil))
                 (and a b))
               (myeval '(and a b) '((a . 1) (b . nil)))))
(assert (equal (let ((a 1)
                     (b 2)
                     (c nil))
                 (and a b c))
               (myeval '(and a b c) '((a . 1) (b . 2) (c . nil)))))
(assert (equal (let ((a 1)
                     (b 2)
                     (c 3))
                 (and a b c))
               (myeval '(and a b c) '((a . 1) (b . 2) (c . 3)))))
;; Тесты для EVOR
(assert (equal (or)           (evor '() nil)))
(assert (equal (or nil 1)     (evor '(nil 1) nil)))
(assert (equal (or nil nil 1) (evor '(nil nil 1) nil)))
(assert (equal (or nil 1 2)   (evor '(nil 1 2) nil)))
(assert (equal (or 1 2 3)     (evor '(1 2 3) nil)))
;; Тесты для EVOR в окружении
(assert (equal (let ((a nil))
                 (or a))
               (evor '(a) '((a . nil)))))
(assert (equal (let ((a 1))
                 (or a))
               (evor '(a) '((a . 1)))))
(assert (equal (let ((a nil)
                     (b 1))
                 (or a b))
               (evor '(a b) '((a . nil) (b . 1)))))
(assert (equal (let ((a nil)
                     (b nil)
                     (c 3))
                 (or a b c))
               (evor '(a b c) '((a . nil) (b . nil) (c . 3)))))
(assert (equal (let ((a nil)
                     (b 1)
                     (c 2))
                 (or a b c))
               (evor '(a b c) '((a . nil) (b . 1) (c . 2)))))

;; Тесты для OR
(assert (equal (or)                  (myeval '(or) nil)))
(assert (equal (or nil 1)            (myeval '(or nil 1) nil)))
(assert (equal (or nil nil 1)        (myeval '(or nil nil 1) nil)))
(assert (equal (or nil 1 2)          (myeval '(or nil 1 2) nil)))
(assert (equal (or nil (or 3 2) 2)   (myeval '(or nil (or 3 2) 2) nil)))
;; Тесты для OR в окружении
(assert (equal (let ((a nil))
                 (or a))
               (myeval '(or a) '((a . nil)))))
(assert (equal (let ((a 1))
                 (or a))
               (myeval '(or a) '((a . 1)))))
(assert (equal (let ((a nil)
                     (b 1))
                 (or a b))
               (myeval '(or a b) '((a . nil) (b . 1)))))
(assert (equal (let ((a nil)
                     (b nil)
                     (c 3))
                 (or a b c))
               (myeval '(or a b c) '((a . nil) (b . nil) (c . 3)))))
(assert (equal (let ((a nil)
                     (b 1)
                     (c 2))
                 (or a b c))
               (myeval '(or a b c) '((a . nil) (b . 1) (c . 2)))))
;; Тесты для EVADD
(assert (equal 0                (evadd '() 0 nil)))
(assert (equal 2                (evadd '(2) 0 nil)))
(assert (equal 5                (evadd '(2 3) 0 nil)))
(assert (equal (+ 2 3 4)        (evadd '(2 3 4) 0 nil)))
(assert (equal (+ 2 (+ 3 4))    (evadd '(2 (+ 3 4)) 0 nil)))
(assert (equal (+ 2 (+ 3 4) 5)  (evadd '(2 (+ 3 4) 5) 0 nil)))
;; Тесты для EVADD в окружении
(assert (equal (let ((a 2))
                 (+ a))
               (evadd '(a)
                      0
                      '((a . 2)))))
(assert (equal (let ((a 2) (b 3))
                 (+ a b))
               (evadd '(a b)
                      0
                      '((a . 2) (b . 3)))))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (+ a b c))
               (evadd '(a b c)
                      0
                      '((a . 2) (b . 3) (c . 4)))))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (+ a (+ b c)))
               (evadd '(a (+ b c))
                      0
                      '((a . 2) (b . 3) (c . 4)))))
(assert (equal (let ((a 2) (b 3) (c 4) (d 5))
                 (+ a (+ b c) d))
               (evadd '(a (+ b c) d)
                      0
                      '((a . 2) (b . 3) (c . 4) (d . 5)))))
;; Тесты для EVMUL
(assert (equal 1                (evmul '() 1 nil)))
(assert (equal 2                (evmul '(2) 1 nil)))
(assert (equal 6                (evmul '(2 3) 1 nil)))
(assert (equal (* 2 3 4)        (evmul '(2 3 4) 1 nil)))
(assert (equal (* 2 (* 3 4))    (evmul '(2 (* 3 4)) 1 nil)))
(assert (equal (* 2 (* 3 4) 5)  (evmul '(2 (* 3 4) 5) 1 nil)))
;; Тесты для EVMUL в окружении
(assert (equal (let ((a 2))
                 (* a))
               (evmul '(2)
                      1
                      '((a . 2)))))
(assert (equal (let ((a 2) (b 3))
                 (* a b))
               (evmul '(2 3)
                      1
                      '((a . 2) (b . 3)))))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (* a b c))
               (evmul '(2 3 4)
                      1
                      '((a . 2) (b . 3) (c . 4)))))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (* a (* b c)))
               (evmul '(a (* b c))
                      1
                      '((a . 2) (b . 3) (c . 4)))))
(assert (equal (let ((a 2) (b 3) (c 4) (d 5))
                 (* a (* b c) d))
               (evmul '(a (* b c) d)
                      1
                      '((a . 2) (b . 3) (c . 4) (d . 5)))))
;; Тесты для сложения
(assert (equal 0                (myeval '(+) nil)))
(assert (equal (+ 2)            (myeval '(+ 2) nil)))
(assert (equal (+ 2 3)          (myeval '(+ 2 3) nil)))
(assert (equal (+ 2 3 4)        (myeval '(+ 2 3 4) nil)))
(assert (equal (+ 2 (+ 3 4))    (myeval '(+ 2 (+ 3 4)) nil)))
(assert (equal (+ 2 (+ 3 4) 5)  (myeval '(+ 2 (+ 3 4) 5) nil)))
;; Тесты для умножения
(assert (equal 1                (myeval '(*) nil)))
(assert (equal (* 2)            (myeval '(* 2) nil)))
(assert (equal (* 2 3)          (myeval '(* 2 3) nil)))
(assert (equal (* 2 3 4)        (myeval '(* 2 3 4) nil)))
(assert (equal (* 2 (* 3 4))    (myeval '(* 2 (* 3 4)) nil)))
(assert (equal (* 2 (* 3 4) 5)  (myeval '(* 2 (* 3 4) 5) nil)))
;; Тесты для сложения в окружении
(assert (equal 0
               (myeval '(+) nil)))
(assert (equal (let ((a 2))
                 (+ a))
               (myeval '(+ a)
                       '((a . 2)))))
(assert (equal (let ((a 2) (b 3))
                 (+ a b))
               (myeval '(+ a b)
                       '((a . 2) (b . 3)))))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (+ a b c))
               (myeval '(+ a b c)
                       '((a . 2) (b . 3) (c . 4)))))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (+ a (+ b c)))
               (myeval '(+ a (+ b c))
                       '((a . 2) (b . 3) (c . 4)))))
(assert (equal (let ((a 2) (b 3) (c 4) (d 5))
                 (+ a (+ b c) d))
               (myeval '(+ a (+ b c) d)
                       '((a . 2) (b . 3) (c . 4) (d . 5)))))
;; Тесты для умножения  в окружении
(assert (equal 1
               (myeval '(*) nil)))
(assert (equal (let ((a 2))
                 (* a))
               (myeval '(* a)
                       '((a . 2)))))
(assert (equal (let ((a 2) (b 3))
                 (* a b))
               (myeval '(* a b)
                       '((a . 2) (b . 3)))))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (* a b c))
               (myeval '(* a b c)
                       '((a . 2) (b . 3) (c . 4)))))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (* a (* b c)))
               (myeval '(* a (* b c))
                       '((a . 2) (b . 3) (c . 4)))))
(assert (equal (let ((a 2) (b 3) (c 4) (d 5))
                 (* a (* b c) d))
               (myeval '(* a (* b c) d)
                       '((a . 2) (b . 3) (c . 4) (d . 5)))))
;; Тест для MYPAIRLIS
(assert (equal '(( a . 1) (b . 2) ( c . 3) (z . 6) (y . 77))
               (mypairlis '(a b c) '(1 2 3) '((z . 6) (y . 77)))))
(assert (equal "error"
               (handler-case (mypairlis '(a b c) nil '((z . 6) (y . 77)))
                 (MYPAIRLIS-ERROR (condition) "error"))))
(assert (equal "error"
               (handler-case (mypairlis nil '(1 2 3) '((z . 6) (y . 77)))
                 (MYPAIRLIS-ERROR (condition) "error"))))
;; Тест для LET
(assert (equal '(1 . 2) (myeval '(let ((a 1)
                                       (b 2))
                                  (cons a b)) nil)))
;; Тест для LET*
(assert (equal '(3 1 . 2) (myeval '(let* ((a 1)
                                          (b 2)
                                          (c (+ a b)))
                                    (cons c (cons a b))) nil)))
;; Тест для LAMBDA
(assert (equal '(42 . 42) (myeval '((lambda (x)
                                      (cons x x))
                                    42) nil)))
(assert (equal '(42 . 17) (myeval '((lambda (x y)
                                      (cons x y))
                                    42 17) nil)))
Яндекс.Метрика
Home