Table of Contents

План работ

Цель этого этапа: преобразовать наш интерпретатор так, чтобы получить возможность использовать block и return-from. Для этого мы заведем специальный вид окружения block-env, который будем замыкать также, как мы замыкаем окружение env.

Аналогично, заведем специальное окружение catch-env, которое делает то же самое, но не в лексической области видимости, а в динамической. Так мы получим возможность использовать trow и catch.

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

Глобальное окружение

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

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

Добавляем block-env, чтобы иметь возможность лексически его замыкать.

(defstruct closure
  body
  env
  block-env
  args)

MyApply

Теперь myapply принимает еще и catch-env:

(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_5>>
<<evlis_5>>
(defun myapply (fn args catch-env errcont cont)
  (cond
    <<myapply_car_cdr_cons_5>>
    <<myapply_null_5>>
    <<myapply_ariph_5>>
    <<myapply_closure_5>>
    <<myapply_print_5>>
    <<myapply_list_5>>
    (t (error 'unknown-function :fn fn))))

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

<<myapply_car_cdr_cons_5_test>>
<<myapply_null_5_test>>
<<evaddmul_5_test>>
<<myapply_ariph_5_test>>
<<myapply_closure_5_test>>
<<myapply_print_5_test>>
<<myapply_evlis_5_test>>
<<myapply_list_5_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 nil nil #'err #'ok)))
(assert (equal '((1 . 2) 3 . 4) (myeval '(cons (cons 1 2) (cons 3 4)) nil nil nil #'err #'ok)))
(assert (equal 2 (myeval '(car (cons 2 3)) nil nil nil #'err #'ok)))
(assert (equal 3 (myeval '(cdr (cons 2 3)) nil nil nil #'err #'ok)))
(assert (equal '(1 . 2) (myeval '(car (cons (cons 1 2) (cons 3 4))) nil nil nil #'err #'ok)))
(assert (equal '(3 . 4) (myeval '(cdr (cons (cons 1 2) (cons 3 4))) nil nil nil #'err #'ok)))
;; Тесты для cons-ячеек, вычисляемых в окружении
(assert (equal 1 (myeval '(car a) '((a . (1 . 2))) nil nil #'err #'ok)))
(assert (equal 2 (myeval '(cdr a) '((a . (1 . 2))) nil nil #'err #'ok)))
(assert (equal 3 (myeval '(car b) '((a . (1 . 2)) (b . (3 . 4))) nil nil #'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)))))
((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 nil nil #'err #'ok)))
(assert (equal T (myeval '(null nil) nil nil nil #'err #'ok)))
(assert (equal NIL (myeval '(null T) nil nil nil #'err #'ok)))
(assert (equal T (myeval '(null a) '((a . ())) nil nil #'err #'ok)))
;; Тесты для NULL, с аргументом, вычисляемые в окружении
(assert (equal NIL (myeval '(null a) '((a . T)) nil nil #'err #'ok)))
(assert (equal NIL (myeval '(null a) '((a . 1)) nil nil #'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 nil nil #'err #'ok)))
(assert (equal (+ 2)            (myeval '(+ 2) nil nil nil #'err #'ok)))
(assert (equal (+ 2 3)          (myeval '(+ 2 3) nil nil nil #'err #'ok)))
(assert (equal (+ 2 3 4)        (myeval '(+ 2 3 4) nil nil nil #'err #'ok)))
(assert (equal (+ 2 (+ 3 4))    (myeval '(+ 2 (+ 3 4)) nil nil nil #'err #'ok)))
(assert (equal (+ 2 (+ 3 4) 5)  (myeval '(+ 2 (+ 3 4) 5) nil nil nil #'err #'ok)))
;; Тесты для умножения
(assert (equal 1                (myeval '(*) nil nil nil #'err #'ok)))
(assert (equal (* 2)            (myeval '(* 2) nil nil nil #'err #'ok)))
(assert (equal (* 2 3)          (myeval '(* 2 3) nil nil nil #'err #'ok)))
(assert (equal (* 2 3 4)        (myeval '(* 2 3 4) nil nil nil #'err #'ok)))
(assert (equal (* 2 (* 3 4))    (myeval '(* 2 (* 3 4)) nil nil nil #'err #'ok)))
(assert (equal (* 2 (* 3 4) 5)  (myeval '(* 2 (* 3 4) 5) nil nil nil #'err #'ok)))
;; Тесты для сложения в окружении
(assert (equal 0
               (myeval '(+) nil nil nil #'err #'ok)))
(assert (equal (let ((a 2))
                 (+ a))
               (myeval '(+ a)
                       '((a . 2))
                       nil nil #'err #'ok)))
(assert (equal (let ((a 2) (b 3))
                 (+ a b))
               (myeval '(+ a b)
                       '((a . 2) (b . 3))
                       nil nil #'err #'ok)))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (+ a b c))
               (myeval '(+ a b c)
                       '((a . 2) (b . 3) (c . 4))
                       nil nil #'err #'ok)))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (+ a (+ b c)))
               (myeval '(+ a (+ b c))
                       '((a . 2) (b . 3) (c . 4))
                       nil nil #'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))
                       nil nil #'err #'ok)))
;; Тесты для умножения  в окружении
(assert (equal 1
               (myeval '(*) nil nil nil #'err #'ok)))
(assert (equal (let ((a 2))
                 (* a))
               (myeval '(* a)
                       '((a . 2))
                       nil nil #'err #'ok)))
(assert (equal (let ((a 2) (b 3))
                 (* a b))
               (myeval '(* a b)
                       '((a . 2) (b . 3))
                       nil nil #'err #'ok)))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (* a b c))
               (myeval '(* a b c)
                       '((a . 2) (b . 3) (c . 4))
                       nil nil #'err #'ok)))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (* a (* b c)))
               (myeval '(* a (* b c))
                       '((a . 2) (b . 3) (c . 4))
                       nil nil #'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))
                       nil nil #'err #'ok)))

CLOSURE

Пробрасываем catch-env, а block-env берем из замыкания:

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

Добавляем параметры в тесты

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

PRINT

((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 nil nil #'err #'identity))))
(assert (equal (print 12)
               (myeval '(print 12) nil nil 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))
                         nil nil #'err #'identity))))
(assert (equal (let ((a 12))
                 (print a))
               (myeval '(print a)
                       '((b . 23) (a . 12))
                       nil nil #'err #'ok)))

LIST

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

(defun evlis (fn unevaled evaled env block-env catch-env errcont cont)
  (cond ((null unevaled)  (myapply fn (reverse evaled) catch-env errcont cont))
        (t                (myeval (car unevaled) env block-env catch-env errcont
                                  (lambda (x)
                                    (evlis fn
                                           (cdr unevaled)
                                           (cons x evaled)
                                           env block-env catch-env
                                           errcont cont))))))

Вызов:

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

Тесты получают дополнительные параметры

;; Тест для EVLIS
(assert (equal 4           (evlis '+     '(1 (+ 1 2))             nil nil nil nil  #'err #'ok)))
(assert (equal (+ 1 3 5)   (evlis '+     '(1 (+ 1 2) 5)           nil nil nil nil  #'err #'ok)))
(assert (equal '(1 3 5)    (evlis 'list  '(1 (+ 1 2) 5)           nil nil 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))
                                  nil nil  #'err #'ok)))

И тесты для LIST

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

MyEval

Мы добавляем новые конструкции:

  • block и return-from
  • catch и trow
<<myeval_evcond_5>>
<<myeval_evprogn_5>>
<<myeval_evand_5>>
<<myeval_evor_5>>
<<myeval_mypairlis_5>>
<<myeval_evlet_5>>
<<myeval_evletstar_5>>
(defun myeval (exp env block-env catch-env errcont cont)
  (cond
    <<myeval_number_5>>
    <<myeval_symb_5>>
    <<myeval_quote_5>>
    <<myeval_if_5>>
    <<myeval_cond_5>>
    <<myeval_progn_5>>
    <<myeval_and_5>>
    <<myeval_or_5>>
    <<myeval_let_5>>
    <<myeval_letstar_5>>
    <<myeval_defun_5>>
    <<myeval_setq_5>>
    <<myeval_lambda_5>>
    <<myeval_block_5>>
    <<myeval_return_from_5>>
    <<myeval_catch_5>>
    <<myeval_throw_5>>
    (t
     (myeval (car exp) env block-env catch-env errcont
             (lambda (x)
               (evlis x (cdr exp) nil env block-env catch-env errcont cont))))))

Тесты:

<<myeval_number_5_test>>
<<myeval_symb_5_test>>
<<myeval_quote_5_test>>
<<myeval_if_5_test>>
<<myeval_evcond_5_test>>
<<myeval_cond_5_test>>
<<myeval_evprogn_5_test>>
<<myeval_progn_5_test>>
<<myeval_evand_5_test>>
<<myeval_and_5_test>>
<<myeval_evor_5_test>>
<<myeval_or_5_test>>
<<myeval_mypairlis_5_test>>
<<myeval_evlet_5_test>>
<<myeval_let_5_test>>
<<myeval_evletstar_5_test>>
<<myeval_letstar_5_test>>
<<myeval_defun_5_test>>
<<myeval_setq_5_test>>
<<myeval_lambda_5_test>>
<<myeval_block_5_test>>
<<myeval_return_from_5_test>>
<<myeval_catch_5_test>>
<<myeval_throw_5_test>>

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

теперь используют продолжения

((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 nil nil #'err #'ok)))
(assert (equal NIL (myeval 'NIL nil nil nil #'err #'ok)))
(assert (equal 999 (myeval 999 nil nil nil #'err #'ok)))

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

((symbolp exp)               (lookup exp env errcont cont))
;; Тесты для вычисления символов
(assert (equal 6 (myeval 'b '((a . 3) (b . 6)) nil nil #'err #'ok)))
(assert (equal "error" (car (myeval 'b nil nil 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 nil nil #'err #'ok)))

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

Пробрасываем block-env и catch-env:

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

COND

Пробрасываем block-env и catch-env:

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

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

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

PROGN

Пробрасываем block-env и catch-env:

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

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

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

AND

Пробрасываем block-env и catch-env:

(defun evand (args env block-env catch-env errcont cont)
  (cond ((null args)        (funcall cont T))
        ((null (cdr args))  (myeval (car args) env block-env catch-env errcont cont))
        (t                  (myeval (car args) env block-env catch-env errcont
                                    (lambda (x)
                                      (if (null x)
                                          (funcall cont nil)
                                          (evand (cdr args) env block-env catch-env
                                                 errcont cont)))))))

Поправим тесты

;; Тесты для EVAND
(assert (equal (and)           (evand '() nil nil nil #'err #'ok)))
(assert (equal (and 1)         (evand '(1) nil nil nil #'err #'ok)))
(assert (equal (and nil)       (evand '(nil) nil nil nil  #'err #'ok)))
(assert (equal (and 1 nil)     (evand '(1 nil) nil nil nil #'err #'ok)))
(assert (equal (and 1 2 nil)   (evand '(1 2 nil) nil nil nil #'err #'ok)))
(assert (equal (and 1 2 3)     (evand '(1 2 3) nil nil nil #'err #'ok)))
(assert (equal (and 1 2 nil 3) (evand '(1 2 nil 3) nil nil nil #'err #'ok)))
;; Тесты для EVAND в окружении
(assert (equal (let ((a nil))
                 (and nil))
               (evand '(a) '((a . nil)) nil nil #'err #'ok)))
(assert (equal (let ((a 1))
                 (and a))
               (evand '(a) '((a . 1)) nil nil #'err #'ok)))
(assert (equal (let ((a 1)
                     (b nil))
                 (and a b))
               (evand '(a b) '((a . 1) (b . nil)) nil 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)) nil 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)) nil nil #'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)) nil nil #'err #'ok)))

Добавим параметры в вызов

((equal (car exp) 'and)      (evand (cdr exp)
                                    env block-env catch-env
                                    errcont cont))

Поправим тесты

;; Тесты для AND
(assert (equal (and)                  (myeval '(and) nil nil nil #'err #'ok)))
(assert (equal (and 1)                (myeval '(and 1) nil nil nil #'err #'ok)))
(assert (equal (and nil)              (myeval '(and nil) nil nil nil #'err #'ok)))
(assert (equal (and 1 nil)            (myeval '(and 1 nil) nil nil nil #'err #'ok)))
(assert (equal (and 1 2 nil)          (myeval '(and 1 2 nil) nil nil nil #'err #'ok)))
(assert (equal (and 1 2 3)            (myeval '(and 1 2 3) nil nil nil #'err #'ok)))
(assert (equal (and 1 (and 1 2) 3  )  (myeval '(and 1 (and 1 2) 3) nil nil nil #'err #'ok)))
(assert (equal (and 1 (and 1 nil) 3)  (myeval '(and 1 (and 1 nil) 3) nil nil nil #'err #'ok)))
;; Тесты для AND в окружении
(assert (equal (let ((a nil))
                 (and nil))
               (myeval '(and a) '((a . nil)) nil nil #'err #'ok)))
(assert (equal (let ((a 1))
                 (and a))
               (myeval '(and a) '((a . 1)) nil nil #'err #'ok)))
(assert (equal (let ((a 1)
                     (b nil))
                 (and a b))
               (myeval '(and a b) '((a . 1) (b . nil)) nil 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)) nil 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)) nil nil #'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)) nil nil #'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)) nil nil #'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)) nil nil #'err #'ok)))

OR

(defun evor (args env block-env catch-env errcont cont)
  (cond ((null args)        (funcall cont nil))
        ((null (cdr args))  (myeval (car args) env block-env catch-env errcont cont))
        (t                  (myeval (car args) env block-env catch-env errcont
                                    (lambda (x)
                                      (if (not (null x))
                                          (funcall cont x)
                                          (evor (cdr args) env block-env catch-env
                                                errcont cont)))))))

Поправим тесты

;; Тесты для EVOR
(assert (equal (or)                   (evor '() nil nil nil #'err #'ok)))
(assert (equal (or nil 1)             (evor '(nil 1) nil nil nil #'err #'ok)))
(assert (equal (or nil nil 1)         (evor '(nil nil 1) nil nil nil #'err #'ok)))
(assert (equal (or nil 1 2)           (evor '(nil 1 2) nil nil nil #'err #'ok)))
(assert (equal (or 1 2 3)             (evor '(1 2 3) nil nil nil #'err #'ok)))
(assert (equal (or nil nil 3 nil)     (evor '(nil nil 3 nil) nil nil nil #'err #'ok)))
;; Тесты для EVOR в окружении
(assert (equal (let ((a nil))
                 (or a))
               (evor '(a) '((a . nil)) nil nil #'err #'ok)))
(assert (equal (let ((a 1))
                 (or a))
               (evor '(a) '((a . 1)) nil nil #'err #'ok)))
(assert (equal (let ((a nil)
                     (b 1))
                 (or a b))
               (evor '(a b) '((a . nil) (b . 1)) nil nil #'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)) nil nil #'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)) nil nil #'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)) nil nil  #'err #'ok)))

Добавим параметры в вызов

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

Поправим тесты

;; Тесты для OR
(assert (equal (or)                  (myeval '(or) nil nil nil #'err #'ok)))
(assert (equal (or nil 1)            (myeval '(or nil 1) nil nil nil #'err #'ok)))
(assert (equal (or nil nil 1)        (myeval '(or nil nil 1) nil nil nil #'err #'ok)))
(assert (equal (or nil 1 2)          (myeval '(or nil 1 2) nil nil nil #'err #'ok)))
(assert (equal (or nil (or 3 2) 2)   (myeval '(or nil (or 3 2) 2) nil nil nil #'err #'ok)))
;; Тесты для OR в окружении
(assert (equal (let ((a nil))
                 (or a))
               (myeval '(or a) '((a . nil)) nil nil #'err #'ok)))
(assert (equal (let ((a 1))
                 (or a))
               (myeval '(or a) '((a . 1)) nil nil #'err #'ok)))
(assert (equal (let ((a nil)
                     (b 1))
                 (or a b))
               (myeval '(or a b) '((a . nil) (b . 1)) nil nil #'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)) nil nil #'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)) nil nil #'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))
                       nil nil #'err #'ok)))

LET

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

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

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

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

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

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

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

LET*

Пробрасываем block-env и catch-env:

(defun evletstar (varpairs exp env block-env catch-env errcont cont)
  (cond ((null varpairs)  (evprogn exp env block-env catch-env errcont cont))
        (t                (myeval (cadar varpairs) env block-env catch-env errcont
                                  (lambda (x)
                                    (evletstar (cdr varpairs) exp
                                               (acons (caar varpairs) x env)
                                               block-env catch-env
                                               errcont cont))))))
;; Тесты для EVLETSTAR
(assert (equal 2 (evletstar '((a 1) (b a)) '(4 (+ a b)) nil nil nil #'err #'ok)))
((equal (car exp) 'let*)     (evletstar (cadr exp)
                                        (cddr exp)
                                        env block-env catch-env
                                        errcont cont))
;; Тесты для LET*
(assert (equal '(3 1 . 2) (myeval '(let* ((a 1)
                                          (b 2)
                                          (c (+ a b)))
                                    (cons c (cons a b)))
                                  nil nil nil #'err #'ok)))

DEFUN

При создании функции мы добавляем в замыкание block-env:

((equal (car exp) 'defun)         (progn
                                    (push (cons (cadr exp)
                                                (make-closure :body (cdddr exp)
                                                              :env env
                                                              :block-env block-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 nil nil #'err #'ok)
                    (prog1 (myeval '(alfa 8) nil nil 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 nil nil #'err #'ok)
                     (prog1 (myeval '(alfa 8) nil nil nil #'err #'ok)
                       (setf *glob-env* nil)))))

SETQ

Пробрасываем block-env и catch-env и убираем комментарии:

((equal (car exp) 'setq)     (myeval (caddr exp) env block-env catch-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))
                                      nil nil #'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 nil 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 nil nil #'err #'ok)
                              *glob-env*)
                   (setf *glob-env* nil)))))

LAMBDA

При создании лямбды мы добавляем в замыкание block-env:

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

BLOCK

При создании блока мы добавляем в окружение block-env пару вида "(имя блока . продолжение)".

((equal (car exp) 'block)    (myeval (caddr exp)
                                     env
                                     (acons (cadr exp)
                                            cont
                                            block-env)
                                     catch-env errcont cont))

Тесты для BLOCK

;; Тесты для BLOCK
(assert (equal nil (myeval '(block testblock)
                           nil nil nil #'err #'ok)))
(assert (equal 3 (myeval '(block testblock 3)
                         nil nil nil #'err #'ok)))

RETURN-FROM

При выходе из блока мы извлекаем из окружения block-env соответствующее продолжение и вызываем его.

((equal (car exp)
        'return-from)        (if (not (symbolp (cadr exp)))
                                 (funcall errcont
                                          (format nil
                                                  "return-from: first argument not a symbol"))
                                 (myeval (caddr exp) env block-env catch-env errcont
                                         (lambda (x)
                                           (assoc-2 (cadr exp) block-env
                                                    (lambda (y) (funcall y x))
                                                    (lambda (y) (funcall errcont
                                                                         (format nil "return-from: undefined return block ~A" y))))))))

Тесты для RETURN-FROM

;; Тесты для RETURN-FROM
(assert (equal 3 (myeval '(block testblock (return-from testblock (+ 1 2)) 777)
                         nil nil nil #'err #'ok)))
(assert (equal "error" (myeval '(block testblock (return-from notblock (+ 1 2)) 777)
                               nil nil nil #'(lambda (x) "error") #'ok)))
(assert (equal "error" (myeval '(progn (return-from not-found-block (+ 1 2)) 777)
                               nil nil nil (lambda (x) "error")
                               #'ok)))
;; Тест RETURN-FROM в лексической области видимости
(assert (equal 12 (myeval '(progn
                            (defun foo (x)
                              (block in-lambda-block
                                (return-from in-lambda-block
                                  (+ x 2))
                                777))
                            (foo 10))
                          nil nil nil (lambda (x) "error")
                          #'ok)))
;; Тест RETURN-FROM в динамической области видимости (должна быть ошибка)
(assert (equal "error" (myeval '(progn
                                 (defun foo (x)
                                   (return-from in-lambda-block
                                     (+ x 2))
                                   777)
                                 (block in-lambda-block
                                   (foo 10)))
                               nil nil nil (lambda (x) "error")
                               #'ok)))

CATCH

При создании блока обработки исключений мы добавляем в окружение catch-env пару вида "(имя блока . продолжение)".

((equal (car exp) 'catch)    (myeval (cadr exp) env block-env catch-env errcont
                                     (lambda (symb-res)
                                       (if (not (symbolp symb-res))
                                           (funcall errcont
                                                    (format nil "catch: first argument not a symbol"))
                                           (myeval (caddr exp)
                                                   env
                                                   block-env
                                                   (acons symb-res
                                                          cont
                                                          catch-env)
                                                   errcont cont)))))

Тесты для CATCH

;; Тесты для CATCH
(assert (equal nil (myeval '(catch 'zzz)
                           nil nil nil #'err #'ok)))
(assert (equal 3 (myeval '(catch 'zzz 3)
                         nil nil nil #'err #'ok)))

THROW

Когда мы бросаем исключение, мы извлекаем из окружения catch-env соответствующее продолжение и вызываем его.

((equal (car exp) 'throw)    (myeval (cadr exp) env block-env catch-env errcont
                                     (lambda (symb-res)
                                       (myeval (caddr exp) env block-env catch-env errcont
                                               (lambda (exp-res)
                                                 (assoc-2 symb-res catch-env
                                                          (lambda (cont-res)
                                                            (funcall cont-res exp-res))
                                                          (lambda (key)
                                                            (funcall errcont
                                                                     (format nil "throw: matching ~A catch is not found" key)))))))))

Тесты для THROW

;; Тесты для THROW
(assert (equal 3 (myeval '(catch 'testcatch (throw 'testcatch (+ 1 2)) 777)
                         nil nil nil #'err #'ok)))
(assert (equal "error" (myeval '(catch 'testcatch (throw 'notcatch (+ 1 2)) 777)
                               nil nil nil
                               #'(lambda (x) "error")
                               #'ok)))
(assert (equal "error" (myeval '(progn (throw 'not-found-catch (+ 1 2)) 777)
                               nil nil nil (lambda (x) "error")
                               #'ok)))
;; Тест THROW в лексической области видимости
(assert (equal 12 (myeval '(progn
                            (defun foo (x)
                              (catch 'in-lambda-catch
                                (throw 'in-lambda-catch
                                  (+ x 2))
                                777))
                            (foo 10))
                          nil nil nil (lambda (x) "error")
                          #'ok)))
;; Тест THROW в динамической области видимости (должно сработать)
(assert (equal 12 (myeval '(progn
                            (defun foo (x)
                              (throw 'in-lambda-catch
                                (+ x 2))
                              777)
                            (catch 'in-lambda-catch
                              (foo 10)))
                          nil nil nil (lambda (x) "error")
                          #'ok)))

REPL

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

Итоги

;; CPS-версия ASSOC
<<assoc_5>>
;; Классы ошибок
<<errors_5>>
;; Новая функция lookup
<<lookup_5>>
;; Структура замыкания
<<closure_5>>
;; CPS-вариант MYAPPLY и все что к нему относится
<<myapply_5>>
;; CPS-вариант MYEVAL и все что к нему относится
<<myeval_5>>
;; Тестируем новый lookup
<<lookup_5_test>>
;; Функции для тестирования CPS-функций
<<ok_err_5>>
;; Тесты для MYAPPLY
<<myapply_5_test>>
;; Тесты для MYEVAL
<<myeval_5_test>>
;; REPL
<<repl_5>>
;; (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
  block-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))))))
(defun evlis (fn unevaled evaled env block-env catch-env errcont cont)
  (cond ((null unevaled)  (myapply fn (reverse evaled) catch-env errcont cont))
        (t                (myeval (car unevaled) env block-env catch-env errcont
                                  (lambda (x)
                                    (evlis fn
                                           (cdr unevaled)
                                           (cons x evaled)
                                           env block-env catch-env
                                           errcont cont))))))
(defun myapply (fn args catch-env 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))
                                         (closure-block-env fn)
                                         catch-env
                                         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 block-env catch-env errcont cont)
  (cond ((null exp)  (funcall cont nil))
        (t           (myeval (caar exp) env block-env catch-env errcont
                             (lambda (x)
                               (if x
                                   (myeval (cadar exp)
                                           env block-env catch-env
                                           errcont cont)
                                   (evcond (cdr exp)
                                           env block-env catch-env
                                           errcont cont)))))))
(defun evprogn (lst env block-env catch-env errcont cont)
  (cond ((null lst)         (funcall cont nil))
        ((null (cdr lst))   (myeval (car lst) env block-env catch-env errcont cont))
        (t                  (myeval (car lst) env block-env catch-env errcont
                                    (lambda (x)
                                      (evprogn (cdr lst)
                                               env block-env catch-env
                                               errcont cont))))))
(defun evand (lst env block-env catch-env errcont cont)
  (cond ((null lst)        (funcall cont (and)))
        ((null (cdr lst))  (myeval (car lst) env block-env catch-env errcont
                                   (lambda (x)
                                     (funcall cont
                                              (and x)))))
        (t                 (myeval (car lst) env block-env catch-env errcont
                                   (lambda (x)
                                     (funcall cont
                                              (and x
                                                   (evand (cdr lst)
                                                          env block-env catch-env
                                                          errcont cont))))))))
(defun evor (lst env block-env catch-env errcont cont)
  (cond ((null lst)        (funcall cont (or)))
        ((null (cdr lst))  (myeval (car lst) env block-env catch-env errcont
                                   (lambda (x)
                                     (funcall cont
                                              (or x)))))
        (t                 (myeval (car lst) env block-env catch-env errcont
                                   (lambda (x)
                                     (funcall cont
                                              (or x
                                                  (evor (cdr lst)
                                                        env block-env catch-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 block-env catch-env errcont cont)
  (cond ((null exps)  (evprogn exp
                               (pairlis vars (reverse evald-exps) env)
                               block-env catch-env
                               errcont cont))
        (t            (myeval (car exps) env block-env catch-env errcont
                              (lambda (x)
                                (evlet vars (cdr exps) (cons x evald-exps) exp
                                       env block-env catch-env
                                       errcont cont))))))
(defun evletstar (varpairs exp env block-env catch-env errcont cont)
  (cond ((null varpairs)  (evprogn exp env block-env catch-env errcont cont))
        (t                (myeval (cadar varpairs) env block-env catch-env errcont
                                  (lambda (x)
                                    (evletstar (cdr varpairs) exp
                                               (acons (caar varpairs) x env)
                                               block-env catch-env
                                               errcont cont))))))
(defun myeval (exp env block-env catch-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 block-env catch-env errcont
                                         (lambda (x)
                                           (if x
                                               (myeval (caddr exp)
                                                       env block-env catch-env
                                                       errcont cont)
                                               (myeval (cadddr exp)
                                                       env block-env catch-env
                                                       errcont cont)))))
    ((equal (car exp) 'cond)     (evcond (cdr exp)
                                         env block-env catch-env
                                         errcont cont))
    ((equal (car exp) 'progn)    (evprogn (cdr exp)
                                          env block-env catch-env
                                          errcont cont))
    ((equal (car exp) 'and)      (funcall cont (evand (cdr exp)
                                                      env block-env catch-env
                                                      errcont cont)))
    ((equal (car exp) 'or)       (evor  (cdr exp)
                                        env block-env catch-env
                                        errcont cont))
    ((equal (car exp) 'let)      (evlet (mapcar #'car (cadr exp))
                                        (mapcar #'cadr (cadr exp))
                                        nil
                                        (cddr exp)
                                        env block-env catch-env
                                        errcont cont))
    ((equal (car exp) 'let*)     (evletstar (cadr exp)
                                            (cddr exp)
                                            env block-env catch-env
                                            errcont cont))
    ((equal (car exp) 'defun)         (progn
                                        (push (cons (cadr exp)
                                                    (make-closure :body (cadddr exp)
                                                                  :env env
                                                                  :block-env block-env
                                                                  :args (caddr exp)))
                                              *glob-env*)
                                        (funcall cont (cadr exp))))
    ((equal (car exp) 'setq)     (myeval (caddr exp) env block-env catch-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
                                                             :block-env block-env
                                                             :args (cadr exp))))
    ((equal (car exp) 'block)    (myeval (caddr exp)
                                         env
                                         (acons (cadr exp)
                                                cont
                                                block-env)
                                         catch-env errcont cont))
    ((equal (car exp)
            'return-from)        (if (not (symbolp (cadr exp)))
                                     (funcall errcont
                                              (format nil
                                                      "return-from: first argument not a symbol"))
                                     (myeval (caddr exp) env block-env catch-env errcont
                                             (lambda (x)
                                               (assoc-2 (cadr exp) block-env
                                                        (lambda (y) (funcall y x))
                                                        (lambda (y) (funcall errcont
                                                                             (format nil "return-from: undefined return block ~A" y))))))))
    ((equal (car exp) 'catch)    (myeval (cadr exp) env block-env catch-env errcont
                                         (lambda (symb-res)
                                           (if (not (symbolp symb-res))
                                               (funcall errcont
                                                        (format nil "catch: first argument not a symbol"))
                                               (myeval (caddr exp)
                                                       env
                                                       block-env
                                                       (acons symb-res
                                                              cont
                                                              catch-env)
                                                       errcont cont)))))
    ((equal (car exp) 'throw)    (myeval (cadr exp) env block-env catch-env errcont
                                         (lambda (symb-res)
                                           (myeval (caddr exp) env block-env catch-env errcont
                                                   (lambda (exp-res)
                                                     (assoc-2 symb-res catch-env
                                                              (lambda (cont-res)
                                                                (funcall cont-res exp-res))
                                                              (lambda (key)
                                                                (funcall errcont
                                                                         (format nil "throw: matching ~A catch is not found" key)))))))))
    ((equal (car exp)
            'return-from)        (if (not (symbolp (cadr exp)))
                                     (funcall errcont
                                              (format nil
                                                      "return-from: first argument not a symbol"))
                                     (myeval (caddr exp) env block-env catch-env errcont
                                             (lambda (x)
                                               (assoc-2 (cadr exp) block-env
                                                        (lambda (y) (funcall y x))
                                                        (lambda (y) (funcall errcont
                                                                             (format nil "return-from: undefined return block ~A" y))))))))
    ((equal (car exp) 'catch)    (myeval (cadr exp) env block-env catch-env errcont
                                         (lambda (symb-res)
                                           (if (not (symbolp symb-res))
                                               (funcall errcont
                                                        (format nil "catch: first argument not a symbol"))
                                               (myeval (caddr exp)
                                                       env
                                                       block-env
                                                       (acons symb-res
                                                              cont
                                                              catch-env)
                                                       errcont cont)))))
    ((equal (car exp) 'throw)    (myeval (cadr exp) env block-env catch-env errcont
                                         (lambda (symb-res)
                                           (myeval (caddr exp) env block-env catch-env errcont
                                                   (lambda (exp-res)
                                                     (assoc-2 symb-res catch-env
                                                              (lambda (cont-res)
                                                                (funcall cont-res exp-res))
                                                              (lambda (key)
                                                                (funcall errcont
                                                                         (format nil "throw: matching ~A catch is not found" key)))))))))
    (t
     (myeval (car exp) env block-env catch-env errcont
             (lambda (x)
               (evlis x (cdr exp) nil env block-env catch-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 nil nil #'err #'ok)))
(assert (equal '((1 . 2) 3 . 4) (myeval '(cons (cons 1 2) (cons 3 4)) nil nil nil #'err #'ok)))
(assert (equal 2 (myeval '(car (cons 2 3)) nil nil nil #'err #'ok)))
(assert (equal 3 (myeval '(cdr (cons 2 3)) nil nil nil #'err #'ok)))
(assert (equal '(1 . 2) (myeval '(car (cons (cons 1 2) (cons 3 4))) nil nil nil #'err #'ok)))
(assert (equal '(3 . 4) (myeval '(cdr (cons (cons 1 2) (cons 3 4))) nil nil nil #'err #'ok)))
;; Тесты для cons-ячеек, вычисляемых в окружении
(assert (equal 1 (myeval '(car a) '((a . (1 . 2))) nil nil #'err #'ok)))
(assert (equal 2 (myeval '(cdr a) '((a . (1 . 2))) nil nil #'err #'ok)))
(assert (equal 3 (myeval '(car b) '((a . (1 . 2)) (b . (3 . 4))) nil nil #'err #'ok)))
;; Тесты для NULL
(assert (equal T (myeval '(null ()) nil nil nil #'err #'ok)))
(assert (equal T (myeval '(null nil) nil nil nil #'err #'ok)))
(assert (equal NIL (myeval '(null T) nil nil nil #'err #'ok)))
(assert (equal T (myeval '(null a) '((a . ())) nil nil #'err #'ok)))
;; Тесты для NULL, с аргументом, вычисляемые в окружении
(assert (equal NIL (myeval '(null a) '((a . T)) nil nil #'err #'ok)))
(assert (equal NIL (myeval '(null a) '((a . 1)) nil nil #'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 nil nil #'err #'ok)))
(assert (equal (+ 2)            (myeval '(+ 2) nil nil nil #'err #'ok)))
(assert (equal (+ 2 3)          (myeval '(+ 2 3) nil nil nil #'err #'ok)))
(assert (equal (+ 2 3 4)        (myeval '(+ 2 3 4) nil nil nil #'err #'ok)))
(assert (equal (+ 2 (+ 3 4))    (myeval '(+ 2 (+ 3 4)) nil nil nil #'err #'ok)))
(assert (equal (+ 2 (+ 3 4) 5)  (myeval '(+ 2 (+ 3 4) 5) nil nil nil #'err #'ok)))
;; Тесты для умножения
(assert (equal 1                (myeval '(*) nil nil nil #'err #'ok)))
(assert (equal (* 2)            (myeval '(* 2) nil nil nil #'err #'ok)))
(assert (equal (* 2 3)          (myeval '(* 2 3) nil nil nil #'err #'ok)))
(assert (equal (* 2 3 4)        (myeval '(* 2 3 4) nil nil nil #'err #'ok)))
(assert (equal (* 2 (* 3 4))    (myeval '(* 2 (* 3 4)) nil nil nil #'err #'ok)))
(assert (equal (* 2 (* 3 4) 5)  (myeval '(* 2 (* 3 4) 5) nil nil nil #'err #'ok)))
;; Тесты для сложения в окружении
(assert (equal 0
               (myeval '(+) nil nil nil #'err #'ok)))
(assert (equal (let ((a 2))
                 (+ a))
               (myeval '(+ a)
                       '((a . 2))
                       nil nil #'err #'ok)))
(assert (equal (let ((a 2) (b 3))
                 (+ a b))
               (myeval '(+ a b)
                       '((a . 2) (b . 3))
                       nil nil #'err #'ok)))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (+ a b c))
               (myeval '(+ a b c)
                       '((a . 2) (b . 3) (c . 4))
                       nil nil #'err #'ok)))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (+ a (+ b c)))
               (myeval '(+ a (+ b c))
                       '((a . 2) (b . 3) (c . 4))
                       nil nil #'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))
                       nil nil #'err #'ok)))
;; Тесты для умножения  в окружении
(assert (equal 1
               (myeval '(*) nil nil nil #'err #'ok)))
(assert (equal (let ((a 2))
                 (* a))
               (myeval '(* a)
                       '((a . 2))
                       nil nil #'err #'ok)))
(assert (equal (let ((a 2) (b 3))
                 (* a b))
               (myeval '(* a b)
                       '((a . 2) (b . 3))
                       nil nil #'err #'ok)))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (* a b c))
               (myeval '(* a b c)
                       '((a . 2) (b . 3) (c . 4))
                       nil nil #'err #'ok)))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (* a (* b c)))
               (myeval '(* a (* b c))
                       '((a . 2) (b . 3) (c . 4))
                       nil nil #'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))
                       nil nil #'err #'ok)))
;; Тесты для применения CLOSURE
(assert (equal 1 (myeval '(((lambda (x)
                              (lambda (y) x))
                            1)
                           2)
                         nil nil 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 nil nil #'err #'identity))))
(assert (equal (print 12)
               (myeval '(print 12) nil nil 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))
                         nil nil #'err #'identity))))
(assert (equal (let ((a 12))
                 (print a))
               (myeval '(print a)
                       '((b . 23) (a . 12))
                       nil nil #'err #'ok)))
;; Тест для EVLIS
(assert (equal 4           (evlis '+     '(1 (+ 1 2))             nil nil nil nil  #'err #'ok)))
(assert (equal (+ 1 3 5)   (evlis '+     '(1 (+ 1 2) 5)           nil nil nil nil  #'err #'ok)))
(assert (equal '(1 3 5)    (evlis 'list  '(1 (+ 1 2) 5)           nil nil 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))
                                  nil nil  #'err #'ok)))
;; Тесты для LIST
(assert (equal '(1 14) (myeval '(list 1 (+ 2 (* 3 4)))
                               nil nil nil #'err #'ok)))
(assert (equal '(3 6 42)
               (myeval '(list (+ 1 2) (* 2 3) 42) nil nil nil #'err #'ok)))
(assert (equal '(3 6 42)
               (myeval '(list (+ a b) (* b c) 42)
                       '((a . 1) (b . 2) (c . 3) (d . 4))
                       nil nil #'err #'ok)))
;; Тесты для MYEVAL
;; Тесты для самовычисляемых форм
(assert (equal T (myeval 'T nil nil nil #'err #'ok)))
(assert (equal NIL (myeval 'NIL nil nil nil #'err #'ok)))
(assert (equal 999 (myeval 999 nil nil nil #'err #'ok)))
;; Тесты для вычисления символов
(assert (equal 6 (myeval 'b '((a . 3) (b . 6)) nil nil #'err #'ok)))
(assert (equal "error" (car (myeval 'b nil nil nil
                                    #'(lambda (x) (cons "error" x))
                                    #'ok))))
;; Тесты для QUOTE
(assert (equal '(+ 1 2) (myeval '(quote (+ 1 2)) nil nil nil #'err #'ok)))
;; Тесты для IF
(assert (equal 2 (myeval '(if () 1 2) nil nil nil #'err #'ok)))
(assert (equal 1 (myeval '(if (null ()) 1 2) nil nil nil #'err #'ok)))
;; Тесты для IF, где условие вычисляется в окружении
(assert (equal 2 (myeval '(if a 1 2) '((a . ())) nil nil #'err #'ok)))
(assert (equal 1 (myeval '(if a 1 2) '((a . 1)) nil nil #'err #'ok)))
;; Тесты для EVCOND
(assert (equal 2   (evcond '((t 2)   (t 1)) nil nil nil #'err #'ok)))
(assert (equal 1   (evcond '((nil 2) (t 1)) nil nil nil #'err #'ok)))
(assert (equal nil (evcond '((nil 2) (nil 1)) nil nil nil #'err #'ok)))
;; Тесты для EVCOND, где участвует окружение
(assert (equal 2 (evcond '((a 2) (b 1))
                         '((a . 1) (b . ()))
                         nil nil #'err #'ok)))
(assert (equal 1 (evcond '((a 2) (b 1))
                         '((a . nil) (b . T))
                         nil nil #'err #'ok)))
;; Тесты для COND
(assert (equal 2 (myeval '(cond
                           (() 1)
                           (1 2))
                         nil nil nil #'err #'ok)))
(assert (equal 2 (myeval '(cond
                           (a 1)
                           (b 2))
                         '((a . ()) (b . 1))
                         nil nil #'err #'ok)))
(assert (equal 1 (myeval '(cond
                           (a 1)
                           (b 2))
                         '((a . 1) (b . ()))
                         nil nil #'err #'ok)))
;; Тест для EVPROGN
(assert (equal 2 (evprogn '(1 2) nil nil nil  #'err #'ok)))
;; Тест для EVPROGN в окружении
(assert (equal 3 (evprogn '(a b c)
                          '((a . 1) (b . 2) (c . 3))
                          nil nil #'err #'ok)))
;; Тест для PROGN
(assert (equal 3 (myeval '(progn 1 2 3) nil nil nil #'err #'ok)))
;; Тест для PROGN в окружении
(assert (equal 3 (myeval '(progn a b c) '((a . 1) (b . 2) (c . 3))
                         nil nil #'err #'ok)))
;; Тесты для EVAND
(assert (equal (and)           (evand '() nil nil nil #'err #'ok)))
(assert (equal (and 1)         (evand '(1) nil nil nil #'err #'ok)))
(assert (equal (and nil)       (evand '(nil) nil nil nil  #'err #'ok)))
(assert (equal (and 1 nil)     (evand '(1 nil) nil nil nil #'err #'ok)))
(assert (equal (and 1 2 nil)   (evand '(1 2 nil) nil nil nil #'err #'ok)))
(assert (equal (and 1 2 3)     (evand '(1 2 3) nil nil nil #'err #'ok)))
;; Тесты для EVAND в окружении
(assert (equal (let ((a nil))
                 (and nil))
               (evand '(a) '((a . nil)) nil nil #'err #'ok)))
(assert (equal (let ((a 1))
                 (and a))
               (evand '(a) '((a . 1)) nil nil #'err #'ok)))
(assert (equal (let ((a 1)
                     (b nil))
                 (and a b))
               (evand '(a b) '((a . 1) (b . nil)) nil 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)) nil 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)) nil nil #'err #'ok)))
;; Тесты для AND
(assert (equal (and)                (myeval '(and) nil nil nil #'err #'ok)))
(assert (equal (and 1)              (myeval '(and 1) nil nil nil #'err #'ok)))
(assert (equal (and nil)            (myeval '(and nil) nil nil nil #'err #'ok)))
(assert (equal (and 1 nil)          (myeval '(and 1 nil) nil nil nil #'err #'ok)))
(assert (equal (and 1 2 nil)        (myeval '(and 1 2 nil) nil nil nil #'err #'ok)))
(assert (equal (and 1 2 3)          (myeval '(and 1 2 3) nil nil nil #'err #'ok)))
(assert (equal (and 1 (and 1 2) 3)  (myeval '(and 1 (and 1 2) 3) nil nil nil #'err #'ok)))
;; Тесты для AND в окружении
(assert (equal (let ((a nil))
                 (and nil))
               (myeval '(and a) '((a . nil)) nil nil #'err #'ok)))
(assert (equal (let ((a 1))
                 (and a))
               (myeval '(and a) '((a . 1)) nil nil #'err #'ok)))
(assert (equal (let ((a 1)
                     (b nil))
                 (and a b))
               (myeval '(and a b) '((a . 1) (b . nil)) nil 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)) nil 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)) nil nil #'err #'ok)))
;; Тесты для EVOR
(assert (equal (or)           (evor '() nil nil nil #'err #'ok)))
(assert (equal (or nil 1)     (evor '(nil 1) nil nil nil #'err #'ok)))
(assert (equal (or nil nil 1) (evor '(nil nil 1) nil nil nil #'err #'ok)))
(assert (equal (or nil 1 2)   (evor '(nil 1 2) nil nil nil #'err #'ok)))
(assert (equal (or 1 2 3)     (evor '(1 2 3) nil nil nil #'err #'ok)))
;; Тесты для EVOR в окружении
(assert (equal (let ((a nil))
                 (or a))
               (evor '(a) '((a . nil)) nil nil #'err #'ok)))
(assert (equal (let ((a 1))
                 (or a))
               (evor '(a) '((a . 1)) nil nil #'err #'ok)))
(assert (equal (let ((a nil)
                     (b 1))
                 (or a b))
               (evor '(a b) '((a . nil) (b . 1)) nil nil #'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)) nil nil #'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)) nil nil #'err #'ok)))
;; Тесты для OR
(assert (equal (or)                  (myeval '(or) nil nil nil #'err #'ok)))
(assert (equal (or nil 1)            (myeval '(or nil 1) nil nil nil #'err #'ok)))
(assert (equal (or nil nil 1)        (myeval '(or nil nil 1) nil nil nil #'err #'ok)))
(assert (equal (or nil 1 2)          (myeval '(or nil 1 2) nil nil nil #'err #'ok)))
(assert (equal (or nil (or 3 2) 2)   (myeval '(or nil (or 3 2) 2) nil nil nil #'err #'ok)))
;; Тесты для OR в окружении
(assert (equal (let ((a nil))
                 (or a))
               (myeval '(or a) '((a . nil)) nil nil #'err #'ok)))
(assert (equal (let ((a 1))
                 (or a))
               (myeval '(or a) '((a . 1)) nil nil #'err #'ok)))
(assert (equal (let ((a nil)
                     (b 1))
                 (or a b))
               (myeval '(or a b) '((a . nil) (b . 1)) nil nil #'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)) nil nil #'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)) nil nil #'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 nil nil #'err #'ok)))
;; Тесты для LET
(assert (equal '(1 . 2) (myeval '(let ((a 1)
                                       (b 2))
                                  (cons a b))
                                nil nil nil
                                #'err #'ok)))
;; Тесты для EVLETSTAR
(assert (equal 2 (evletstar '((a 1) (b a)) '(4 (+ a b)) nil nil nil #'err #'ok)))
;; Тесты для LET*
(assert (equal '(3 1 . 2) (myeval '(let* ((a 1)
                                          (b 2)
                                          (c (+ a b)))
                                    (cons c (cons a b)))
                                  nil nil nil #'err #'ok)))
;; Тесты для DEFUN
(assert (equal 64 (progn
                    (setf *glob-env* nil)
                    (myeval '(defun alfa (x) (* x x)) nil nil nil #'err #'ok)
                    (prog1 (myeval '(alfa 8) nil nil 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))
                                      nil nil #'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 nil 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 nil nil #'err #'ok)
                              *glob-env*)
                   (setf *glob-env* nil)))))
;; Тесты для LAMBDA
(assert (equal 3 (myeval '((lambda (x) (+ 1  x)) 2)
                         nil nil nil #'err #'ok)))
;; Тесты для LAMBDA в окружении
(assert (equal 5 (myeval '(let ((y 3))
                           ((lambda (x) (+ y x)) 2))
                         nil nil nil #'err #'ok)))
;; Тесты для BLOCK
(assert (equal nil (myeval '(block testblock)
                           nil nil nil #'err #'ok)))
(assert (equal 3 (myeval '(block testblock 3)
                         nil nil nil #'err #'ok)))
;; Тесты для RETURN-FROM
(assert (equal 3 (myeval '(block testblock (return-from testblock (+ 1 2)) 777)
                         nil nil nil #'err #'ok)))
(assert (equal "error" (myeval '(block testblock (return-from notblock (+ 1 2)) 777)
                               nil nil nil #'(lambda (x) "error") #'ok)))
(assert (equal "error" (myeval '(progn (return-from not-found-block (+ 1 2)) 777)
                               nil nil nil (lambda (x) "error")
                               #'ok)))
;; Тест RETURN-FROM в лексической области видимости
(assert (equal 12 (myeval '(progn
                            (defun foo (x)
                              (block in-lambda-block
                                (return-from in-lambda-block
                                  (+ x 2))
                                777))
                            (foo 10))
                          nil nil nil (lambda (x) "error")
                          #'ok)))
;; Тест RETURN-FROM в динамической области видимости (должна быть ошибка)
(assert (equal "error" (myeval '(progn
                                 (defun foo (x)
                                   (return-from in-lambda-block
                                     (+ x 2))
                                   777)
                                 (block in-lambda-block
                                   (foo 10)))
                               nil nil nil (lambda (x) "error")
                               #'ok)))
;; Тесты для CATCH
(assert (equal nil (myeval '(catch 'zzz)
                           nil nil nil #'err #'ok)))
(assert (equal 3 (myeval '(catch 'zzz 3)
                         nil nil nil #'err #'ok)))

;; Тесты для THROW
(assert (equal 3 (myeval '(catch 'testcatch (throw 'testcatch (+ 1 2)) 777)
                         nil nil nil #'err #'ok)))
(assert (equal "error" (myeval '(catch 'testcatch (throw 'notcatch (+ 1 2)) 777)
                               nil nil nil
                               #'(lambda (x) "error")
                               #'ok)))
(assert (equal "error" (myeval '(progn (throw 'not-found-catch (+ 1 2)) 777)
                               nil nil nil (lambda (x) "error")
                               #'ok)))
;; Тест THROW в лексической области видимости
(assert (equal 12 (myeval '(progn
                            (defun foo (x)
                              (catch 'in-lambda-catch
                                (throw 'in-lambda-catch
                                  (+ x 2)))
                              777)
                            (foo 10))
                          nil nil nil (lambda (x) "error")
                          #'ok)))
;; Тест THROW в динамической области видимости (должно сработать)
(assert (equal 12 (myeval '(progn
                            (defun foo (x)
                              (throw 'in-lambda-catch
                                (+ x 2))
                              777)
                            (catch 'in-lambda-catch
                              (foo 10)))
                          nil nil nil (lambda (x) "error")
                          #'ok)))
;; REPL
(defun repl ()
  (princ "microlisp>")
  (finish-output)
  (princ (myeval (read) nil #'identity #'identity))
  (terpri)
  (finish-output)
  (repl))
;; (repl)
Яндекс.Метрика
Home