lisp-4

Table of Contents

План работ

Цель этого этапа: преобразовать наш интерпретатор так, чтобы он был написан в стиле передачи продолжений (сontinuation-passing style, CPS).

Зачем мы это делаем? Сейчас мы имеем рекурсивный интерпретатор, который использует рекурсию, когда выполняет оценку (eval) программмы. Нам надо получить нерекурсивный (итеративный, циклический) интерпретатор, иначе:

  • нам придется пользоваться стеком хост-языка, чтобы обрабатывать рекурсивный eval
  • мы не сможем написать отладчик с точками останова, шагом исполнения и.т.п. потому что рекурсивный интерпретатор нельзя остановить в определенный момент.
  • мы не сможем сделать механизм обработки ошибок, такой как catch/trow и сложные структуры управления потоком управления.

Поэтому нам надо удалить рекурсию из интерпретатора. Есть два способа подойти к этой проблеме:

  • CPS-преобразование
  • Реализация SECD-машины

SECD-машину мы будем реализовывать несколько позже, а сейчас сосредоточимся на CPS-преобразовании. Оно дает нам бесплатные бонусы, например, решение semipredicate problem, проблемы полупредикатов.

Кроме того, на этом шаге мы переносим print и list из myeval в myapply.

Semipredicate problem

Полупредикаты - это предикаты, у которых может быть три возможных вида возвращаемых значений:

  • T
  • NIL
  • Еще один вид, например "элемент не найден"

Например, полупредикатом является assoc. Вот его реализация, которая названа assoc-1, чтобы не перекрывать встроенную функцию:

(defun assoc-1 (key alist)
  (cond ((null alist)              nil)
        ((equal key (caar alist))  (car alist))
        (t                         (assoc-1 key (cdr alist)))))

;; (assoc-1 'alfa '((alfa . 1) (beta . 2)))
;; => (ALFA . 1)

;; (assoc-1 'gamma '((alfa . 1) (beta . 2)))
;; => NIL

В этой реализации assoc-1 вынужден возвращать точечную пару (имя . значение), ведь иначе будет невозможно отличить ситуацию "элемент не найден" от ситуации "элемент имеет значение NIL".

Типичным вариантом использования ~assoc-1 ~является проверка на "элемент не найден" возвращаемого значения. Ее отсутствие, как правило является ошибкой. Так как после решения funarg-problem мы можем передавать функции, мы могли бы сделать такой вариант assoc, который принимал бы функцию, которая будет вызвана в ситуации "элемент не найден".

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

(defun assoc-2 (key alist cont errcont) ;; NB!: inverted order of
                                        ;; continuations (for lookup)
  (cond ((null alist)              (funcall errcont key))
        ((equal key (caar alist))  (funcall cont    (cdar alist)))
        (t                         (assoc-2 key (cdr alist) cont errcont))))

Мы можем протестировать это в обоих случаях:

(assert (equal "ok:123"
               (assoc-2 'alfa '((alfa . 123))
                        (lambda (x) (format nil "ok:~A" x))
                        (lambda (x) (format nil "err:~A" x)))))
(assert (equal "err:ALFA"
               (assoc-2 'alfa '((beta . 123))
                        (lambda (x) (format nil "ok:~A" x))
                        (lambda (x) (format nil "err:~A" x)))))

Lookup в глобальном окружении

Используя такой подход мы можем изменить lookup, который у нас выглядел так:

(defparameter *glob-env* nil)
(defun lookup (symb env)
  (let ((it (assoc symb env)))
    (if (not (null it))
        it
        (assoc symb *glob-env*))))

Теперь lookup будет написан в стиле передачи продолжений:

;; environment
(defparameter *glob-env* nil)
;; lookup
(defun lookup (symb env errcont cont)
  (assoc-2 symb env cont
           (lambda (key)
             (assoc-2 key *glob-env* cont
                      (lambda (key)
                        (funcall errcont
                                 (format
                                  nil
                                  "UNBOUD VARIABLE [~A] ~%LOCAL ENV: [~A] ~%GLOBAL ENV: [~A]"
                                  key env *glob-env*)))))))

Теперь lookup принимает два продолжения:

  • продолжение errcont вызывается в случае, если элемент не найден, ему передается ошибка в качестве параметра
  • продолжение cont вызывается, когда элемент найден, ему передается найденное значение в качестве параметра.

Мы можем протестировать его:

;; test lookup
(assert (equal "ok:123" (lookup 'aaa '((aaa . 123))
                                (lambda (x) (format nil "err:~A" x))
                                (lambda (x) (format nil "ok:~A" x)))))
(assert (equal nil      (lookup 'aaa '((bbb . 123))
                                (lambda (x) (declare (ignore x)) nil)
                                (lambda (x) (format nil "ok:~A" x)))))

Но для того того чтобы в конце концов получить вывод значения на экран нам понадобятся…

Функции для тестирования

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

(defun ok (x)
  (format t "~%ok: ~A" x)
  x)
(defun err (x)
  (format t "~%err: ~A" x)
  x)

Мы будем передавать их как cont и errcont.

Структура замыкания

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

(defstruct closure
  body
  env
  args)

Преобразование EVLIS

Напомним, что EVLIS - это функция, которая оценивает аргументы перед применением (MYAPPLY). Мы хотим преобразовать ее к CPS-виду. Нам потребуется несколько этапов, чтобы понять и реализовать это.

  • Преобразование в CPS на примере факториала (через рекурсию с аккумулятором)
  • Преобразование на примере фибоначчи
  • Преобразование функции обработки списка
  • Преобразование EVLIS

Преобразование факториала

В качестве примера возьмем факториал:

(defun fact (n)
  (cond ((equal 0 n)  1)
        (t            (* n (fact (- n 1))))))

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

Мы можем использовать параметр-аккумулятор, чтобы преобразовать нехвостовую рекурсию в хвостовую. Этот аккумулятор будет накапливать результат вычисления, который ранее был в возвращаемом значении. Тогда нам уже не нужно использовать возвращаемое значение при шаге вычисления и мы можем сделать рекурсию хвостовой.

Тогда наш факториал будет таким:

(defun fact-tail-call (n &optional (acc 1))
  (cond ((equal 0 n)  acc)
        (t            (fact-tail-call (- n 1)
                                      (* n acc)))))

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

Технически, мы можем построить эквивалентный цикл для этого кода:

(defun fact-iter (param)
  (let ((acc 1))
    (loop :for n :from param :downto 1 :do
       (setf acc (* n acc))
       (print acc))
    acc))

Теперь перепишем хвосторекурсивный факториал в cps-стиле. Чтобы преобразовать fact-tail-call в fact-tail-call-cps добавим параметр-продолжение cont, в который будем передавать функцию, которая представляет собой остаток вычисления. (- n 1) мы можем вычислить сразу, а (* n acc) - нет, так как у нас больше нет параметра acc.

(defun fact-tail-call-cps (n cont)
  (cond ((equal n 1)  (funcall cont 1))
        (t            (fact-tail-call-cps (- n 1)
                                          (lambda (x)
                                            (funcall cont (* n x)))))))
(defun fact-tail-call-cps-start (n)
  (fact-tail-call-cps n (lambda (x) x)))

Здесь вместо аккумулятора мы передаем продолжение. Это продолжение представлят собой лямбду, которая вызывает продолжение-параметр. Это продолжение-параметр вызывается с аргументом, который представляет собой собственно вычисление (n * x). По-видимому, это такой довольно интересный способ отложить вычисления до тех пор пока мы не достигнем базы рекурсии.

В самом деле, при вызове (fact-tail-call-cps 3 #'(lambda (x) x)), когда мы достигнем базы рекурсии будет выполнено это:

(funcall (lambda (x)
           (funcall (lambda (x)
                      (funcall (lambda (x)
                                 x)
                               (* 3 x)))
                    (* 2 x)))
         1)

Преобразование фибоначчи

Второй пример будет чуть сложнее - числа фибоначчи:

(defun fib (n)
  (cond ((equal n 1)  1)
        ((equal n 2)  1)
        (t            (+ (fib (- n 1))
                         (fib (- n 2))))))

Преобразуем вызов в хвосторекурсивный, используя аккумуляторы. С помощью них мы можем уменьшить количество вложенных вызовов, если применим такую стратегию вычилений:

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

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

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

(defun ftc (n &optional (acc1 1) (acc2 1))
  (cond ((or (equal 1 n)
             (equal 2 n))  acc2)
        (t                 (ftc (- n 1) acc2 (+ acc1 acc2)))))

Теперь перепишем в cps-стиле:

(defun ftc-cps (n cont)
  (cond ((equal 1 n)  (funcall cont 1 1))
        ((equal 2 n)  (funcall cont 1 1))
        (t            (ftc-cps (- n 1)
                               (lambda (acc1 acc2)
                                 (funcall cont acc2 (+ acc1 acc2)))))))

(defun ftc-cps-start (n)
  (ftc-cps n (lambda (acc1 acc2)
               acc2)))

[TODO:gmm] - Здесь надо для тренировки превратить это в CPS.

Преобразование функции обработки списка

Еще один пример, но этот раз для списка - функция, которая проходит по списку удваивая каждый элемент:

(defun mul2 (lst)
  (cond ((null lst)  nil)
        (t           (cons (* 2 (car lst))
                           (mul2 (cdr lst))))))

Воспользовавшись тем же подходом получим ее хвосторекурсивный вариант:

(defun mul2 (lst &optional (acc nil))
  (cond ((null lst)  (reverse acc))
        (t           (mul2 (cdr lst)
                           (cons (* 2 (car lst)) acc)))))

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

Можно смотреть на процесс обработки списка как на перемещение головы списка lst в голову acc. Мы могли бы переименовать lst в "список еще невычесленных форм" unevaled, а acc в "список уже вычисленных форм" evaled:

(defun mul2 (unevaled &optional (evaled nil))
  (cond ((null unevaled)  (reverse evaled))
        (t                (mul2 (cdr unevaled)
                                (cons (* 2 (car unevaled))
                                      evaled)))))

Следующим шагом можно отделить функцию, которая обрабатывает элементы списка. Зададим ее как параметр:

(defun mul2 (fn unevaled &optional (evaled nil))
  (cond ((null unevaled)  (reverse evaled))
        (t                (mul2 fn
                                (cdr unevaled)
                                (cons (funcall fn (car unevaled))
                                      evaled)))))

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

(defun mul2 (fn unevaled evaled)
  (cond ((null unevaled)  (reverse evaled))
        (t                (mul2 fn
                                (cdr unevaled)
                                (cons (funcall fn (car unevaled))
                                      evaled)))))

[TODO:gmm] - Для тренировки преобразовать в CPS?

Преобразование EVLIS и MYEVAL

Возьмем нашу функцию evis (из предыдущего этапа):

(defun evlis (unevaled evaled env)
  (cond ((null unevaled)  (reverse evaled))
        (t                (evlis (cdr unevaled)
                                 (cons (myeval (car unevaled) env)
                                       evaled)))))

Мы помним, что сейчас myeval принимает продолжения. Значит и evlis должен их принимать:

(defun evlis (unevaled evaled env errcont cont)
  (cond ((null unevaled)  (reverse evaled))
        (t                (evlis (cdr unevaled)
                                 (cons (myeval (car unevaled) env errcont cont)
                                       evaled)
                                 env errcont cont))))

Теперь проведем CPS-преобразование. Вызов myeval - первый из вычисляемых и имеющих продолжение, поэтому мы можем передать ему все остальное как параметр cont.

(defun evlis (unevaled evaled env errcont cont)
  (cond ((null unevaled)  (funcall cont (reverse evaled)))
        (t                (myeval (car unevaled) env errcont
                                  (lambda (x)
                                    (evlis (cdr unevaled)
                                           (cons x evaled)
                                           env errcont cont))))))

Вспомним, как выглядит наша функция MYAPPLY из предыдущего раздела:

(defun myeval (lst env)
  (cond
    ...
    (t
     (myapply (myeval (car lst) env)
              (evlis (cdr lst) nil env)))))

Если мы преобразуем ее в CPS-стиль, то у нас получится вот так:

(defun myeval (exp env errcont cont)
  (cond
    ...
    (t
     (myeval (car exp) env errcont
             (lambda (x) ;; x - это результат вычисления формы (car list)
               (evlis (cdr exp) nil env errcont
                      (lambda (y) ;; y - это список форм
                        (myapply x y errcont cont))))))))

Здесь есть неприятный момент, связанный с тем, что последнее продолжение (y) не соответствует шагу вычисления интерпретатора. Если бы у нас был отладчик, позволяющий перемещаться по продолжениям вверх и вниз, то мы бы обнаружили, что продолжения, не соответствующие шагам вычисления интерпретатора, мешают.

Пользователь языка мыслит в терминах вычисления форм, а не в терминах внутренних продолжений интерпретатора, соответственно продолжения должны повторять это мышение в терминах вычисления форм. Следовательно, нужно выделять продолжения так, чтобы каждому продолжению соответстовала форма. Например, у Гая Стила в интерпретаторе foo https://gist.github.com/fogus/3698078 лишние продолжения, но если нет отладчика продолжений, то пользователь языка этого, конечно, не заметит.

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

Если взять оригинальный, не хвосторекурсивный evlis и преобразовать его CPS то получится вот так:

(defun evlis-orig-cps (lst env errcont cont)
  (cond ((null lst) nil)
        (t (myeval (car lst) env errcont
                   (lambda (x)    ; результат формы (car lst)
                     (evlis (cdr lst) env errcont
                            (lambda (y)  ; список выч. форм
                              (funcall cont (cons x y)))))))))

А если перед этим сделать его хвосторекурсивным с аккумулятором и только потом преобразовать в CPS - то получится так:

(defun evlis (unevaled evaled env errcont cont)
  (cond ((null unevaled)  (funcall cont (reverse evaled)))
        (t                (myeval (car unevaled) env errcont
                                  (lambda (x)
                                    (evlis (cdr unevaled)
                                           (cons x evaled)
                                           env errcont cont))))))

Как мы видим из MYEVAL

(defun myeval (exp env errcont cont)
  (cond
    ...
    (t
     (myeval (car exp) env errcont
             (lambda (x)
               (evlis (cdr exp) nil env errcont
                      (lambda (y)   ; y -- список форм
                        (myapply x y errcont cont))))))))

Нужно преобразовать evlis так, чтобы продожение в myeval где комментарий "y – список форм" исчезло

Для этого мы переместим функционал myapply (применение функции к аргументам) прямо в evlis, передав ему функцию, которую будем применять. Тогда выйдет вот так:

(defun myeval (exp env errcont cont)
  (cond
    ...
    (myeval (car exp) env errcont
            (lambda (x)
              (evlis x (cdr exp) nil env errcont cont)))))
(defun evlis (fn unevaled evaled env errcont cont)
  (cond ((null unevaled)  (myapply fn (reverse evaled) errcont cont))
        (t                (myeval (car unevaled) env errcont
                                  (lambda (x)
                                    (evlis fn
                                           (cdr unevaled)
                                           (cons x evaled)
                                           env errcont cont))))))

Что мы и видим в результате:

;; менее эффективный но более понятный вариант evlis
(defun evlis (fn unevaled evaled env errcont cont)
  (cond ((null unevaled)  (myapply fn evaled errcont cont))
        (t                (myeval (car unevaled) env errcont
                                  (lambda (x)
                                    (evlis fn
                                           (cdr unevaled)
                                           (append evaled (list x))
                                           env errcont cont))))))
;; более эффективный вариант evlis
(defun evlis (fn unevaled evaled env errcont cont)
  (cond ((null unevaled)  (myapply fn (reverse evaled) errcont cont))
        (t                (myeval (car unevaled) env errcont
                                  (lambda (x)
                                    (evlis fn
                                           (cdr unevaled)
                                           (cons x evaled)
                                           env errcont cont))))))

Роман:

Потом еще fn добавить надо, чтобы удовлетворить нашиму (ограниченному) пониманию cps. Таким образом итоговый evlis сначала вычисляет аргументы, а потом применяет функцию. Оригинальный evlis делал только первое.

Михаил:

а зачем нам fn?

Роман:

Вот тут же:

(defun evlis (fn unevaled evaled env errcont cont)
  (cond ((null unevaled) (myapply fn (reverse evaled) errcont cont))
        ...
        ))

Иначе будут континуации, которые не соответствуют шагу вычислений. Так не пойдет:

(defun evlis (unevaled evaled env errcont cont)
  (cond ((null unevaled) (funcall cont evaled))
        ...
        ))

Потому что cont тогда принимает не результат формы, а список результатов, что противоречит нашему пониманию cps.

Роман:

Одна из причин преобразования в cps — сделать рекурсию хвостовой. Применение cps к функции с хвостовой рекурсией вообще ничего не дает. Вот evlis — другое дело. Преобразовав ее к хвостовому виду добавив аккумулятор, мы еще не привели к хвостовому виду вызов myeval. Вот поэтому мы и делаем cps над evlis с хвостовой рекурсией.

MyApply

Теперь myapply принимает два продолжения: errcont и cont.

Переносим сюда print из myeval, потому что это функция, которая оценивает свои аргументы.

(define-condition unknown-function (error)
  ((fn :initarg :fn  :reader fn))
  (:report
   (lambda (condition stream)
     (format stream "Error in MYAPPLY: unknown-function: ~A"
             (fn condition)))))
<<evaddmul_4>>
<<evlis_4>>
(defun myapply (fn args errcont cont)
  (cond
    <<myapply_car_cdr_cons_4>>
    <<myapply_null_4>>
    <<myapply_ariph_4>>
    <<myapply_closure_4>>
    <<myapply_print_4>>
    <<myapply_list_4>>
    (t (error 'unknown-function :fn fn))))

А набор тестов остался без изменений:

<<myapply_car_cdr_cons_4_test>>
<<myapply_null_4_test>>
<<evaddmul_4_test>>
<<myapply_ariph_4_test>>
<<myapply_closure_4_test>>
<<myapply_print_4_test>>
<<myapply_evlis_4_test>>
<<myapply_list_4_test>>

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

Функции, которые работают с cons-ячейками теперь вызывают продолжение cont, передавая ему в качестве параметра результат своих вычислений.

((equal fn 'car)             (funcall cont (caar args)))
((equal fn 'cdr)             (funcall cont (cdar args)))
((equal fn 'cons)            (funcall cont (cons (car args) (cadr args))))

Тесты такие-же, но теперь принимают продолжения

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

NULL-предикат

(define-condition invalid-number-of-arguments (error)
  ((fn :initarg :fn  :reader fn))
  (:report
   (lambda (condition stream)
     (format stream "Error in MYAPPLY: invalid-number-of-arguments: ~A"
             (fn condition)))))

null теперь тоже вызывает продолжение cont:

((equal fn 'null)            (if (null (cdr args))
                                 (funcall cont (null (car args)))
                                 (error 'invalid-number-of-arguments :fn fn)))

Тесты такие-же, но теперь принимают продолжения

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

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

Вспомогательные функции evadd и evmul мы не будем преобразовывать в CPS потому что они не являются частью интерпретатора. Поэтому этот раздел остается без изменений

(defun evadd (lst acc)
  (cond ((null lst)        0)
        ((null (cdr lst))  (+ acc (car lst)))
        (t                 (evadd (cdr lst)
                                  (+ acc (car lst))))))
(defun evmul (lst acc)
  (cond ((null lst)        1)
        ((null (cdr lst))  (* acc (car lst)))
        (t                 (evmul (cdr lst)
                                  (* acc (car lst))))))
;; Тесты для EVADD
(assert (equal 0                (evadd '() 0)))
(assert (equal 2                (evadd '(2) 0)))
(assert (equal 5                (evadd '(2 3) 0)))
(assert (equal (+ 2 3 4)        (evadd '(2 3 4) 0)))
;; Тесты для EVMUL
(assert (equal 1                (evmul '() 1)))
(assert (equal 2                (evmul '(2) 1)))
(assert (equal 6                (evmul '(2 3) 1)))
(assert (equal (* 2 3 4)        (evmul '(2 3 4) 1)))
((equal fn '+)               (funcall cont (evadd args 0)))
((equal fn '*)               (funcall cont (evmul args 1)))
;; Тесты для сложения
(assert (equal 0                (myeval '(+) nil #'err #'ok)))
(assert (equal (+ 2)            (myeval '(+ 2) nil #'err #'ok)))
(assert (equal (+ 2 3)          (myeval '(+ 2 3) nil #'err #'ok)))
(assert (equal (+ 2 3 4)        (myeval '(+ 2 3 4) nil #'err #'ok)))
(assert (equal (+ 2 (+ 3 4))    (myeval '(+ 2 (+ 3 4)) nil #'err #'ok)))
(assert (equal (+ 2 (+ 3 4) 5)  (myeval '(+ 2 (+ 3 4) 5) nil #'err #'ok)))
;; Тесты для умножения
(assert (equal 1                (myeval '(*) nil #'err #'ok)))
(assert (equal (* 2)            (myeval '(* 2) nil #'err #'ok)))
(assert (equal (* 2 3)          (myeval '(* 2 3) nil #'err #'ok)))
(assert (equal (* 2 3 4)        (myeval '(* 2 3 4) nil #'err #'ok)))
(assert (equal (* 2 (* 3 4))    (myeval '(* 2 (* 3 4)) nil #'err #'ok)))
(assert (equal (* 2 (* 3 4) 5)  (myeval '(* 2 (* 3 4) 5) nil #'err #'ok)))
;; Тесты для сложения в окружении
(assert (equal 0
               (myeval '(+) nil #'err #'ok)))
(assert (equal (let ((a 2))
                 (+ a))
               (myeval '(+ a)
                       '((a . 2))
                       #'err #'ok)))
(assert (equal (let ((a 2) (b 3))
                 (+ a b))
               (myeval '(+ a b)
                       '((a . 2) (b . 3))
                       #'err #'ok)))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (+ a b c))
               (myeval '(+ a b c)
                       '((a . 2) (b . 3) (c . 4))
                       #'err #'ok)))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (+ a (+ b c)))
               (myeval '(+ a (+ b c))
                       '((a . 2) (b . 3) (c . 4))
                       #'err #'ok)))
(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))
                       #'err #'ok)))
;; Тесты для умножения  в окружении
(assert (equal 1
               (myeval '(*) nil #'err #'ok)))
(assert (equal (let ((a 2))
                 (* a))
               (myeval '(* a)
                       '((a . 2))
                       #'err #'ok)))
(assert (equal (let ((a 2) (b 3))
                 (* a b))
               (myeval '(* a b)
                       '((a . 2) (b . 3))
                       #'err #'ok)))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (* a b c))
               (myeval '(* a b c)
                       '((a . 2) (b . 3) (c . 4))
                       #'err #'ok)))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (* a (* b c)))
               (myeval '(* a (* b c))
                       '((a . 2) (b . 3) (c . 4))
                       #'err #'ok)))
(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))
                       #'err #'ok)))

CLOSURE

Добавляем продолжения

((closure-p fn)              (evprogn (closure-body fn)
                                      (pairlis (closure-args fn)
                                               args
                                               (closure-env fn))
                                      errcont
                                      cont))

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

;; Тесты для применения CLOSURE
(assert (equal 1 (myeval '(((lambda (x)
                              (lambda (y) x))
                            1)
                           2)
                         nil #'err #'ok)))

PRINT

PRINT - это функция, т.к. она оценивает свои аргументы. Перенесем print из myeval в myapply и научим его принимать продолжения:

((equal fn 'print)           (funcall cont (print (car args))))

Тесты такие-же, но теперь принимают продолжения

;; Тесты для PRINT в сравнении с host-овым print
(assert (equal (with-output-to-string (*standard-output*)
                 (print 12))
               (with-output-to-string (*standard-output*)
                 (myeval '(print 12) nil #'err #'identity))))
(assert (equal (print 12)
               (myeval '(print 12) nil #'err #'ok)))
;; Тесты для PRINT в окружении
(assert (equal (with-output-to-string (*standard-output*)
                 (let ((a 12))
                   (print a)))
               (with-output-to-string (*standard-output*)
                 (myeval '(print a)
                         '((b . 23) (a . 12))
                         #'err #'identity))))
(assert (equal (let ((a 12))
                 (print a))
               (myeval '(print a)
                       '((b . 23) (a . 12))
                       #'err #'ok)))

LIST

Как мы помним, в разделе Преобразование EVLIS и MYAPPLY мы получили новый evlis в CPS-стиле.

Здесь вызов:

((equal fn 'list)            (funcall cont args))

Теперь здесь мы напишем тесты для него:

;; Тест для EVLIS
(assert (equal 4           (evlis '+     '(1 (+ 1 2))             nil nil #'err #'ok)))
(assert (equal (+ 1 3 5)   (evlis '+     '(1 (+ 1 2) 5)           nil nil #'err #'ok)))
(assert (equal '(1 3 5)    (evlis 'list  '(1 (+ 1 2) 5)           nil nil #'err #'ok)))
(assert (equal '(0 3 6 42) (evlis 'list  '(0 (+ a b) (* b c) 42)
                                  nil
                                  '((a . 1) (b . 2) (c . 3) (d . 4))
                                  #'err #'ok)))

И тесты для LIST

;; Тесты для LIST
(assert (equal '(1 14) (myeval '(list 1 (+ 2 (* 3 4)))
                               nil #'err #'ok)))
(assert (equal '(3 6 42)
               (myeval '(list (+ 1 2) (* 2 3) 42) nil #'err #'ok)))
(assert (equal '(3 6 42)
               (myeval '(list (+ a b) (* b c) 42)
                       '((a . 1) (b . 2) (c . 3) (d . 4))
                       #'err #'ok)))

MyEval

Теперь myeval принимает два продолжения: errcont и cont и передает их при рекурсивном вызове внутри лямбды. Мы также переименовываем параметр lst в exp.

Это еще не все изменения. Изменяется хвостовая часть myeval, что подробно описано в разделе Преобразование EVLIS и MYEVAL

<<myeval_evcond_4>>
<<myeval_evprogn_4>>
<<myeval_evand_4>>
<<myeval_evor_4>>
<<myeval_mypairlis_4>>
<<myeval_evlet_4>>
<<myeval_evletstar_4>>
(defun myeval (exp env errcont cont)
  (cond
    <<myeval_number_4>>
    <<myeval_symb_4>>
    <<myeval_quote_4>>
    <<myeval_if_4>>
    <<myeval_cond_4>>
    <<myeval_progn_4>>
    ;; Тут был PRINT, но он перенесен в MYAPPLY
    ;; Тут был LIST, но он перенесен в MYAPPLY
    <<myeval_and_4>>
    <<myeval_or_4>>
    <<myeval_let_4>>
    <<myeval_letstar_4>>
    <<myeval_defun_4>>
    <<myeval_setq_4>>
    <<myeval_lambda_4>>
    (t
     (myeval (car exp) env errcont
             (lambda (x)
               (evlis  x  (cdr exp) nil env errcont cont))))))

Тесты:

<<myeval_number_4_test>>
<<myeval_symb_4_test>>
<<myeval_quote_4_test>>
<<myeval_if_4_test>>
<<myeval_evcond_4_test>>
<<myeval_cond_4_test>>
<<myeval_evprogn_4_test>>
<<myeval_progn_4_test>>
<<myeval_evand_4_test>>
<<myeval_and_4_test>>
<<myeval_evor_4_test>>
<<myeval_or_4_test>>
<<myeval_mypairlis_4_test>>
<<myeval_evlet_4_test>>
<<myeval_let_4_test>>
<<myeval_evletstar_4_test>>
<<myeval_letstar_4_test>>
<<myeval_defun_4_test>>
<<myeval_setq_4_test>>
<<myeval_lambda_4_test>>

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

Самовычисляемые формы теперь используют продолжения. Кроме того, мы добавляем print и list в самовычисляемые формы, потому что переноси их из myeval в myapply

((null exp)                  (funcall cont 'nil))
((equal t exp)               (funcall cont 't))
((member exp '(+ * car cdr cons null print list))  (funcall cont exp))
((numberp exp)               (funcall cont exp))

Тесты незначительно изменяются

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

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

…стало проще. Теперь вместо сигнализирования ошибки, когда символ не найден, lookup просто вызовет (другое) error-продолжение. Поэтому класс ошибки var-not-found-error нам больше не требуется.

((symbolp exp)               (lookup exp env errcont cont))

Соответственно изменился и тест - теперь мы ожидаем, что будет выполнено error-продолжение.

;; Тесты для вычисления символов
(assert (equal 6 (myeval 'b '((a . 3) (b . 6)) #'err #'ok)))
(assert (equal "error" (car (myeval 'b nil
                                    #'(lambda (x) (cons "error" x))
                                    #'ok))))

Цитирование

теперь вызывает продолжение

((equal (car exp) 'quote)    (funcall cont (cadr exp)))
;; Тесты для QUOTE
(assert (equal '(+ 1 2) (myeval '(quote (+ 1 2)) nil #'err #'ok)))

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

Чтобы сделать IF в CPS-стиле мы вызываем myeval, чтобы вычислить значение выражения-условия. При этом мы передаем в параметр cont лямбду, которая в зависимости от значения вычисления вызовет ту или иную ветку:

((equal (car exp) 'if)       (myeval (cadr exp) env errcont
                                     (lambda (x)
                                       (if x
                                           (myeval (caddr exp)  env errcont cont)
                                           (myeval (cadddr exp) env errcont cont)))))
;; Тесты для IF
(assert (equal 2 (myeval '(if () 1 2) nil #'err #'ok)))
(assert (equal 1 (myeval '(if (null ()) 1 2) nil #'err #'ok)))
;; Тесты для IF, где условие вычисляется в окружении
(assert (equal 2 (myeval '(if a 1 2) '((a . ())) #'err #'ok)))
(assert (equal 1 (myeval '(if a 1 2) '((a . 1)) #'err #'ok)))

COND

Модифицируем evcond в CPS-стиле. Это примерно то же самое, что и IF в CPS-стиле, с той особенность, что если вычисление условия не вернуло T, то мы рекурсивно вычисляем от остатка переданного списка условий. Мы так делали и раньше в evcond, просто тут рекурсия перехала в продолжения.

(defun evcond (exp env errcont cont)
  (cond ((null exp)  (funcall cont nil))
        (t           (myeval (caar exp) env errcont
                             (lambda (x)
                               (if x
                                   (myeval (cadar exp) env errcont cont)
                                   (evcond (cdr exp)   env errcont cont)))))))
;; Тесты для EVCOND
(assert (equal 2   (evcond '((t 2)   (t 1)) nil #'err #'ok)))
(assert (equal 1   (evcond '((nil 2) (t 1)) nil #'err #'ok)))
(assert (equal nil (evcond '((nil 2) (nil 1)) nil #'err #'ok)))
;; Тесты для EVCOND, где участвует окружение
(assert (equal 2 (evcond '((a 2) (b 1))
                         '((a . 1) (b . ()))
                         #'err #'ok)))
(assert (equal 1 (evcond '((a 2) (b 1))
                         '((a . nil) (b . T))
                         #'err #'ok)))

и адаптируем вызов внутри myeval:

((equal (car exp) 'cond)     (evcond (cdr exp) env errcont cont))
;; Тесты для COND
(assert (equal 2 (myeval '(cond
                           (() 1)
                           (1 2))
                         nil #'err #'ok)))
(assert (equal 2 (myeval '(cond
                           (a 1)
                           (b 2))
                         '((a . ()) (b . 1))
                         #'err #'ok)))
(assert (equal 1 (myeval '(cond
                           (a 1)
                           (b 2))
                         '((a . 1) (b . ()))
                         #'err #'ok)))

PROGN

Аналогичным образом преобразуем evprogn в CPS.

(defun evprogn (lst env errcont cont)
  (cond ((null lst)         (funcall cont nil))
        ((null (cdr lst))   (myeval (car lst) env errcont cont))
        (t                  (myeval (car lst) env errcont
                                    (lambda (x)
                                      (evprogn (cdr lst) env errcont cont))))))
;; Тест для EVPROGN
(assert (equal 2 (evprogn '(1 2) nil  #'err #'ok)))
;; Тест для EVPROGN в окружении
(assert (equal 3 (evprogn '(a b c)
                          '((a . 1) (b . 2) (c . 3))
                          #'err #'ok)))

модифицируем вызов в myeval:

((equal (car exp) 'progn)    (evprogn (cdr exp) env errcont cont))
;; Тест для PROGN
(assert (equal 3 (myeval '(progn 1 2 3) nil #'err #'ok)))
;; Тест для PROGN в окружении
(assert (equal 3 (myeval '(progn a b c) '((a . 1) (b . 2) (c . 3)) #'err #'ok)))

CANCEL PRINT

PRINT - это функция, поэтому она должна обрабатываться в MYAPPLY. Туда мы ее и перенесли.

CANCEL LIST

LIST - это функция, т.к. она оценивает свои аргументы. Поэтому мы переносим ее в MYAPPLY.

AND

Выполняем CPS-преобразование (очень похоже на EVCOND)

(defun evand (args env errcont cont)
  (cond ((null args)        (funcall cont T))
        ((null (cdr args))  (myeval (car args) env errcont cont))
        (t                  (myeval (car args) env errcont
                                    (lambda (x)
                                      (if (null x)
                                          (funcall cont nil)
                                          (evand (cdr args) env errcont cont)))))))
;; Тесты для EVAND
(assert (equal (and)           (evand '() nil #'err #'ok)))
(assert (equal (and 1)         (evand '(1) nil #'err #'ok)))
(assert (equal (and nil)       (evand '(nil) nil #'err #'ok)))
(assert (equal (and 1 nil)     (evand '(1 nil) nil #'err #'ok)))
(assert (equal (and 1 2 nil)   (evand '(1 2 nil) nil #'err #'ok)))
(assert (equal (and 1 2 3)     (evand '(1 2 3) nil #'err #'ok)))
(assert (equal (and 1 2 nil 3) (evand '(1 2 nil 3) nil #'err #'ok)))
;; Тесты для EVAND в окружении
(assert (equal (let ((a nil))
                 (and nil))
               (evand '(a) '((a . nil)) #'err #'ok)))
(assert (equal (let ((a 1))
                 (and a))
               (evand '(a) '((a . 1)) #'err #'ok)))
(assert (equal (let ((a 1)
                     (b nil))
                 (and a b))
               (evand '(a b) '((a . 1) (b . nil)) #'err #'ok)))
(assert (equal (let ((a 1)
                     (b 2)
                     (c nil))
                 (and a b c))
               (evand '(a b c) '((a . 1) (b . 2) (c . nil)) #'err #'ok)))
(assert (equal (let ((a 1)
                     (b 2)
                     (c 3))
                 (and a b c))
               (evand '(a b c) '((a . 1) (b . 2) (c . 3)) #'err #'ok)))
(assert (equal (let ((a 1)
                     (b 2)
                     (c nil)
                     (d 3))
                 (and a b c d))
               (evand '(a b c) '((a . 1) (b . 2) (c . nil) (d . 3)) #'err #'ok)))
((equal (car exp) 'and)      (evand (cdr exp) env errcont cont))
;; Тесты для AND
(assert (equal (and)                  (myeval '(and) nil #'err #'ok)))
(assert (equal (and 1)                (myeval '(and 1) nil #'err #'ok)))
(assert (equal (and nil)              (myeval '(and nil) nil #'err #'ok)))
(assert (equal (and 1 nil)            (myeval '(and 1 nil) nil #'err #'ok)))
(assert (equal (and 1 2 nil)          (myeval '(and 1 2 nil) nil #'err #'ok)))
(assert (equal (and 1 2 3)            (myeval '(and 1 2 3) nil #'err #'ok)))
(assert (equal (and 1 (and 1 2) 3)    (myeval '(and 1 (and 1 2) 3) nil #'err #'ok)))
(assert (equal (and 1 (and 1 nil) 3)  (myeval '(and 1 (and 1 nil) 3) nil #'err #'ok)))
;; Тесты для AND в окружении
(assert (equal (let ((a nil))
                 (and nil))
               (myeval '(and a) '((a . nil)) #'err #'ok)))
(assert (equal (let ((a 1))
                 (and a))
               (myeval '(and a) '((a . 1)) #'err #'ok)))
(assert (equal (let ((a 1)
                     (b nil))
                 (and a b))
               (myeval '(and a b) '((a . 1) (b . nil)) #'err #'ok)))
(assert (equal (let ((a 1)
                     (b 2)
                     (c nil))
                 (and a b c))
               (myeval '(and a b c) '((a . 1) (b . 2) (c . nil)) #'err #'ok)))
(assert (equal (let ((a 1)
                     (b 2)
                     (c 3))
                 (and a b c))
               (myeval '(and a b c) '((a . 1) (b . 2) (c . 3)) #'err #'ok)))
(assert (equal (let ((a 1)
                     (b 2)
                     (c nil)
                     (d 3))
                 (and a b c d))
               (myeval '(and a b c) '((a . 1) (b . 2) (c . nil) (d . 3)) #'err #'ok)))
(assert (equal (let ((a 1)
                     (b 2)
                     (c 3))
                 (and a (and a b) c))
               (myeval '(and a (and a b) c) '((a . 1) (b . 2) (c . 3)) #'err #'ok)))
(assert (equal (let ((a 1)
                     (b nil)
                     (c 3))
                 (and a (and a b) c))
               (myeval '(and a (and a b) c) '((a . 1) (b . nil) (c . 3)) #'err #'ok)))

OR

Выполняем CPS-преобразование (очень похоже на EVCOND)

(defun evor (args env errcont cont)
  (cond ((null args)        (funcall cont nil))
        ((null (cdr args))  (myeval (car args) env errcont cont))
        (t                  (myeval (car args) env errcont
                                    (lambda (x)
                                      (if (not (null x))
                                          (funcall cont x)
                                          (evor (cdr args) env errcont cont)))))))
;; Тесты для EVOR
(assert (equal (or)                   (evor '() nil #'err #'ok)))
(assert (equal (or nil 1)             (evor '(nil 1) nil #'err #'ok)))
(assert (equal (or nil nil 1)         (evor '(nil nil 1) nil #'err #'ok)))
(assert (equal (or nil 1 2)           (evor '(nil 1 2) nil #'err #'ok)))
(assert (equal (or 1 2 3)             (evor '(1 2 3) nil #'err #'ok)))
(assert (equal (or nil nil 3 nil)     (evor '(nil nil 3 nil) nil #'err #'ok)))
;; Тесты для EVOR в окружении
(assert (equal (let ((a nil))
                 (or a))
               (evor '(a) '((a . nil)) #'err #'ok)))
(assert (equal (let ((a 1))
                 (or a))
               (evor '(a) '((a . 1)) #'err #'ok)))
(assert (equal (let ((a nil)
                     (b 1))
                 (or a b))
               (evor '(a b) '((a . nil) (b . 1)) #'err #'ok)))
(assert (equal (let ((a nil)
                     (b nil)
                     (c 3))
                 (or a b c))
               (evor '(a b c) '((a . nil) (b . nil) (c . 3)) #'err #'ok)))
(assert (equal (let ((a nil)
                     (b 1)
                     (c 2))
                 (or a b c))
               (evor '(a b c) '((a . nil) (b . 1) (c . 2)) #'err #'ok)))
(assert (equal (let ((a nil)
                     (b nil)
                     (c 3)
                     (d nil))
                 (or a b c d))
               (evor '(a b c d) '((a . nil) (b . nil) (c . 3) (d . nil)) #'err #'ok)))

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

((equal (car exp) 'or)       (evor  (cdr exp) env errcont cont))

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

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

LET

Ошибка mypairlis-error нам все еще нужна

(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)))))

Функция mypairlis остается без изменений

(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"))))

Теперь нам понадобится новая функция evlet. Она рекурсивно вычисляет exps перебрасывая вычисленные результаты в evald-exps и по окончании этого процесса вызывает evprogn чтобы вычислить тело let в объединенном окружении.

(defun evlet (vars exps evald-exps exp env errcont cont)
  (cond ((null exps)  (evprogn exp
                               (pairlis vars (reverse evald-exps) env)
                               errcont cont))
        (t            (myeval (car exps) env errcont
                              (lambda (x)
                                (evlet vars (cdr exps) (cons x evald-exps) exp env errcont cont))))))
;; Тесты для EVLET
(assert (equal 3 (evlet '(a b) '(1 2) nil '(4 (+ a b)) nil #'err #'ok)))

используем evlet в myeval чтобы вычислить let

((equal (car exp) 'let)      (evlet (mapcar #'car (cadr exp))
                                    (mapcar #'cadr (cadr exp))
                                    nil
                                    (cddr exp)
                                    env
                                    errcont
                                    cont))

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

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

LET*

cps

(defun evletstar (varpairs exp env errcont cont)
  (cond ((null varpairs)  (evprogn exp env errcont cont))
        (t                (myeval (cadar varpairs) env errcont
                                  (lambda (x)
                                    (evletstar (cdr varpairs) exp
                                               (acons (caar varpairs) x env)
                                               errcont cont))))))
;; Тесты для EVLETSTAR
(assert (equal 2 (evletstar '((a 1) (b a)) '(4 (+ a b)) nil  #'err #'ok)))

cps

((equal (car exp) 'let*)     (evletstar (cadr exp)
                                        (cddr exp)
                                        env
                                        errcont cont))
;; Тесты для LET*
(assert (equal '(3 1 . 2) (myeval '(let* ((a 1)
                                          (b 2)
                                          (c (+ a b)))
                                    (cons c (cons a b)))
                                  nil #'err #'ok)))

DEFUN

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

((equal (car exp) 'defun)         (progn
                                    (push (cons (cadr exp)
                                                (make-closure :body (cdddr exp)
                                                              :env env
                                                              :args (caddr exp)))
                                          *glob-env*)
                                    (funcall cont (cadr exp))))

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

;; Тесты для DEFUN
(assert (equal 64 (progn
                    (setf *glob-env* nil)
                    (myeval '(defun alfa (x) (* x x)) nil #'err #'ok)
                    (prog1 (myeval '(alfa 8) nil #'err #'ok)
                      (setf *glob-env* nil)))))
;; Тесты на IMPLICIT-PROGN в DEFUN
(assert (equal 384 (progn
                     (setf *glob-env* nil)
                     (myeval '(let ((y 3))
                               (defun alfa (x)
                                 (setq y 6)
                                 (* x x y)))
                             nil #'err #'ok)
                     (prog1 (myeval '(alfa 8) nil #'err #'ok)
                       (setf *glob-env* nil)))))

SETQ

lookup у нас не может вернуть пару (переменная . значение), а нам эта пара нужна чтобы изменить значение переменной. Поэтому здесь мы обходимся без lookup, напрямую отрабатывая все его инварианты

((equal (car exp) 'setq)     (myeval (caddr exp) env errcont
                                     (lambda (val)
                                       (if (null (assoc (cadr exp) env))
                                           ;; переменная не найдена в текущем окружении
                                           ;; - посмотрим в глобальном
                                           (if (null (assoc (cadr exp) *glob-env*))
                                               ;; переменная не найдена в глобальном
                                               ;; окружении - создадим ее в глобальном
                                               ;; окружении
                                               (push (cons (cadr exp) val)
                                                     *glob-env*)
                                               ;; переменная найдена в глобальном
                                               ;; окружении - изменим ее значение
                                               (rplacd (assoc (cadr exp) *glob-env*) val))
                                           ;; переменная найдена в текущем окружении
                                           ;; - изменить ее значение
                                           (rplacd (assoc (cadr exp) env) val))
                                       ;; В любом случае возвращаем значение переменной
                                       (funcall cont val))))
;; Тесты для SETQ
;; Проверка изменения значения локальной переменной, не затрагивая глобального окружения
(assert (equal '((2 . 2) ((alfa . 0)))
               (progn
                 (setf *glob-env* '((alfa . 0)))
                 (prog1 (list (myeval '(cons (setq alfa 2)
                                        alfa)
                                      '((alfa . 1))
                                      #'err #'ok)
                              *glob-env*)
                   (setf *glob-env* nil)))))
;; Изменение значения несуществующей переменной (создание глобальной переменной)
(assert (equal '((1 . 1) ((ALFA . 1) (BETA . 222)))
               (progn
                 (setf *glob-env* '((beta . 222)))
                 (prog1 (list (myeval '(cons
                                        (setq alfa 1)
                                        alfa)
                                      nil #'err #'ok)
                              *glob-env*)
                   (setf *glob-env* nil)))))
;; Изменение значения существующей глобальной переменной
(assert (equal '((1 . 1) ((BETA . 1)))
               (progn
                 (setf *glob-env* '((beta . 222)))
                 (prog1 (list (myeval '(cons
                                        (setq beta 1)
                                        beta)
                                      nil #'err #'ok)
                              *glob-env*)
                   (setf *glob-env* nil)))))

LAMBDA

При обработке формы, начинающейся с вызова lambda мы все также создаем замыкание, чтобы сохранить то окружение, которое было в момент создания лямбды. Но теперь мы делаем это в CPS-стиле.

((equal (car exp) 'lambda)   (funcall cont (make-closure :body (cddr exp)
                                                         :env env
                                                         :args (cadr exp))))
;; Тесты для LAMBDA
(assert (equal 3 (myeval '((lambda (x) (+ 1  x)) 2)
                         nil #'err #'ok)))
;; Тесты для LAMBDA в окружении
(assert (equal 5 (myeval '(let ((y 3))
                           ((lambda (x) (+ y x)) 2))
                         nil #'err #'ok)))
;; Тесты на IMPLICIT-PROGN в LAMBDA
(assert (equal 8 (myeval '(let ((y 3))
                           ((lambda (x)
                              (setq y 6)
                              (+ y x)) 2))
                         nil #'err #'ok)))

REPL

(defun repl ()
    (princ "microlisp>")
    (finish-output)
    (princ (myeval (read) nil #'identity #'identity))
    (terpri)
    (finish-output)
    (repl))

Итоги

;; CPS-версия ASSOC
<<assoc_4>>
;; Классы ошибок
<<errors_4>>
;; Новая функция lookup
<<lookup_4>>
;; Структура замыкания
<<closure_4>>
;; CPS-вариант MYAPPLY и все что к нему относится
<<myapply_4>>
;; CPS-вариант MYEVAL и все что к нему относится
<<myeval_4>>
;; Тестируем новый lookup
<<lookup_4_test>>
;; Функции для тестирования CPS-функций
<<ok_err_4>>
;; Тесты для MYAPPLY
<<myapply_4_test>>
;; Тесты для MYEVAL
<<myeval_4_test>>
;; REPL
<<repl_4>>
;; (repl)

Получиться должен вот такой результат:

;; CPS-версия ASSOC
(defun assoc-2 (key alist cont errcont) ;; NB!: inverted order of
  ;; continuations (for lookup)
  (cond ((null alist)              (funcall errcont key))
        ((equal key (caar alist))  (funcall cont    (cdar alist)))
        (t                         (assoc-2 key (cdr alist) cont errcont))))
;; Классы ошибок
(define-condition unknown-function (error)
  ((fn :initarg :fn  :reader fn))
  (:report
   (lambda (condition stream)
     (format stream "Error in MYAPPLY: unknown-function: ~A"
             (fn condition)))))
(define-condition invalid-number-of-arguments (error)
  ((fn :initarg :fn  :reader fn))
  (:report
   (lambda (condition stream)
     (format stream "Error in MYAPPLY: invalid-number-of-arguments: ~A"
             (fn condition)))))
(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)))))
;; Новая функция lookup
;; environment
(defparameter *glob-env* nil)
;; lookup
(defun lookup (symb env errcont cont)
  (assoc-2 symb env cont
           (lambda (key)
             (assoc-2 key *glob-env* cont
                      (lambda (key)
                        (funcall errcont
                                 (format
                                  nil
                                  "UNBOUD VARIABLE [~A] ~%LOCAL ENV: [~A] ~%GLOBAL ENV: [~A]"
                                  key env *glob-env*)))))))
;; Структура замыкания
(defstruct closure
  body
  env
  args)
;; CPS-вариант MYAPPLY и все что к нему относится
(defun evadd (lst acc)
  (cond ((null lst)        0)
        ((null (cdr lst))  (+ acc (car lst)))
        (t                 (evadd (cdr lst)
                                  (+ acc (car lst))))))
(defun evmul (lst acc)
  (cond ((null lst)        1)
        ((null (cdr lst))  (* acc (car lst)))
        (t                 (evmul (cdr lst)
                                  (* acc (car lst))))))
;; менее эффективный но более понятный вариант evlis
(defun evlis (fn unevaled evaled env errcont cont)
  (cond ((null unevaled)  (myapply fn evaled errcont cont))
        (t                (myeval (car unevaled) env errcont
                                  (lambda (x)
                                    (evlis fn
                                           (cdr unevaled)
                                           (append evaled (list x))
                                           env errcont cont))))))
;; более эффективный вариант evlis
(defun evlis (fn unevaled evaled env errcont cont)
  (cond ((null unevaled)  (myapply fn (reverse evaled) errcont cont))
        (t                (myeval (car unevaled) env errcont
                                  (lambda (x)
                                    (evlis fn
                                           (cdr unevaled)
                                           (cons x evaled)
                                           env errcont cont))))))
(defun myapply (fn args errcont cont)
  (cond
    ((equal fn 'car)             (funcall cont (caar args)))
    ((equal fn 'cdr)             (funcall cont (cdar args)))
    ((equal fn 'cons)            (funcall cont (cons (car args) (cadr args))))
    ((equal fn 'null)            (if (null (cdr args))
                                     (funcall cont (null (car args)))
                                     (error 'invalid-number-of-arguments :fn fn)))
    ((equal fn '+)               (funcall cont (evadd args 0)))
    ((equal fn '*)               (funcall cont (evmul args 1)))
    ((closure-p fn)              (myeval (closure-body fn)
                                         (pairlis (closure-args fn)
                                                  args
                                                  (closure-env fn))
                                         errcont
                                         cont))
    ((equal fn 'print)           (funcall cont (print (car args))))
    ((equal fn 'list)            (funcall cont args))
    (t (error 'unknown-function :fn fn))))
;; CPS-вариант MYEVAL и все что к нему относится
(defun evcond (exp env errcont cont)
  (cond ((null exp)  (funcall cont nil))
        (t           (myeval (caar exp) env errcont
                             (lambda (x)
                               (if x
                                   (myeval (cadar exp) env errcont cont)
                                   (evcond (cdr exp)   env errcont cont)))))))
(defun evprogn (lst env errcont cont)
  (cond ((null lst)         (funcall cont nil))
        ((null (cdr lst))   (myeval (car lst) env errcont cont))
        (t                  (myeval (car lst) env errcont
                                    (lambda (x)
                                      (evprogn (cdr lst) env errcont cont))))))
(defun evand (lst env errcont cont)
  (cond ((null lst)        (funcall cont (and)))
        ((null (cdr lst))  (myeval (car lst) env errcont
                                   (lambda (x)
                                     (funcall cont
                                              (and x)))))
        (t                 (myeval (car lst) env errcont
                                   (lambda (x)
                                     (funcall cont
                                              (and x
                                                   (evand (cdr lst) env errcont cont))))))))
(defun evor (lst env errcont cont)
  (cond ((null lst)        (funcall cont (or)))
        ((null (cdr lst))  (myeval (car lst) env errcont
                                   (lambda (x)
                                     (funcall cont
                                              (or x)))))
        (t                 (myeval (car lst) env errcont
                                   (lambda (x)
                                     (funcall cont
                                              (or x
                                                  (evor (cdr lst) env errcont cont))))))))
(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 evlet (vars exps evald-exps exp env errcont cont)
  (cond ((null exps)  (evprogn exp
                               (pairlis vars (reverse evald-exps) env)
                               errcont cont))
        (t            (myeval (car exps) env errcont
                              (lambda (x)
                                (evlet vars (cdr exps) (cons x evald-exps) exp env errcont cont))))))
(defun evletstar (varpairs exp env errcont cont)
  (cond ((null varpairs)  (evprogn exp env errcont cont))
        (t                (myeval (cadar varpairs) env errcont
                                  (lambda (x)
                                    (evletstar (cdr varpairs) exp
                                               (acons (caar varpairs) x env)
                                               errcont cont))))))
(defun myeval (exp env errcont cont)
  (cond
    ((null exp)                  (funcall cont 'nil))
    ((equal t exp)               (funcall cont 't))
    ((member exp '(+ * car cdr cons null print list))  (funcall cont exp))
    ((numberp exp)               (funcall cont exp))
    ((symbolp exp)               (lookup exp env errcont cont))
    ((equal (car exp) 'quote)    (funcall cont (cadr exp)))
    ((equal (car exp) 'if)       (myeval (cadr exp) env errcont
                                         (lambda (x)
                                           (if x
                                               (myeval (caddr exp)  env errcont cont)
                                               (myeval (cadddr exp) env errcont cont)))))
    ((equal (car exp) 'cond)     (evcond (cdr exp) env errcont cont))
    ((equal (car exp) 'progn)    (evprogn (cdr exp) env errcont cont))
    ;; Тут был PRINT, но он перенесен в MYAPPLY
    ;; Тут был LIST, но он перенесен в MYAPPLY
    ((equal (car exp) 'and)      (evand (cdr exp) env errcont cont))
    ((equal (car exp) 'or)       (evor  (cdr exp) env errcont cont))
    ((equal (car exp) 'let)      (evlet (mapcar #'car (cadr exp))
                                        (mapcar #'cadr (cadr exp))
                                        nil
                                        (cddr exp)
                                        env
                                        errcont
                                        cont))
    ((equal (car exp) 'let*)     (evletstar (cadr exp)
                                            (cddr exp)
                                            env
                                            errcont cont))
    ((equal (car exp) 'defun)         (progn
                                        (push (cons (cadr exp)
                                                    (make-closure :body (cadddr exp)
                                                                  :env env
                                                                  :args (caddr exp)))
                                              *glob-env*)
                                        (funcall cont (cadr exp))))
    ((equal (car exp) 'setq)     (myeval (caddr exp) env errcont
                                         (lambda (val)
                                           (if (null (assoc (cadr exp) env))
                                               ;; переменная не найдена в текущем окружении
                                               ;; - посмотрим в глобальном
                                               (if (null (assoc (cadr exp) *glob-env*))
                                                   ;; переменная не найдена в глобальном
                                                   ;; окружении - создадим ее в глобальном
                                                   ;; окружении
                                                   (push (cons (cadr exp) val)
                                                         *glob-env*)
                                                   ;; переменная найдена в глобальном
                                                   ;; окружении - изменим ее значение
                                                   (rplacd (assoc (cadr exp) *glob-env*) val))
                                               ;; переменная найдена в текущем окружении
                                               ;; - изменить ее значение
                                               (rplacd (assoc (cadr exp) env) val))
                                           ;; В любом случае возвращаем значение переменной
                                           (funcall cont val))))
    ((equal (car exp) 'lambda)   (funcall cont (make-closure :body (caddr exp)
                                                             :env env
                                                             :args (cadr exp))))
    (t
     (myeval (car exp) env errcont
             (lambda (x)
               (evlis  x  (cdr exp) nil env errcont cont))))))
;; Тестируем новый lookup
;; test lookup
(assert (equal "ok:123" (lookup 'aaa '((aaa . 123))
                                (lambda (x) (format nil "err:~A" x))
                                (lambda (x) (format nil "ok:~A" x)))))
(assert (equal nil      (lookup 'aaa '((bbb . 123))
                                (lambda (x) (declare (ignore x)) nil)
                                (lambda (x) (format nil "ok:~A" x)))))
;; Функции для тестирования CPS-функций
(defun ok (x)
  (format t "~%ok: ~A" x)
  x)
(defun err (x)
  (format t "~%err: ~A" x)
  x)
;; Тесты для MYAPPLY
;; Тесты cons, car, cdr
(assert (equal '(1 . 2) (myeval '(cons 1 2) nil #'err #'ok)))
(assert (equal '((1 . 2) 3 . 4) (myeval '(cons (cons 1 2) (cons 3 4)) nil #'err #'ok)))
(assert (equal 2 (myeval '(car (cons 2 3)) nil #'err #'ok)))
(assert (equal 3 (myeval '(cdr (cons 2 3)) nil #'err #'ok)))
(assert (equal '(1 . 2) (myeval '(car (cons (cons 1 2) (cons 3 4))) nil #'err #'ok)))
(assert (equal '(3 . 4) (myeval '(cdr (cons (cons 1 2) (cons 3 4))) nil #'err #'ok)))
;; Тесты для cons-ячеек, вычисляемых в окружении
(assert (equal 1 (myeval '(car a) '((a . (1 . 2))) #'err #'ok)))
(assert (equal 2 (myeval '(cdr a) '((a . (1 . 2))) #'err #'ok)))
(assert (equal 3 (myeval '(car b) '((a . (1 . 2)) (b . (3 . 4))) #'err #'ok)))
;; Тесты для NULL
(assert (equal T (myeval '(null ()) nil #'err #'ok)))
(assert (equal T (myeval '(null nil) nil #'err #'ok)))
(assert (equal NIL (myeval '(null T) nil #'err #'ok)))
(assert (equal T (myeval '(null a) '((a . ())) #'err #'ok)))
;; Тесты для NULL, с аргументом, вычисляемые в окружении
(assert (equal NIL (myeval '(null a) '((a . T)) #'err #'ok)))
(assert (equal NIL (myeval '(null a) '((a . 1)) #'err #'ok)))
;; Тесты для EVADD
(assert (equal 0                (evadd '() 0)))
(assert (equal 2                (evadd '(2) 0)))
(assert (equal 5                (evadd '(2 3) 0)))
(assert (equal (+ 2 3 4)        (evadd '(2 3 4) 0)))
;; Тесты для EVMUL
(assert (equal 1                (evmul '() 1)))
(assert (equal 2                (evmul '(2) 1)))
(assert (equal 6                (evmul '(2 3) 1)))
(assert (equal (* 2 3 4)        (evmul '(2 3 4) 1)))
;; Тесты для сложения
(assert (equal 0                (myeval '(+) nil #'err #'ok)))
(assert (equal (+ 2)            (myeval '(+ 2) nil #'err #'ok)))
(assert (equal (+ 2 3)          (myeval '(+ 2 3) nil #'err #'ok)))
(assert (equal (+ 2 3 4)        (myeval '(+ 2 3 4) nil #'err #'ok)))
(assert (equal (+ 2 (+ 3 4))    (myeval '(+ 2 (+ 3 4)) nil #'err #'ok)))
(assert (equal (+ 2 (+ 3 4) 5)  (myeval '(+ 2 (+ 3 4) 5) nil #'err #'ok)))
;; Тесты для умножения
(assert (equal 1                (myeval '(*) nil #'err #'ok)))
(assert (equal (* 2)            (myeval '(* 2) nil #'err #'ok)))
(assert (equal (* 2 3)          (myeval '(* 2 3) nil #'err #'ok)))
(assert (equal (* 2 3 4)        (myeval '(* 2 3 4) nil #'err #'ok)))
(assert (equal (* 2 (* 3 4))    (myeval '(* 2 (* 3 4)) nil #'err #'ok)))
(assert (equal (* 2 (* 3 4) 5)  (myeval '(* 2 (* 3 4) 5) nil #'err #'ok)))
;; Тесты для сложения в окружении
(assert (equal 0
               (myeval '(+) nil #'err #'ok)))
(assert (equal (let ((a 2))
                 (+ a))
               (myeval '(+ a)
                       '((a . 2))
                       #'err #'ok)))
(assert (equal (let ((a 2) (b 3))
                 (+ a b))
               (myeval '(+ a b)
                       '((a . 2) (b . 3))
                       #'err #'ok)))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (+ a b c))
               (myeval '(+ a b c)
                       '((a . 2) (b . 3) (c . 4))
                       #'err #'ok)))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (+ a (+ b c)))
               (myeval '(+ a (+ b c))
                       '((a . 2) (b . 3) (c . 4))
                       #'err #'ok)))
(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))
                       #'err #'ok)))
;; Тесты для умножения  в окружении
(assert (equal 1
               (myeval '(*) nil #'err #'ok)))
(assert (equal (let ((a 2))
                 (* a))
               (myeval '(* a)
                       '((a . 2))
                       #'err #'ok)))
(assert (equal (let ((a 2) (b 3))
                 (* a b))
               (myeval '(* a b)
                       '((a . 2) (b . 3))
                       #'err #'ok)))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (* a b c))
               (myeval '(* a b c)
                       '((a . 2) (b . 3) (c . 4))
                       #'err #'ok)))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (* a (* b c)))
               (myeval '(* a (* b c))
                       '((a . 2) (b . 3) (c . 4))
                       #'err #'ok)))
(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))
                       #'err #'ok)))
;; Тесты для применения CLOSURE
(assert (equal 1 (myeval '(((lambda (x)
                              (lambda (y) x))
                            1)
                           2)
                         nil #'err #'ok)))
;; Тесты для PRINT в сравнении с host-овым print
(assert (equal (with-output-to-string (*standard-output*)
                 (print 12))
               (with-output-to-string (*standard-output*)
                 (myeval '(print 12) nil #'err #'identity))))
(assert (equal (print 12)
               (myeval '(print 12) nil #'err #'ok)))
;; Тесты для PRINT в окружении
(assert (equal (with-output-to-string (*standard-output*)
                 (let ((a 12))
                   (print a)))
               (with-output-to-string (*standard-output*)
                 (myeval '(print a)
                         '((b . 23) (a . 12))
                         #'err #'identity))))
(assert (equal (let ((a 12))
                 (print a))
               (myeval '(print a)
                       '((b . 23) (a . 12))
                       #'err #'ok)))
;; Тест для EVLIS
(assert (equal 4           (evlis '+     '(1 (+ 1 2))             nil nil #'err #'ok)))
(assert (equal (+ 1 3 5)   (evlis '+     '(1 (+ 1 2) 5)           nil nil #'err #'ok)))
(assert (equal '(1 3 5)    (evlis 'list  '(1 (+ 1 2) 5)           nil nil #'err #'ok)))
(assert (equal '(0 3 6 42) (evlis 'list  '(0 (+ a b) (* b c) 42)
                                  nil
                                  '((a . 1) (b . 2) (c . 3) (d . 4))
                                  #'err #'ok)))
;; Тесты для LIST
(assert (equal '(1 14) (myeval '(list 1 (+ 2 (* 3 4)))
                               nil #'err #'ok)))
(assert (equal '(3 6 42)
               (myeval '(list (+ 1 2) (* 2 3) 42) nil #'err #'ok)))
(assert (equal '(3 6 42)
               (myeval '(list (+ a b) (* b c) 42)
                       '((a . 1) (b . 2) (c . 3) (d . 4))
                       #'err #'ok)))
;; Тесты для MYEVAL
;; Тесты для самовычисляемых форм
(assert (equal T (myeval 'T nil #'err #'ok)))
(assert (equal NIL (myeval 'NIL nil #'err #'ok)))
(assert (equal 999 (myeval 999 nil #'err #'ok)))
;; Тесты для вычисления символов
(assert (equal 6 (myeval 'b '((a . 3) (b . 6)) #'err #'ok)))
(assert (equal "error" (car (myeval 'b nil
                                    #'(lambda (x) (cons "error" x))
                                    #'ok))))
;; Тесты для QUOTE
(assert (equal '(+ 1 2) (myeval '(quote (+ 1 2)) nil #'err #'ok)))
;; Тесты для IF
(assert (equal 2 (myeval '(if () 1 2) nil #'err #'ok)))
(assert (equal 1 (myeval '(if (null ()) 1 2) nil #'err #'ok)))
;; Тесты для IF, где условие вычисляется в окружении
(assert (equal 2 (myeval '(if a 1 2) '((a . ())) #'err #'ok)))
(assert (equal 1 (myeval '(if a 1 2) '((a . 1)) #'err #'ok)))
;; Тесты для EVCOND
(assert (equal 2   (evcond '((t 2)   (t 1)) nil #'err #'ok)))
(assert (equal 1   (evcond '((nil 2) (t 1)) nil #'err #'ok)))
(assert (equal nil (evcond '((nil 2) (nil 1)) nil #'err #'ok)))
;; Тесты для EVCOND, где участвует окружение
(assert (equal 2 (evcond '((a 2) (b 1))
                         '((a . 1) (b . ()))
                         #'err #'ok)))
(assert (equal 1 (evcond '((a 2) (b 1))
                         '((a . nil) (b . T))
                         #'err #'ok)))
;; Тесты для COND
(assert (equal 2 (myeval '(cond
                           (() 1)
                           (1 2))
                         nil #'err #'ok)))
(assert (equal 2 (myeval '(cond
                           (a 1)
                           (b 2))
                         '((a . ()) (b . 1))
                         #'err #'ok)))
(assert (equal 1 (myeval '(cond
                           (a 1)
                           (b 2))
                         '((a . 1) (b . ()))
                         #'err #'ok)))
;; Тест для EVPROGN
(assert (equal 2 (evprogn '(1 2) nil  #'err #'ok)))
;; Тест для EVPROGN в окружении
(assert (equal 3 (evprogn '(a b c)
                          '((a . 1) (b . 2) (c . 3))
                          #'err #'ok)))
;; Тест для PROGN
(assert (equal 3 (myeval '(progn 1 2 3) nil #'err #'ok)))
;; Тест для PROGN в окружении
(assert (equal 3 (myeval '(progn a b c) '((a . 1) (b . 2) (c . 3)) #'err #'ok)))
;; Тесты для EVAND
(assert (equal (and)           (evand '() nil #'err #'ok)))
(assert (equal (and 1)         (evand '(1) nil #'err #'ok)))
(assert (equal (and nil)       (evand '(nil) nil #'err #'ok)))
(assert (equal (and 1 nil)     (evand '(1 nil) nil #'err #'ok)))
(assert (equal (and 1 2 nil)   (evand '(1 2 nil) nil #'err #'ok)))
(assert (equal (and 1 2 3)     (evand '(1 2 3) nil #'err #'ok)))
;; Тесты для EVAND в окружении
(assert (equal (let ((a nil))
                 (and nil))
               (evand '(a) '((a . nil)) #'err #'ok)))
(assert (equal (let ((a 1))
                 (and a))
               (evand '(a) '((a . 1)) #'err #'ok)))
(assert (equal (let ((a 1)
                     (b nil))
                 (and a b))
               (evand '(a b) '((a . 1) (b . nil)) #'err #'ok)))
(assert (equal (let ((a 1)
                     (b 2)
                     (c nil))
                 (and a b c))
               (evand '(a b c) '((a . 1) (b . 2) (c . nil)) #'err #'ok)))
(assert (equal (let ((a 1)
                     (b 2)
                     (c 3))
                 (and a b c))
               (evand '(a b c) '((a . 1) (b . 2) (c . 3)) #'err #'ok)))
;; Тесты для AND
(assert (equal (and)                (myeval '(and) nil #'err #'ok)))
(assert (equal (and 1)              (myeval '(and 1) nil #'err #'ok)))
(assert (equal (and nil)            (myeval '(and nil) nil #'err #'ok)))
(assert (equal (and 1 nil)          (myeval '(and 1 nil) nil #'err #'ok)))
(assert (equal (and 1 2 nil)        (myeval '(and 1 2 nil) nil #'err #'ok)))
(assert (equal (and 1 2 3)          (myeval '(and 1 2 3) nil #'err #'ok)))
(assert (equal (and 1 (and 1 2) 3)  (myeval '(and 1 (and 1 2) 3) nil #'err #'ok)))
;; Тесты для AND в окружении
(assert (equal (let ((a nil))
                 (and nil))
               (myeval '(and a) '((a . nil)) #'err #'ok)))
(assert (equal (let ((a 1))
                 (and a))
               (myeval '(and a) '((a . 1)) #'err #'ok)))
(assert (equal (let ((a 1)
                     (b nil))
                 (and a b))
               (myeval '(and a b) '((a . 1) (b . nil)) #'err #'ok)))
(assert (equal (let ((a 1)
                     (b 2)
                     (c nil))
                 (and a b c))
               (myeval '(and a b c) '((a . 1) (b . 2) (c . nil)) #'err #'ok)))
(assert (equal (let ((a 1)
                     (b 2)
                     (c 3))
                 (and a b c))
               (myeval '(and a b c) '((a . 1) (b . 2) (c . 3)) #'err #'ok)))
;; Тесты для EVOR
(assert (equal (or)           (evor '() nil #'err #'ok)))
(assert (equal (or nil 1)     (evor '(nil 1) nil #'err #'ok)))
(assert (equal (or nil nil 1) (evor '(nil nil 1) nil #'err #'ok)))
(assert (equal (or nil 1 2)   (evor '(nil 1 2) nil #'err #'ok)))
(assert (equal (or 1 2 3)     (evor '(1 2 3) nil #'err #'ok)))
;; Тесты для EVOR в окружении
(assert (equal (let ((a nil))
                 (or a))
               (evor '(a) '((a . nil)) #'err #'ok)))
(assert (equal (let ((a 1))
                 (or a))
               (evor '(a) '((a . 1)) #'err #'ok)))
(assert (equal (let ((a nil)
                     (b 1))
                 (or a b))
               (evor '(a b) '((a . nil) (b . 1)) #'err #'ok)))
(assert (equal (let ((a nil)
                     (b nil)
                     (c 3))
                 (or a b c))
               (evor '(a b c) '((a . nil) (b . nil) (c . 3)) #'err #'ok)))
(assert (equal (let ((a nil)
                     (b 1)
                     (c 2))
                 (or a b c))
               (evor '(a b c) '((a . nil) (b . 1) (c . 2)) #'err #'ok)))
;; Тесты для OR
(assert (equal (or)                  (myeval '(or) nil #'err #'ok)))
(assert (equal (or nil 1)            (myeval '(or nil 1) nil #'err #'ok)))
(assert (equal (or nil nil 1)        (myeval '(or nil nil 1) nil #'err #'ok)))
(assert (equal (or nil 1 2)          (myeval '(or nil 1 2) nil #'err #'ok)))
(assert (equal (or nil (or 3 2) 2)   (myeval '(or nil (or 3 2) 2) nil #'err #'ok)))
;; Тесты для OR в окружении
(assert (equal (let ((a nil))
                 (or a))
               (myeval '(or a) '((a . nil)) #'err #'ok)))
(assert (equal (let ((a 1))
                 (or a))
               (myeval '(or a) '((a . 1)) #'err #'ok)))
(assert (equal (let ((a nil)
                     (b 1))
                 (or a b))
               (myeval '(or a b) '((a . nil) (b . 1)) #'err #'ok)))
(assert (equal (let ((a nil)
                     (b nil)
                     (c 3))
                 (or a b c))
               (myeval '(or a b c) '((a . nil) (b . nil) (c . 3)) #'err #'ok)))
(assert (equal (let ((a nil)
                     (b 1)
                     (c 2))
                 (or a b c))
               (myeval '(or a b c) '((a . nil) (b . 1) (c . 2)) #'err #'ok)))
;; Тесты для 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"))))
;; Тесты для EVLET
(assert (equal 3 (evlet '(a b) '(1 2) nil '(4 (+ a b)) nil #'err #'ok)))
;; Тесты для LET
(assert (equal '(1 . 2) (myeval '(let ((a 1)
                                       (b 2))
                                  (cons a b)) nil
                                  #'err #'ok)))
;; Тесты для EVLETSTAR
(assert (equal 2 (evletstar '((a 1) (b a)) '(4 (+ a b)) nil  #'err #'ok)))
;; Тесты для LET*
(assert (equal '(3 1 . 2) (myeval '(let* ((a 1)
                                          (b 2)
                                          (c (+ a b)))
                                    (cons c (cons a b)))
                                  nil #'err #'ok)))
;; Тесты для DEFUN
(assert (equal 64 (progn
                    (setf *glob-env* nil)
                    (myeval '(defun alfa (x) (* x x)) nil #'err #'ok)
                    (prog1 (myeval '(alfa 8) nil #'err #'ok)
                      (setf *glob-env* nil)))))
;; Тесты для SETQ
;; Проверка изменения значения локальной переменной, не затрагивая глобального окружения
(assert (equal '((2 . 2) ((alfa . 0)))
               (progn
                 (setf *glob-env* '((alfa . 0)))
                 (prog1 (list (myeval '(cons (setq alfa 2)
                                        alfa)
                                      '((alfa . 1))
                                      #'err #'ok)
                              *glob-env*)
                   (setf *glob-env* nil)))))
;; Изменение значения несуществующей переменной (создание глобальной переменной)
(assert (equal '((1 . 1) ((ALFA . 1) (BETA . 222)))
               (progn
                 (setf *glob-env* '((beta . 222)))
                 (prog1 (list (myeval '(cons
                                        (setq alfa 1)
                                        alfa)
                                      nil #'err #'ok)
                              *glob-env*)
                   (setf *glob-env* nil)))))
;; Изменение значения существующей глобальной переменной
(assert (equal '((1 . 1) ((BETA . 1)))
               (progn
                 (setf *glob-env* '((beta . 222)))
                 (prog1 (list (myeval '(cons
                                        (setq beta 1)
                                        beta)
                                      nil #'err #'ok)
                              *glob-env*)
                   (setf *glob-env* nil)))))
;; Тесты для LAMBDA
(assert (equal 3 (myeval '((lambda (x) (+ 1  x)) 2)
                         nil #'err #'ok)))
;; Тесты для LAMBDA в окружении
(assert (equal 5 (myeval '(let ((y 3))
                           ((lambda (x) (+ y x)) 2))
                         nil #'err #'ok)))
;; REPL
(defun repl ()
  (princ "microlisp>")
  (finish-output)
  (princ (myeval (read) nil #'identity #'identity))
  (terpri)
  (finish-output)
  (repl))
;; (repl)
Яндекс.Метрика
Home