Table of Contents

План работ

На этом этапе мы проведем дефункционализацию. Дефункционализация - это представление продолжений явными структурами. Для этого мы берем лямбду продолжения и все её свободные переменные упаковываем в структуру, соответствующую этом вызову.

Большинство вызовов похожи друг на друга в отношении принимаемых параметров, значит и структуры будут похожи в отношении полей. Поэтому мы можем объявить структуру (назовем ее unicont) от которой будем наследовать различающиеся поля. Мы сделаем это в разделе Структура UNICONT.

Теперь у нас есть передача структур вместо функций в продолжениях. Когда продолжения были функциями мы применяли их с помощью funcall. Теперь мы вынесем применение продолжения в отдельную функцию apply-continuation, которая по типу продолжения определяет как именно его применить. Т.е. вся логика лямбда-функции продолжений переносится туда. Большинство продолжений принимают один аргумент, но есть и такие (в go) которые не принимают аргументов. Мы сделаем это в разделе Применение продолжений

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

Здесь мы не должны менять funcall на apply-continuation, потому что продолжения assoc-2 не являются продолжениями интерпретатора. Поэтому для наглядоности переименуем cont в success а errcont в failure:

[TODO:gmm] Возможно это стоит бэкпортить

(defun assoc-2 (key alist success failure) ;; NB!: inverted order of
                                           ;; successinuations (for lookup)
  (cond ((null alist)              (funcall failure key))
        ((equal key (caar alist))  (funcall success (cdar alist)))
        (t                         (assoc-2 key (cdr alist) success failure))))
(assert (equal 123 (lookup 'aaa '((aaa . 123)) #'err #'ok)))
(assert (equal "stub"  (lookup 'aaa '((bbb . 123)) #'stub #'ok)))

Заменяем передачу продолжения cont в assoc на (apply-continuation cont ...). Также заменяем вызов funcall errcont на (apply-continuation errcont ...). Мы можем это сделать, так как когда apply-continuation встречает лямбду, а не структуру, она применяет ее с помощью funcall.

[TODO:gmm] Я тут поправил возможную ошибку с потерей лямбды, замеченную в следущем файле. Проверить что все работает.

;; environment
(defparameter *glob-env* nil)
(defun lookup (symb env errcont cont)
  (assoc-2 symb env
           (lambda (x)
             (apply-continuation cont x))
           (lambda (key)
             (assoc-2 key *glob-env*
                      (lambda (x) ;; возможно ошибка (была) тут
                        (apply-continuation cont x))
                      (lambda (key)
                        (apply-continuation
                         errcont
                         (format
                          nil "UNBOUD VARIABLE [~A] ~%LOCAL ENV: [~A] ~%GLOBAL ENV: [~A]"
                          key env *glob-env*)))))))

Изменяем тесты так чтобы они использовали stub в качестве продолжения

;; test lookup
(assert (equal 123 (lookup 'aaa '((aaa . 123)) #'err #'ok)))
(assert (equal "stub"  (lookup 'aaa '((bbb . 123)) #'stub #'ok)))

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

Добавляем функцию stub для тестирования продолжений ошибки

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

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

(defstruct closure
  body
  env
  block-env
  go-env
  args)

Структура UNICONT

Определим структуру unicont, которая будет хранить

  • block-env
  • go-env
  • catch-env
  • errcont
  • cont

дефункционализированного продолжения. Остальные структуры разнотипных продолжений будем наследовать от нее. Поэтому они будут включаться здесь, под объединяющим литературным плейсхолдером contstruct (игра слов: от continuation structure), так же как мы включаем общий плейсхлолдер ошибок errors.

(defstruct unicont
  block-env
  go-env
  catch-env
  errcont
  cont)
<<construct_9>>

Применение продолжений

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

(define-condition unknown-continuation (error)
  ((cont :initarg :cont  :reader cont))
  (:report
   (lambda (condition stream)
     (format stream "Error in APPLY-CONTINUATION: unknown-continuation: ~A"
             (cont condition)))))

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

(defun apply-continuation (cont arg)
  (cond ((eq #'ok   cont)       (funcall cont arg))
        ((eq #'err  cont)       (funcall cont arg))
        ((eq #'stub cont)       (funcall cont arg))
        ((functionp cont)       (funcall cont arg)) ;; tmp
        <<apply_cont_if_9>>
        <<apply_cont_evcond_9>>
        <<apply_cont_evcond_9>>
        <<apply_cont_evand_9>>
        <<apply_cont_evor_9>>
        <<apply_cont_evlet_9>>
        <<apply_cont_evletstar_9>>
        <<apply_cont_setq_9>>
        <<apply_cont_catch_9>>
        <<apply_cont_throw_9>>
        <<apply_cont_throw2_9>>
        <<apply_cont_evtagbody_9>>
        <<apply_cont_evlis_9>>
        (t (error 'unknown-continuation :cont cont))))

MyApply

(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_9>>
<<evlis_9>>
(defun myapply (fn args catch-env errcont cont)
  (cond
    <<myapply_car_cdr_cons_9>>
    <<myapply_null_9>>
    <<myapply_ariph_9>>
    <<myapply_closure_9>>
    <<myapply_print_9>>
    <<myapply_list_9>>
    <<myapply_callcc_9>>
    (t (error 'unknown-function :fn fn))))
<<myapply_car_cdr_cons_9_test>>
<<myapply_null_9_test>>
<<evaddmul_9_test>>
<<myapply_ariph_9_test>>
<<myapply_closure_9_test>>
<<myapply_print_9_test>>
<<myapply_evlis_9_test>>
<<myapply_list_9_test>>
<<myapply_callcc_9_test>>

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

Заменяем funcall на apply-continuation.

((equal fn 'car)             (apply-continuation cont (caar args)))
((equal fn 'cdr)             (apply-continuation cont (cdar args)))
((equal fn 'cons)            (apply-continuation cont (cons (car args) (cadr args))))
;; Тесты cons, car, cdr
(assert (equal '(1 . 2) (myeval '(cons 1 2) nil nil nil nil #'err #'ok)))
(assert (equal '((1 . 2) 3 . 4) (myeval '(cons (cons 1 2) (cons 3 4)) nil nil nil nil #'err #'ok)))
(assert (equal 2 (myeval '(car (cons 2 3)) nil nil nil nil #'err #'ok)))
(assert (equal 3 (myeval '(cdr (cons 2 3)) nil nil nil nil #'err #'ok)))
(assert (equal '(1 . 2) (myeval '(car (cons (cons 1 2) (cons 3 4))) nil nil nil nil #'err #'ok)))
(assert (equal '(3 . 4) (myeval '(cdr (cons (cons 1 2) (cons 3 4))) nil nil nil nil #'err #'ok)))
;; Тесты для cons-ячеек, вычисляемых в окружении
(assert (equal 1 (myeval '(car a) '((a . (1 . 2))) nil nil nil #'err #'ok)))
(assert (equal 2 (myeval '(cdr a) '((a . (1 . 2))) nil nil nil #'err #'ok)))
(assert (equal 3 (myeval '(car b) '((a . (1 . 2)) (b . (3 . 4))) nil 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)))))

Заменяем funcall на apply-continuation.

((equal fn 'null)            (if (null (cdr args))
                                 (apply-continuation cont (null (car args)))
                                 (error 'invalid-number-of-arguments :fn fn)))
;; Тесты для NULL
(assert (equal T (myeval '(null ()) nil nil nil nil #'err #'ok)))
(assert (equal T (myeval '(null nil) nil nil nil nil #'err #'ok)))
(assert (equal NIL (myeval '(null T) nil nil nil nil #'err #'ok)))
(assert (equal T (myeval '(null a) '((a . ())) nil nil nil #'err #'ok)))
;; Тесты для NULL, с аргументом, вычисляемые в окружении
(assert (equal NIL (myeval '(null a) '((a . T)) nil nil nil #'err #'ok)))
(assert (equal NIL (myeval '(null a) '((a . 1)) nil nil nil #'err #'ok)))

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

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

Заменяем funcall на apply-continuation.

((equal fn '+)               (apply-continuation cont (evadd args 0)))
((equal fn '*)               (apply-continuation cont (evmul args 1)))
;; Тесты для сложения
(assert (equal 0                (myeval '(+) nil nil nil nil #'err #'ok)))
(assert (equal (+ 2)            (myeval '(+ 2) nil nil nil nil #'err #'ok)))
(assert (equal (+ 2 3)          (myeval '(+ 2 3) nil nil nil nil #'err #'ok)))
(assert (equal (+ 2 3 4)        (myeval '(+ 2 3 4) nil nil nil nil #'err #'ok)))
(assert (equal (+ 2 (+ 3 4))    (myeval '(+ 2 (+ 3 4)) nil nil nil nil #'err #'ok)))
(assert (equal (+ 2 (+ 3 4) 5)  (myeval '(+ 2 (+ 3 4) 5) nil nil nil nil #'err #'ok)))
;; Тесты для умножения
(assert (equal 1                (myeval '(*) nil nil nil nil #'err #'ok)))
(assert (equal (* 2)            (myeval '(* 2) nil nil nil nil #'err #'ok)))
(assert (equal (* 2 3)          (myeval '(* 2 3) nil nil nil nil #'err #'ok)))
(assert (equal (* 2 3 4)        (myeval '(* 2 3 4) nil nil nil nil #'err #'ok)))
(assert (equal (* 2 (* 3 4))    (myeval '(* 2 (* 3 4)) nil nil nil nil #'err #'ok)))
(assert (equal (* 2 (* 3 4) 5)  (myeval '(* 2 (* 3 4) 5) nil nil nil nil #'err #'ok)))
;; Тесты для сложения в окружении
(assert (equal 0
               (myeval '(+) nil nil nil nil #'err #'ok)))
(assert (equal (let ((a 2))
                 (+ a))
               (myeval '(+ a)
                       '((a . 2))
                       nil nil nil #'err #'ok)))
(assert (equal (let ((a 2) (b 3))
                 (+ a b))
               (myeval '(+ a b)
                       '((a . 2) (b . 3))
                       nil 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 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 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 nil #'err #'ok)))
;; Тесты для умножения  в окружении
(assert (equal 1
               (myeval '(*) nil nil nil nil #'err #'ok)))
(assert (equal (let ((a 2))
                 (* a))
               (myeval '(* a)
                       '((a . 2))
                       nil nil nil #'err #'ok)))
(assert (equal (let ((a 2) (b 3))
                 (* a b))
               (myeval '(* a b)
                       '((a . 2) (b . 3))
                       nil 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 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 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 nil #'err #'ok)))

CLOSURE

((closure-p fn)              (evprogn (closure-body fn)
                                      (pairlis (closure-args fn)
                                               args
                                               (closure-env fn))
                                      (closure-block-env fn)
                                      (closure-go-env fn)
                                      catch-env
                                      errcont cont))
;; Тесты для применения CLOSURE
(assert (equal 1 (myeval '(((lambda (x)
                              (lambda (y) x))
                            1)
                           2)
                         nil nil nil nil #'err #'ok)))

PRINT

Заменяем funcall на apply-continuation.

[TODO:gmm] Сделать проверку кол-ва аргументов

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

LIST

Определим структуру для сохранения продолжения evlis, которая будет унаследована от unicond:

(defstruct (evlis-cont (:include unicont))
  fn
  unevaled
  evaled
  env)

Теперь evlis, в случае получения непустого unevaled будет создавать эту структуру и передавать её в качестве продолжения в myeval, вместо лямбды

(defun evlis (fn unevaled evaled env block-env go-env catch-env errcont cont)
  (cond ((null unevaled)  (myapply fn (reverse evaled) catch-env errcont cont))
        (t                (myeval (car unevaled) env block-env go-env catch-env errcont
                                  (make-evlis-cont
                                   :fn fn
                                   :unevaled unevaled
                                   :evaled evaled
                                   :env env
                                   :block-env block-env
                                   :go-env go-env
                                   :catch-env catch-env
                                   :errcont errcont
                                   :cont cont)))))

А саму логику из лямбды переместим в apply-continuation:

((evlis-cont-p cont)    (evlis (evlis-cont-fn cont)
                               (cdr (evlis-cont-unevaled cont))
                               (cons arg (evlis-cont-evaled cont))
                               (evlis-cont-env cont)
                               (unicont-block-env cont)
                               (unicont-go-env cont)
                               (unicont-catch-env cont)
                               (unicont-errcont cont)
                               (unicont-cont cont)))

Заменяем funcall на apply-continuation.

((equal fn 'list)            (apply-continuation cont args))
;; Тест для EVLIS
(assert (equal 4           (evlis '+     '(1 (+ 1 2))   nil nil nil nil nil  #'err #'ok)))
(assert (equal (+ 1 3 5)   (evlis '+     '(1 (+ 1 2) 5) nil nil nil nil nil  #'err #'ok)))
(assert (equal '(1 3 5)    (evlis 'list  '(1 (+ 1 2) 5) nil 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 nil  #'err #'ok)))
;; Тесты для LIST
(assert (equal '(1 14) (myeval '(list 1 (+ 2 (* 3 4)))
                               nil nil nil nil #'err #'ok)))
(assert (equal '(3 6 42)
               (myeval '(list (+ 1 2) (* 2 3) 42) nil 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 nil #'err #'ok)))

CALL/CC

((equal fn 'call/cc)         (myapply (car args) (list cont) catch-env errcont cont))
((functionp fn)              (apply fn args))      ; interim hack
((unicont-p fn)              (apply-continuation fn (car args)))
;;  ((identity-cont-p fn)        (apply-continuation fn (car args))) ;; for identity
;; Тесты для CALL/CC
(assert (equal 14 (myeval '(+ 1 2 (call/cc (lambda (x) (+ 3 4) (x (+ 5 6)) (+7 8))))
                          nil nil nil nil #'err #'ok)))

MyEval

<<myeval_evcond_9>>
<<myeval_evprogn_9>>
<<myeval_evand_9>>
<<myeval_evor_9>>
<<myeval_mypairlis_9>>
<<myeval_evlet_9>>
<<myeval_evletstar_9>>
<<myeval_evthrow_9>>
<<myeval_evtagbody_9>>
<<myeval_is_cont_subset_9>>
<<myeval_make_goenv_9>>
<<myeval_apply_go_continuation_9>>
(defun myeval (exp env block-env go-env catch-env errcont cont)
  (cond
    <<myeval_number_9>>
    <<myeval_symb_9>>
    <<myeval_quote_9>>
    <<myeval_if_9>>
    <<myeval_cond_9>>
    <<myeval_progn_9>>
    <<myeval_and_9>>
    <<myeval_or_9>>
    <<myeval_let_9>>
    <<myeval_letstar_9>>
    <<myeval_defun_9>>
    <<myeval_setq_9>>
    <<myeval_lambda_9>>
    <<myeval_block_9>>
    <<myeval_return_from_9>>
    <<myeval_catch_9>>
    <<myeval_throw_9>>
    <<myeval_tagbody_9>>
    <<myeval_go_9>>
    <<myeval_labels_9>>
    <<myeval_reset_9>>
    <<myeval_shift_9>>
    (t
     (myeval (car exp) env block-env go-env catch-env errcont
             (lambda (x)
               (evlis x (cdr exp) nil env block-env go-env catch-env errcont cont))))))

Тесты:

<<myeval_number_9_test>>
<<myeval_symb_9_test>>
<<myeval_quote_9_test>>
<<myeval_if_9_test>>
<<myeval_evcond_9_test>>
<<myeval_cond_9_test>>
<<myeval_evprogn_9_test>>
<<myeval_progn_9_test>>
<<myeval_evand_9_test>>
<<myeval_and_9_test>>
<<myeval_evor_9_test>>
<<myeval_or_9_test>>
<<myeval_mypairlis_9_test>>
<<myeval_evlet_9_test>>
<<myeval_let_9_test>>
<<myeval_evletstar_9_test>>
<<myeval_letstar_9_test>>
<<myeval_defun_9_test>>
<<myeval_setq_9_test>>
<<myeval_lambda_9_test>>
<<myeval_block_9_test>>
<<myeval_return_from_9_test>>
<<myeval_catch_9_test>>
<<myeval_throw_9_test>>
<<myeval_tagbody_9_test>>
<<myeval_go_9_test>>
<<myeval_labels_9_test>>
<<myeval_reset_9_test>>
<<myeval_shift_9_test>>

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

Замена funcall cont на apply-continuaation

((null exp)                  (apply-continuation cont 'nil))
((equal 't exp)              (apply-continuation cont 't))
((member exp '(+ * car cdr cons null print list call/cc repl))  (apply-continuation cont exp))
((numberp exp)               (apply-continuation cont exp))
;; Тесты для самовычисляемых форм
(assert (equal T (myeval 'T nil nil nil nil #'err #'ok)))
(assert (equal NIL (myeval 'NIL nil nil nil nil #'err #'ok)))
(assert (equal 999 (myeval 999 nil nil nil nil #'err #'ok)))

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

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

Цитирование

Замена funcall cont на apply-continauation

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

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

Определим структуру для сохранения продолжения if, которая будет унаследована от unicond:

(defstruct (if-cont (:include unicont))
  clauses
  env)

Теперь в myeval, будем создавать эту структуру и передавать её в качестве продолжения в myeval, вместо лямбды:

((equal (car exp) 'if)       (myeval (cadr exp) env block-env go-env catch-env errcont
                                     (make-if-cont
                                      :clauses exp
                                      :env env
                                      :block-env block-env
                                      :go-env go-env
                                      :catch-env catch-env
                                      :errcont errcont
                                      :cont cont)))

А саму логику из лямбды переместим в apply-continuation:

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

COND

Определим структуру для сохранения продолжения COND, которая будет унаследована от unicond:

(defstruct (evcond-cont (:include unicont))
  clauses
  env)

Теперь evcond, в случае получения непустого cond будет создавать эту структуру и передавать её в качестве продолжения в myeval, вместо лямбды:

(defun evcond (clauses env block-env go-env catch-env errcont cont)
  (cond ((null clauses)  (apply-continuation cont nil))
        (t               (myeval (caar clauses) env block-env go-env catch-env errcont
                                 (make-evcond-cont
                                  :clauses clauses
                                  :env env
                                  :block-env block-env
                                  :go-env go-env
                                  :catch-env catch-env
                                  :errcont errcont
                                  :cont cont)))))

А саму логику из лямбды переместим в apply-continuation:

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

PROGN

Определим структуру для сохранения продолжения progn, которая будет унаследована от unicond:

(defstruct (evprogn-cont (:include unicont))
  clauses
  env)

Теперь evprogn, имеет три варианта действий

  • если lst пуст, то вызвать продолжение, передав ему nil
  • если lst - список из одного элемента - вызвать myeval, передав ему этот элемент и свое продолжение
  • в ином случае - вызвать myeval, передав в качестве продолжения созданную структуру evprogn-cont вместо лямбды.
(defun evprogn (lst env block-env go-env catch-env errcont cont)
  (cond ((null lst)         (apply-continuation cont nil))
        ((null (cdr lst))   (myeval (car lst) env block-env go-env catch-env errcont cont))
        (t                  (myeval (car lst) env block-env go-env catch-env errcont
                                    (make-evprogn-cont
                                     :clauses lst
                                     :env env
                                     :block-env block-env
                                     :go-env go-env
                                     :catch-env catch-env
                                     :errcont errcont
                                     :cont cont)))))

А саму логику из лямбды переместим в apply-continuation:

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

AND

Определим структуру для сохранения продолжения AND, которая будет унаследована от unicond:

(defstruct (and-cont (:include unicont))
  exps
  env)

Теперь evand, в случае получения непустого списка аргументов будет создавать эту структуру и передавать её в качестве продолжения в myeval, вместо лямбды. Для единообразия мы переименовали args в exps.

(defun evand (exps env block-env go-env catch-env errcont cont)
  (cond ((null exps)       (apply-continuation cont T))
        ((null (cdr exps)) (myeval (car exps) env block-env go-env catch-env errcont cont))
        (t                 (myeval (car exps) env block-env go-env catch-env errcont
                                   (make-and-cont
                                    :exps (cdr exps)
                                    :env env
                                    :block-env block-env
                                    :go-env go-env
                                    :catch-env catch-env
                                    :errcont errcont
                                    :cont cont)))))

А саму логику из лямбды переместим в apply-continuation. В этот момент аргументы уже вычислены. Если аргумент ложный, то возвращаем применение продолжения к nil (потому что and возвращает nil, если встречает ложный аргумент). Это продолжение берем из структуры . В противном случае нам надо продолжить вычисление, оценивая другие формы. Для этого рекурсивно вызываем evand.

((and-cont-p cont)      (if (null arg)
                            (apply-continuation (and-cont-cont cont) nil)
                            (evand (and-cont-exps cont)
                                   (and-cont-env cont)
                                   (and-cont-block-env cont)
                                   (and-cont-go-env cont)
                                   (and-cont-catch-env cont)
                                   (and-cont-errcont cont)
                                   (and-cont-cont cont))))
;; Тесты для EVAND
(assert (equal (and)           (evand '() nil nil nil nil #'err #'ok)))
(assert (equal (and 1)         (evand '(1) nil nil nil nil #'err #'ok)))
(assert (equal (and nil)       (evand '(nil) nil nil nil  nil #'err #'ok)))
(assert (equal (and 1 nil)     (evand '(1 nil) nil nil nil nil #'err #'ok)))
(assert (equal (and 1 2 nil)   (evand '(1 2 nil) nil nil nil nil #'err #'ok)))
(assert (equal (and 1 2 3)     (evand '(1 2 3) nil nil nil nil #'err #'ok)))
(assert (equal (and 1 2 nil 3) (evand '(1 2 nil 3) nil nil nil nil #'err #'ok)))
;; Тесты для EVAND в окружении
(assert (equal (let ((a nil))
                 (and nil))
               (evand '(a) '((a . nil)) nil nil nil #'err #'ok)))
(assert (equal (let ((a 1))
                 (and a))
               (evand '(a) '((a . 1)) nil nil nil #'err #'ok)))
(assert (equal (let ((a 1)
                     (b nil))
                 (and a b))
               (evand '(a b) '((a . 1) (b . nil)) 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 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 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 nil #'err #'ok)))
((equal (car exp) 'and)      (evand (cdr exp)
                                    env block-env go-env catch-env
                                    errcont cont))
;; Тесты для AND
(assert (equal (and)                (myeval '(and) nil nil nil nil #'err #'ok)))
(assert (equal (and 1)              (myeval '(and 1) nil nil nil nil #'err #'ok)))
(assert (equal (and nil)            (myeval '(and nil) nil nil nil nil #'err #'ok)))
(assert (equal (and 1 nil)          (myeval '(and 1 nil) nil nil nil nil #'err #'ok)))
(assert (equal (and 1 2 nil)        (myeval '(and 1 2 nil) nil nil nil nil #'err #'ok)))
(assert (equal (and 1 2 3)          (myeval '(and 1 2 3) nil nil nil nil #'err #'ok)))
(assert (equal (and 1 (and 1 2) 3)  (myeval '(and 1 (and 1 2) 3) nil nil nil nil
                                            #'err #'ok)))
(assert (equal (and 1 (and 1 nil) 3)  (myeval '(and 1 (and 1 nil) 3) nil nil nil nil
                                              #'err #'ok)))
;; Тесты для AND в окружении
(assert (equal (let ((a nil))
                 (and nil))
               (myeval '(and a) '((a . nil)) nil nil nil #'err #'ok)))
(assert (equal (let ((a 1))
                 (and a))
               (myeval '(and a) '((a . 1)) nil nil nil #'err #'ok)))
(assert (equal (let ((a 1)
                     (b nil))
                 (and a b))
               (myeval '(and a b) '((a . 1) (b . nil)) 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 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 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 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 nil
                       #'err #'ok)))

OR

Определим структуру для сохранения продолжения OR, которая будет унаследована от unicond:

(defstruct (or-cont (:include unicont))
  exps
  env)

Теперь evor, в случае получения непустого списка параметров будет создавать эту структуру и передавать её в качестве продолжения в myeval, вместо лямбды. Для единообразия мы переименовали args в exps.

(defun evor (exps env block-env go-env catch-env errcont cont)
  (cond ((null exps)       (apply-continuation cont nil))
        ((null (cdr exps)) (myeval (car exps) env block-env go-env catch-env errcont cont))
        (t                 (myeval (car exps) env block-env go-env catch-env errcont
                                   (make-or-cont
                                    :exps (cdr exps)
                                    :env env
                                    :block-env block-env
                                    :go-env go-env
                                    :catch-env catch-env
                                    :errcont errcont
                                    :cont cont)))))

А саму логику из лямбды переместим в apply-continuation. В этот момент аргументы уже вычислены. Если аргумент истинный, то возвращаем применение продолжения к аргументу (потому что or возвращает свой аргумент). Это продолжение берем из структуры, . В противном случае нам надо продолжить вычисление, оценивая другие формы. Для этого рекурсивно вызываем evor.

((or-cont-p cont)       (if (not (null arg))
                            (apply-continuation (or-cont-cont cont) arg)
                            (evor (or-cont-exps cont)
                                  (or-cont-env cont)
                                  (or-cont-block-env cont)
                                  (or-cont-go-env cont)
                                  (or-cont-catch-env cont)
                                  (or-cont-errcont cont)
                                  (or-cont-cont cont))))
;; Тесты для EVOR
(assert (equal (or)                   (evor '() nil nil nil nil #'err #'ok)))
(assert (equal (or nil 1)             (evor '(nil 1) nil nil nil nil #'err #'ok)))
(assert (equal (or nil nil 1)         (evor '(nil nil 1) nil nil nil nil #'err #'ok)))
(assert (equal (or nil 1 2)           (evor '(nil 1 2) nil nil nil nil #'err #'ok)))
(assert (equal (or 1 2 3)             (evor '(1 2 3) nil nil nil nil #'err #'ok)))
(assert (equal (or nil nil 3 nil)     (evor '(nil nil 3 nil) nil nil nil nil #'err #'ok)))
;; Тесты для EVOR в окружении
(assert (equal (let ((a nil))
                 (or a))
               (evor '(a) '((a . nil)) nil nil nil #'err #'ok)))
(assert (equal (let ((a 1))
                 (or a))
               (evor '(a) '((a . 1)) nil nil nil #'err #'ok)))
(assert (equal (let ((a nil)
                     (b 1))
                 (or a b))
               (evor '(a b) '((a . nil) (b . 1)) nil 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 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 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 nil
                     #'err #'ok)))
((equal (car exp) 'or)       (evor  (cdr exp)
                                    env block-env go-env catch-env
                                    errcont cont))
;; Тесты для OR
(assert (equal (or)                  (myeval '(or) nil nil nil nil #'err #'ok)))
(assert (equal (or nil 1)            (myeval '(or nil 1) nil nil nil nil #'err #'ok)))
(assert (equal (or nil nil 1)        (myeval '(or nil nil 1) nil nil nil nil #'err #'ok)))
(assert (equal (or nil 1 2)          (myeval '(or nil 1 2) nil nil nil nil #'err #'ok)))
(assert (equal (or nil (or 3 2) 2)   (myeval '(or nil (or 3 2) 2) nil nil nil nil #'err #'ok)))
;; Тесты для OR в окружении
(assert (equal (let ((a nil))
                 (or a))
               (myeval '(or a) '((a . nil)) nil nil nil #'err #'ok)))
(assert (equal (let ((a 1))
                 (or a))
               (myeval '(or a) '((a . 1)) nil nil nil #'err #'ok)))
(assert (equal (let ((a nil)
                     (b 1))
                 (or a b))
               (myeval '(or a b) '((a . nil) (b . 1)) nil 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 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 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 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"))))

Определим структуру для сохранения продолжения let, которая будет унаследована от unicond:

(defstruct (evlet-cont (:include unicont))
  vars
  exps
  evald-exps
  exp
  env)

Теперь вместо передачи продолжения в виде лямбды мы будем передавать эту структуру:

(defun evlet (vars exps evald-exps exp env block-env go-env catch-env errcont cont)
  (cond ((null exps)  (evprogn exp
                               (pairlis vars (reverse evald-exps) env)
                               block-env go-env catch-env
                               errcont cont))
        (t            (myeval (car exps) env block-env go-env catch-env errcont
                              (make-evlet-cont
                               :vars vars
                               :exps exps
                               :evald-exps evald-exps
                               :exp exp
                               :env env
                               :block-env block-env
                               :go-env go-env
                               :catch-env catch-env
                               :errcont errcont
                               :cont cont)))))

А саму логику из лямбды переместим в apply-continuation:

((evlet-cont-p cont)    (evlet (evlet-cont-vars cont)
                               (cdr (evlet-cont-exps cont))
                               (cons arg (evlet-cont-evald-exps cont))
                               (evlet-cont-exp cont)
                               (evlet-cont-env cont)
                               (evlet-cont-block-env cont)
                               (evlet-cont-go-env cont)
                               (evlet-cont-catch-env cont)
                               (evlet-cont-errcont cont)
                               (evlet-cont-cont cont)))
;; Тесты для EVLET
(assert (equal 3 (evlet '(a b) '(1 2) nil '(4 (+ a b)) nil nil nil nil #'err #'ok)))
((equal (car exp) 'let)      (evlet (mapcar #'car (cadr exp))
                                    (mapcar #'cadr (cadr exp))
                                    nil
                                    (cddr exp)
                                    env block-env go-env catch-env
                                    errcont cont))
;; Тесты для LET
(assert (equal '(1 . 2) (myeval '(let ((a 1)
                                       (b 2))
                                  (cons a b))
                                  nil nil nil nil
                                  #'err #'ok)))

LET*

Определим структуру для сохранения продолжения letstar, которая будет унаследована от unicond:

(defstruct (evletstar-cont (:include unicont))
  varpairs
  exp
  env)

Теперь вместо передачи продолжения в виде лямбды мы будем передавать эту структуру:

(defun evletstar (varpairs exp env block-env go-env catch-env errcont cont)
  (cond ((null varpairs)  (evprogn exp env block-env go-env catch-env errcont cont))
        (t                (myeval (cadar varpairs) env block-env go-env catch-env errcont
                                  (make-evletstar-cont
                                   :varpairs varpairs
                                   :exp exp
                                   :env env
                                   :block-env block-env
                                   :go-env go-env
                                   :catch-env catch-env
                                   :errcont errcont
                                   :cont cont)))))

А саму логику из лямбды переместим в apply-continuation:

((evletstar-cont-p cont) (evletstar (cdr (evletstar-cont-varpairs cont))
                                    (evletstar-cont-exp cont)
                                    (acons (caar (evletstar-cont-varpairs cont))
                                           arg
                                           (evletstar-cont-env cont))
                                    (evletstar-cont-block-env cont)
                                    (evletstar-cont-go-env cont)
                                    (evletstar-cont-catch-env cont)
                                    (evletstar-cont-errcont cont)
                                    (evletstar-cont-cont cont)))
;; Тесты для EVLETSTAR
(assert (equal 2 (evletstar '((a 1) (b a)) '(4 (+ a b)) nil nil nil nil #'err #'ok)))
((equal (car exp) 'let*)     (evletstar (cadr exp)
                                        (cddr exp)
                                        env block-env go-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 nil #'err #'ok)))

DEFUN

Заменяем funcall cont на apply-continuation

((equal (car exp) 'defun)         (progn
                                    (push (cons (cadr exp)
                                                (make-closure :body (cdddr exp)
                                                              :block-env block-env
                                                              :env env
                                                              :go-env go-env
                                                              :args (caddr exp)))
                                          *glob-env*)
                                    (apply-continuation cont (cadr exp))))
;; Тесты для DEFUN
(assert (equal 64 (progn
                    (setf *glob-env* nil)
                    (myeval '(defun alfa (x) (* x x)) nil nil nil nil #'err #'ok)
                    (prog1 (myeval '(alfa 8) nil 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 nil #'err #'ok)
                     (prog1 (myeval '(alfa 8) nil nil nil nil #'err #'ok)
                       (setf *glob-env* nil)))))

SETQ

Определим структуру для сохранения продолжения setq, которая будет унаследована от unicond:

[TODO:gmm] Судя по дальнейшему коду unicont-поля не используются, откажемся?

(defstruct (setq-cont (:include unicont))
  clauses
  env)

Теперь в myeval, будем создавать эту структуру и передавать её в качестве продолжения в myeval, вместо лямбды:

((equal (car exp) 'setq)     (myeval (caddr exp) env block-env go-env catch-env errcont
                                     (make-setq-cont
                                      :clauses exp
                                      :env env
                                      :block-env block-env
                                      :go-env go-env
                                      :catch-env catch-env
                                      :errcont errcont
                                      :cont cont)))

А саму логику из лямбды переместим в apply-continuation, заменив funcall на apply-continuation:

((setq-cont-p cont)     (progn
                          (if (null (assoc (cadr (setq-cont-clauses cont))
                                           (setq-cont-env cont)))
                              ;; if-null
                              (if (null (assoc (cadr (setq-cont-clauses cont))
                                               *glob-env*))
                                  ;; then
                                  (push (cons (cadr (setq-cont-clauses cont))
                                              arg)
                                        *glob-env*)
                                  ;; else
                                  (rplacd (assoc (cadr (setq-cont-clauses cont))
                                                 *glob-env*)
                                          arg))
                              ;; if-not-null
                              (rplacd (assoc (cadr (setq-cont-clauses cont))
                                             (setq-cont-env cont))
                                      arg))
                          (apply-continuation (setq-cont-cont cont) arg)))
;; Тесты для 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 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 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 nil #'err #'ok)
                              *glob-env*)
                   (setf *glob-env* nil)))))

LAMBDA

Заменяем funcall cont на apply-continuation

;; стало
((equal (car exp) 'lambda)   (apply-continuation cont (make-closure :body (cddr exp)
                                                                    :block-env block-env
                                                                    :env env
                                                                    :go-env go-env
                                                                    :args (cadr exp))))
;; Тесты для LAMBDA
(assert (equal 3 (myeval '((lambda (x) (+ 1  x)) 2)
                         nil nil nil nil #'err #'ok)))
;; Тесты для LAMBDA в окружении
(assert (equal 5 (myeval '(let ((y 3))
                           ((lambda (x) (+ y x)) 2))
                         nil 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 nil #'err #'ok)))

BLOCK

Нет лямбды - не нужно дефункционализировать

((equal (car exp) 'block)    (myeval (caddr exp)
                                     env
                                     (acons (cadr exp)
                                            cont
                                            block-env)
                                     go-env catch-env errcont cont))
;; Тесты для BLOCK
(assert (equal nil (myeval '(block testblock)
                           nil nil nil nil #'err #'ok)))
(assert (equal 3 (myeval '(block testblock 3)
                         nil nil nil nil #'err #'ok)))

RETURN-FROM

С нашей текущей реализацией block/return-from есть одна проблема, которая проявляется так: если присвоить внешней переменой значение какой-нибудь функции, которая захватывает block, то таким образом можно сэмулировать call/cc.

В семантике Common Lisp return-from при выходе из блока, который уже закрыт должен возвращать ошибку. В Common Lisp продолжение, создаваемое block ограничено локально. Для того чтобы это реализовать необходимо, что return-from проверял, вышли мы из блока или нет. Этого нельзя достичь до того как мы сделали дефункционализацию. Но теперь мы можем пройтись по цепочке продолжений и посмотреть, достижимо ли из точки, в которой мы находимся продолжение, в которое мы хотим попасть при выполнении return-from. Для этого нам нужна функция, которая проходит по цепочке продолжений. Назовем ее is-cont-subset. Она будет принимать два продолжения и должна будет проверить, если ли первое продолжение во втором. По сути это похоже на sublis только для продолжений.

(defun is-cont-subset (target-cont cont)
  (cond ((equal target-cont cont) t)    ;; positive
        ((functionp cont) nil)          ;; negative
        (t (is-cont-subset target-cont (cdr cont)))))

Для остановки рекурсии и возврата отрицательного ответа (nil) мы будем использовать то, что у нас есть identity-продолжение, которое представлено как функция. В будущем, когда мы полностью откажемся от представления продолжений в виде функций мы заменим в этой строчке functionp на явное сравнение с оконечным продолжением. Важно отметить, что сравнение (equal target-cont cont) должно идти раньше чем (functionp cont) по той причине, что они могут совпадать и при этом оба быть функциями.

Теперь приступим к преобразованию return-from. Сначала заменяем funcall на apply-continuation - это преобразование уже нам знакомо:

;; стало
((equal (car exp) 'return-from)
                             (if (not (symbolp (cadr exp)))
                                 (apply-continuation
                                  errcont
                                  (format nil "return-from: first argument not a symbol"))
                                 (myeval (caddr exp) env block-env go-env catch-env errcont
                                         (lambda (x)
                                           (assoc-2 (cadr exp) block-env
                                                    (lambda (y) (apply-continuation y x))
                                                    (lambda (y) (apply-continuation
                                                                 errcont
                                                                 (format nil "return-from: undefined return block ~A" y))))))))
;; было
((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 go-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))))))))

Потом выполним кое-что поинтереснее. Когда assoc-2 находит целевое продолжение return-from он вызывает свое первое продолжение success. В этом продолжении мы можем проверить, достижимо ли целевое продолжение y в x. Если да - то делаем apply-continuation, иначе - применяем error-продолжение, потому что это ошибка недостижимости.

((equal (car exp) 'return-from)
                             (if (not (symbolp (cadr exp)))
                                 (apply-continuation
                                  errcont (format nil "return-from: first argument not a symbol"))
                                 (myeval (caddr exp) env block-env go-env catch-env errcont
                                         (lambda (x)
                                           (assoc-2 (cadr exp) block-env
                                                    (lambda (y)
                                                      (if (is-cont-subset y cont)
                                                          (apply-continuation y x)
                                                          (apply-continuation
                                                           errcont
                                                           (format nil "return-from: attempt to RETURN-FROM to ~A that no longer exists" (cadr exp)))))
                                                    (lambda (y)
                                                      (apply-continuation
                                                       errcont (format nil "return-from: undefined return block ~A" y))))))))

[TODO:gmm] продолжить дефункционализацию?

Добавляем тест на ошибку недостижимого блока. Для этого заставим return-from возвратить тот блок из которого он только что вышел. Аналогично проверяем, что эта ошибка не срабатывает в корректных блоках.

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

CATCH

Определим структуру для сохранения продолжения catch, которая будет унаследована от unicond:

(defstruct (catch-cont (:include unicont))
  clauses
  env)

Теперь в myeval, будем создавать эту структуру и передавать её в качестве продолжения в myeval, вместо лямбды:

((equal (car exp) 'catch)    (myeval (cadr exp) env block-env go-env catch-env errcont
                                     (make-catch-cont
                                      :clauses exp
                                      :env env
                                      :block-env block-env
                                      :go-env go-env
                                      :catch-env catch-env
                                      :errcont errcont
                                      :cont cont)))

А саму логику из лямбды переместим в apply-continuation, заменяя вызов продолжения через funcall на вызов через apply-continuation

((catch-cont-p cont)    (if (not (symbolp arg))
                            (apply-continuation
                             errcont
                             (format nil "catch: first argument not a symbol"))
                            (myeval (caddr (catch-cont-clauses cont))
                                    (catch-cont-env cont)
                                    (catch-cont-block-env cont)
                                    (catch-cont-go-env cont)
                                    (acons arg
                                           (catch-cont-cont cont)
                                           (catch-cont-catch-env cont))
                                    (catch-cont-errcont cont)
                                    (catch-cont-cont cont))))
;; Тесты для CATCH
(assert (equal nil (myeval '(catch 'zzz)
                           nil nil nil nil #'err #'ok)))
(assert (equal 3 (myeval '(catch 'zzz 3)
                         nil nil nil nil #'err #'ok)))

THROW

Определим структуру для сохранения продолжения throw, которая будет унаследована от unicond:

(defstruct (throw-cont (:include unicont))
  clauses
  env)

Теперь в evthrow, которая вызывается из myeval, будем создавать эту структуру и передавать её в качестве продолжения в myeval, вместо лямбды:

(defun evthrow (exp env block-env go-env catch-env errcont cont)
  (myeval (cadr exp) env block-env go-env catch-env errcont
          (make-throw-cont
           :clauses exp
           :env env
           :block-env block-env
           :go-env go-env
           :catch-env catch-env
           :errcont errcont
           :cont cont)))
((equal (car exp) 'throw)    (evthrow exp
                                      env block-env go-env catch-env
                                      errcont cont))

А саму логику из лямбды переместим в apply-continuation:

((throw-cont-p cont)    (myeval (caddr (throw-cont-clauses cont))
                                (throw-cont-env cont)
                                (throw-cont-block-env cont)
                                (throw-cont-go-env cont)
                                (throw-cont-catch-env cont)
                                (throw-cont-errcont cont)
                                (make-throw2-cont
                                 :prev-arg arg
                                 :catch-env catch-env
                                 :errcont errcont
                                (lambda (exp-res)
                                  (assoc-2 arg catch-env
                                           (lambda (cont-res)
                                             (apply-continuation cont-res exp-res))
                                           (lambda (key)
                                             (apply-continuation errcont
                                                      (format
                                                       nil
                                                       "throw: matching ~A catch is not found"
                                                       key)))))))

Продолжения передаваемые в assoc-2 не надо дефункционализировать, т.к. продолжения тут используются для выражения полупредиката. А вот оборачивающую лямбду дефункционализировать придется, поэтому создаем для нее еще одну структуру:

(defstruct throw2-cont
  prev-arg
  catch-env
  errcont)

Соответственно добавляем обработку этой структуры в apply-continuation:

((throw2-cont-p cont)   (assoc-2 (throw2-cont-prev-arg cont)
                                 (throw2-cont-catch-env cont)
                                 (lambda (cont-res)
                                   (apply-continuation cont-res arg))
                                 (lambda (key)
                                   (apply-continuation (throw2-cont-errcont cont)
                                            (format
                                             nil
                                             "throw: matching ~A catch is not found"
                                             key)))))

Тогда получается так:

((throw-cont-p cont)    (myeval (caddr (throw-cont-clauses cont))
                                (throw-cont-env cont)
                                (throw-cont-block-env cont)
                                (throw-cont-go-env cont)
                                (throw-cont-catch-env cont)
                                (throw-cont-errcont cont)
                                (make-throw2-cont
                                 :prev-arg arg
                                 :catch-env (throw-cont-catch-env cont)
                                 :errcont (throw-cont-errcont cont))))
;; Тесты для THROW
(assert (equal 3 (myeval '(catch 'testcatch (throw 'testcatch (+ 1 2)) 777)
                         nil nil nil nil #'err #'ok)))
(assert (equal "error" (myeval '(catch 'testcatch (throw 'notcatch (+ 1 2)) 777)
                               nil nil nil nil
                               #'(lambda (x) "error")
                               #'ok)))
(assert (equal "error" (myeval '(progn (throw 'not-found-catch (+ 1 2)) 777)
                               nil nil nil nil (lambda (x) "error")
                               #'ok)))
;; Тест THROW в лексической области видимости
(assert (equal 12 (progn
                    (setf *glob-env* nil)
                    (prog1 (myeval '(progn
                                     (defun foo (x)
                                       (catch 'in-lambda-catch
                                         (throw 'in-lambda-catch
                                           (+ x 2))
                                         777))
                                     (foo 10))
                                   nil nil nil nil (lambda (x) "error")
                                   #'ok)
                      (setf *glob-env* nil)))))
;; Тест THROW в динамической области видимости (должно сработать)
(assert (equal 12 (progn
                    (setf *glob-env* nil)
                    (prog1 (myeval '(progn
                                     (defun foo (x)
                                       (throw 'in-lambda-catch
                                         (+ x 2))
                                       777)
                                     (catch 'in-lambda-catch
                                       (foo 10)))
                                   nil nil nil nil (lambda (x) "error")
                                   #'ok)
                      (setf *glob-env* nil)))))

TAGBODY

(defun tagbody-slice (exp res)
  (cond ((null exp) res)
        ((symbolp (car exp))  (tagbody-slice (cdr exp) (cons exp res)))
        (t                    (tagbody-slice (cdr exp) res))))
(defun tagbody-check-tag (exp cont errcont)
  (cond ((null exp) (funcall cont))
        ((and (symbolp (car exp))
              (member (car exp) (cdr exp)))
         (funcall errcont (car exp)))
        (t (tagbody-check-tag (cdr exp) cont errcont))))

Определим структуру для сохранения продолжения TAGBODY, которая будет унаследована от unicond:

(defstruct (evtagbody-cont (:include unicont))
  body
  env)

Теперь evtagbody, в случае получения непустого body будет создавать эту структуру и передавать её в качестве продолжения в myeval, вместо лямбды:

<<tagbody_check_tag_9>>
(defun evtagbody (body env block-env go-env catch-env errcont cont)
  (cond ((null (car body))      (apply-continuation cont nil))
        ((symbolp (car body))   (evtagbody (cdr body) env block-env go-env catch-env errcont cont))
        (t                      (myeval (car body) env block-env go-env catch-env errcont
                                        (make-evtagbody-cont
                                         :body (cdr body)
                                         :env  env
                                         :block-env block-env
                                         :go-env go-env
                                         :catch-env catch-env
                                         :errcont errcont
                                         :cont cont)))))
<<tagbody_slice_9>>

Теперь перейдем к вызову. Напомним, для ориентира, как выглядит обработка tagbody-формы в myeval:

((equal (car exp) 'tagbody)  (tagbody-check-tag
                              (cdr exp)
                              (lambda ()
                                (setq go-env
                                      (append (mapcar #'(lambda (x)
                                                          (cons (car x)
                                                                (lambda ()
                                                                  (evtagbody x
                                                                             env
                                                                             block-env
                                                                             go-env
                                                                             catch-env
                                                                             errcont cont))))
                                                      (tagbody-slice (cdr exp) nil))
                                              go-env))
                                (evtagbody (cdr exp) env block-env go-env catch-env errcont cont))
                              (lambda (x)
                                (apply-continuation
                                 errcont
                                 (format
                                  nil
                                  "tagbody: The tag ~A appears more than once in a tagbody" x)))))

Продолжая дефункционализацию нам надо преобразовать лямбду, которая вызывает evtagbody (самую глубокую по уровню в примере выше). Преобразуем ее в структуру, которую назовем go-cont. Помимо unicont-полей она будет содержать env и свой slice:

(defstruct (go-cont (:include unicont))
  slice
  env)

Поднимаясь до уровня append мы делаем список таких структур. Но тогда у нас будет выпадать go-env, потому что: пока мы не сделали окружение мы не можем его записать в go-env, т.е цикличности не получится.

Поэтому мы применим тот же трюк что и с labels: мы сделаем все окружения, а потом пройдемся по ним и setf-ом изменим поле go-env в них. Для удобства мы дефункционализируем не всю лямбду, а ее часть, соответствующую содержимому формы setq. Назовем этот кусок make-go-env.

(defun make-go-env (tagbody-body env block-env go-env catch-env errcont cont)
  (let* ((conts (mapcar #'(lambda (x) ;; продолжения, нарезанные из tagbody
                            (make-go-cont
                             :slice x
                             :env env
                             :block-env block-env
                             :go-env go-env ;; этот слот будем setf-эфить
                             :catch-env  catch-env
                             :errcont errcont
                             :cont cont))
                        (tagbody-slice tagbody-body nil)))
         ;; пары (символ . продолжение) нарезанные из
         ;; tagbody и добавленные в окружение
         (new-go-env (append (mapcar #'(lambda (go-cont)
                                         (cons (car (go-cont-slice go-cont))
                                               go-cont))
                                     conts)
                             go-env)))
    ;; изменяем поля go-env, записывая в них new-go-env
    ;; во всех созданных продолжениях
    (loop :for elt-cont :in conts :do
       (setf (go-cont-go-env elt-cont)
             new-go-env))
    ;; возвращаем новое окружение
    new-go-env))

Также нам нужна функция, которая будет go-cont применять, она будет вызывать evtagbody - мы просто переносём логику самой глубокой лямбды в нее. Эта функция будет вызываться при обработке формы go. Она просто вызывает evtagbody, которая просто проходит по телу tagbody и выполняет все формы, отбрасывая метки.

Мы могли бы применять go-cont как обычное продолжение, и тогда мы бы добавили его в apply-continuation. Но лучше сделать для него отдельную функцию, потому что go-cont отличается от всех остальных продолжений тем, что у него нет параметров.

(defun apply-go-continuation (go-cont)
  (evtagbody (go-cont-slice go-cont)
             (go-cont-env go-cont)
             (go-cont-block-env go-cont)
             (go-cont-go-env go-cont)
             (go-cont-catch-env go-cont)
             (go-cont-errcont go-cont)
             (go-cont-cont go-cont)))

Теперь в myeval мы должны:

  • Заменить funcall на apply-continuation
  • Заменить форму setf на вызов evtagbody, в котором для формирования окружения go-env вызовем make-go-env.
((equal (car exp) 'tagbody)  (tagbody-check-tag
                              (cdr exp)
                              (lambda ()
                                (evtagbody (cdr exp) env block-env
                                           (make-go-env (cdr exp)
                                                        env block-env go-env catch-env
                                                        errcont cont)
                                           catch-env errcont cont))
                              (lambda (x)
                                (apply-continuation
                                 errcont
                                 (format
                                  nil
                                  "tagbody: The tag ~A appears more than once in a tagbody"
                                  x)))))

Теперь добавим в apply-continuation обработку evtagbody-cont:

((evtagbody-cont-p cont) (evtagbody (evtagbody-cont-body cont)
                                    (evtagbody-cont-env cont)
                                    (unicont-block-env cont)
                                    (unicont-go-env cont)
                                    (unicont-catch-env cont)
                                    (unicont-errcont cont)
                                    (unicont-cont cont)))
;; Тесты для TAGBODY
(assert (equal nil (myeval '(tagbody a 1)
                           nil nil nil nil #'err #'ok)))
(assert (equal nil (myeval '(tagbody a 1 b 2)
                           nil nil nil nil #'err #'ok)))

GO

Заменяем funcall на (apply-continuation x 'NOT-A-PARAM). А потом сразу же заменяем его на apply-go-continuation, определенный в разделе tagbody.

[TODO:gmm] В следующем файле перенести определение apply-go-continuation сюда.

;; стало
((equal (car exp) 'go)       (assoc-2 (cadr exp) go-env
                                      (lambda (go-cont)
                                        (apply-go-continuation go-cont))
                                      (lambda (go-label)
                                        (apply-continuation
                                         errcont
                                         (format nil "go: wrong target ~A" go-label)))))
;; промежуточный вариант
((equal (car exp) 'go)       (assoc-2 (cadr exp) go-env
                                      (lambda (x)
                                        (apply-continuation x 'NOT-A-PARAM))
                                      (lambda (x)
                                        (apply-continuation
                                         errcont
                                         (format nil "go: wrong target ~A" x)))))
;; было
((equal (car exp) 'go)       (assoc-2 (cadr exp) go-env
                                      (lambda (x)
                                        (funcall x))
                                      (lambda (x)
                                        (funcall
                                         errcont
                                         (format nil "go: wrong target ~A" x)))))
;; Тесты для GO
(assert (equal '(1 . 4) (myeval '(let ((alfa 0))
                                  (tagbody
                                   a (setq alfa 1)
                                   b (go d)
                                   c (setq alfa (cons alfa 3))
                                   d (setq alfa (cons alfa 4)))
                                  alfa)
                                nil nil nil nil #'err #'ok)))
;; Тесты для "обратного хода" GO
(assert (equal '(1 . 5) (myeval '(let ((alfa 0))
                                  (tagbody
                                   a (go d)
                                   b (setq alfa 1)
                                   c (go e)
                                   d (go b)
                                   e (setq alfa (cons alfa 5)))
                                  alfa)
                                nil nil nil nil #'err #'ok)))

LABELS

((equal (car exp) 'labels)   (let* ((alist (mapcar (lambda (label) ;; формируем список пар (имя . nil)
                                                     (cons (car label) nil))
                                                   (cadr exp)))
                                    (new-env (append alist env))   ;; добавим к списку пар предыдущее окружение
                                    (closures (mapcar (lambda (label)
                                                        ;; создаем замыкание, указывающее (env) на созданные переменные (содержащие пока nil)
                                                        (make-closure :body (cddr label) ;; implicit progn
                                                                      :block-env block-env
                                                                      :env new-env
                                                                      :go-env go-env
                                                                      :args (cadr label)))
                                                      (cadr exp))))
                               ;; alist:    '((zzz . nil) (xxx . nil))
                               ;; new-env:  '((zzz . nil) (xxx . nil) (old . #:closure))
                               ;; closures: '(#:closure #:closure) ;; у этих замыканий :env указывает на new-env
                               (assert (equal (length alist) (length closures)))
                               (loop
                                  :for aelt     :in alist
                                  :for closure  :in closures
                                  :do (rplacd aelt closure))
                               ;; получаем:
                               ;; alist:    '((zzz . #:closure) (xxx . #:closure))
                               ;; И передаем new-env в качестве окружения
                               (evprogn (cddr exp) new-env block-env go-env catch-env errcont cont)))
;; Тесты для LABELS
(assert (equal (labels ((zzz (lst acc)
                          (print acc)
                          (cond ((null lst) acc)
                                (t (zzz (cdr lst) (+ 1 acc))))))
                 (print 888)
                 (zzz '(1 2 3) 0))
               (myeval '(labels ((zzz (lst acc)
                                  (print acc)
                                  (cond ((null lst) acc)
                                        (t (zzz (cdr lst) (+ 1 acc))))))
                         (print 888)
                         (zzz '(1 2 3) 0))
                         nil nil nil nil #'err #'ok)))
(assert (equal (with-output-to-string (*standard-output*)
                 (labels ((zzz (lst acc)
                            (print acc)
                            (cond ((null lst) acc)
                                  (t (zzz (cdr lst) (+ 1 acc))))))
                   (print 888)
                   (zzz '(1 2 3) 0)))
               (with-output-to-string (*standard-output*)
                 (myeval '(labels ((zzz (lst acc)
                                    (print acc)
                                    (cond ((null lst) acc)
                                          (t (zzz (cdr lst) (+ 1 acc))))))
                           (print 888)
                           (zzz '(1 2 3) 0))
                         nil nil nil nil #'err #'identity))))

RESET

Заменяем funcall на apply-continuation

((equal (car exp) 'reset)    (apply-continuation cont (myeval (cadr exp)
                                                              env block-env go-env catch-env
                                                              errcont #'identity)))
;; Тесты для RESET
(assert (equal 8 (myeval '(progn
                            (+ 1 (reset (+ 2 3)) 2))
                            nil nil nil nil #'err #'ok)))

SHIFT

((equal (car exp) 'shift)    (myeval (caddr exp)
                                     (acons (cadr exp) cont env)
                                     block-env go-env catch-env
                                     errcont cont))
;; Тесты для SHIFT/RESET
(assert (equal 44 (myeval '(let ((foo))
                            (+ 1 (reset (+ 2 (shift f (progn (setq foo f) 4)))))
                            (foo 42))
                          nil nil nil nil #'err #'ok)))

REPL

(defun repl (prompt catch-env errcont cont)
  (format t "~%~A> " prompt)
  (finish-output)
  (myeval (read) nil nil nil (acons 'exit cont catch-env)
    #'(lambda (x)
        (princ x)
        (terpri)
        (finish-output)
        (repl prompt catch-env errcont cont))
    #'(lambda (x)
        (princ x)
        (terpri)
        (finish-output)
        (repl prompt catch-env errcont cont))))

Итоги

(setq *print-circle* T)
;; Классы ошибок
<<errors_9>>
;; Структуры
<<unicont_9>>
;; APPLY-CONTINUATION
<<apply_continuation_9>>
;; CPS-версия ASSOC
<<assoc_9>>
;; Новая функция lookup
<<lookup_9>>
;; Структура замыкания
<<closure_9>>
;; CPS-вариант MYAPPLY и все что к нему относится
<<myapply_9>>
;; CPS-вариант MYEVAL и все что к нему относится
<<myeval_9>>
;; Тестируем новый lookup
<<lookup_9_test>>
;; Функции для тестирования CPS-функций
<<ok_err_9>>
;; Тесты для MYAPPLY
<<myapply_9_test>>
;; Тесты для MYEVAL
<<myeval_9_test>>
;; REPL
<<repl_9>>
;; (repl)

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

(setq *print-circle* T)
;; Классы ошибок
(define-condition unknown-continuation (error)
  ((cont :initarg :cont  :reader cont))
  (:report
   (lambda (condition stream)
     (format stream "Error in APPLY-CONTINUATION: unknown-continuation: ~A"
             (cont condition)))))
(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)))))
;; Структуры
(defstruct unicont
  block-env
  go-env
  catch-env
  errcont
  cont)
(defstruct (evlis-cont (:include unicont))
  fn
  unevaled
  evaled
  env)
(defstruct (if-cont (:include unicont))
  clauses
  env)
(defstruct (evcond-cont (:include unicont))
  clauses
  env)
(defstruct (evprogn-cont (:include unicont))
  clauses
  env)
(defstruct (and-cont (:include unicont))
  exps
  env)
(defstruct (or-cont (:include unicont))
  exps
  env)
(defstruct (evlet-cont (:include unicont))
  vars
  exps
  evald-exps
  exp
  env)
(defstruct (evletstar-cont (:include unicont))
  varpairs
  exp
  env)
(defstruct (setq-cont (:include unicont))
  clauses
  env)
(defstruct (catch-cont (:include unicont))
  clauses
  env)
(defstruct (throw-cont (:include unicont))
  clauses
  env)
(defstruct throw2-cont
  prev-arg
  catch-env
  errcont)
(defstruct (evtagbody-cont (:include unicont))
  body
  env)
(defstruct (go-cont (:include unicont))
  slice
  env)
;; APPLY-CONTINUATION
(defun apply-continuation (cont arg)
  (cond ((functionp cont)       (funcall cont arg))
        ((if-cont-p cont)       (if arg
                                    (myeval (caddr (if-cont-clauses cont))
                                            (if-cont-env cont)
                                            (if-cont-block-env cont)
                                            (if-cont-go-env cont)
                                            (if-cont-catch-env cont)
                                            (if-cont-errcont cont)
                                            (if-cont-cont cont))
                                    (myeval (cadddr (if-cont-clauses cont))
                                            (if-cont-env cont)
                                            (if-cont-block-env cont)
                                            (if-cont-go-env cont)
                                            (if-cont-catch-env cont)
                                            (if-cont-errcont cont)
                                            (if-cont-cont cont))))
        ((evcond-cont-p cont)   (if arg
                                    (myeval (cadar (evcond-cont-clauses cont))
                                            (evcond-cont-env cont)
                                            (evcond-cont-block-env cont)
                                            (evcond-cont-go-env cont)
                                            (evcond-cont-catch-env cont)
                                            (evcond-cont-errcont cont)
                                            (evcond-cont-cont cont))
                                    (evcond (cdr (evcond-cont-clauses cont))
                                            (evcond-cont-env cont)
                                            (evcond-cont-block-env cont)
                                            (evcond-cont-go-env cont)
                                            (evcond-cont-catch-env cont)
                                            (evcond-cont-errcont cont)
                                            (evcond-cont-cont cont))))
        ((evprogn-cont-p cont)  (evprogn (cdr (evprogn-cont-clauses cont))
                                         (evprogn-cont-env cont)
                                         (evprogn-cont-block-env cont)
                                         (evprogn-cont-go-env cont)
                                         (evprogn-cont-catch-env cont)
                                         (evprogn-cont-errcont cont)
                                         (evprogn-cont-cont cont)))
        ((evcond-cont-p cont)   (if arg
                                    (myeval (cadar (evcond-cont-clauses cont))
                                            (evcond-cont-env cont)
                                            (evcond-cont-block-env cont)
                                            (evcond-cont-go-env cont)
                                            (evcond-cont-catch-env cont)
                                            (evcond-cont-errcont cont)
                                            (evcond-cont-cont cont))
                                    (evcond (cdr (evcond-cont-clauses cont))
                                            (evcond-cont-env cont)
                                            (evcond-cont-block-env cont)
                                            (evcond-cont-go-env cont)
                                            (evcond-cont-catch-env cont)
                                            (evcond-cont-errcont cont)
                                            (evcond-cont-cont cont))))
        ((evprogn-cont-p cont)  (evprogn (cdr (evprogn-cont-clauses cont))
                                         (evprogn-cont-env cont)
                                         (evprogn-cont-block-env cont)
                                         (evprogn-cont-go-env cont)
                                         (evprogn-cont-catch-env cont)
                                         (evprogn-cont-errcont cont)
                                         (evprogn-cont-cont cont)))
        ((and-cont-p cont)      (if (null arg)
                                    (apply-continuation (and-cont-cont cont) nil)
                                    (evand (and-cont-exps cont)
                                           (and-cont-env cont)
                                           (and-cont-block-env cont)
                                           (and-cont-go-env cont)
                                           (and-cont-catch-env cont)
                                           (and-cont-errcont cont)
                                           (and-cont-cont cont))))
        ((or-cont-p cont)       (if (not (null arg))
                                    (apply-continuation (or-cont-cont cont) arg)
                                    (evor (or-cont-exps cont)
                                          (or-cont-env cont)
                                          (or-cont-block-env cont)
                                          (or-cont-go-env cont)
                                          (or-cont-catch-env cont)
                                          (or-cont-errcont cont)
                                          (or-cont-cont cont))))
        ((evlet-cont-p cont)    (evlet (evlet-cont-vars cont)
                                       (cdr (evlet-cont-exps cont))
                                       (cons arg (evlet-cont-evald-exps cont))
                                       (evlet-cont-exp cont)
                                       (evlet-cont-env cont)
                                       (evlet-cont-block-env cont)
                                       (evlet-cont-go-env cont)
                                       (evlet-cont-catch-env cont)
                                       (evlet-cont-errcont cont)
                                       (evlet-cont-cont cont)))
        ((evletstar-cont-p cont) (evletstar (cdr (evletstar-cont-varpairs cont))
                                            (evletstar-cont-exp cont)
                                            (acons (caar (evletstar-cont-varpairs cont))
                                                   arg
                                                   (evletstar-cont-env cont))
                                            (evletstar-cont-block-env cont)
                                            (evletstar-cont-go-env cont)
                                            (evletstar-cont-catch-env cont)
                                            (evletstar-cont-errcont cont)
                                            (evletstar-cont-cont cont)))
        ((setq-cont-p cont)     (progn
                                  (if (null (assoc (cadr (setq-cont-clauses cont))
                                                   (setq-cont-env cont)))
                                      ;; if-null
                                      (if (null (assoc (cadr (setq-cont-clauses cont))
                                                       *glob-env*))
                                          ;; then
                                          (push (cons (cadr (setq-cont-clauses cont))
                                                      arg)
                                                *glob-env*)
                                          ;; else
                                          (rplacd (assoc (cadr (setq-cont-clauses cont))
                                                         *glob-env*)
                                                  arg))
                                      ;; if-not-null
                                      (rplacd (assoc (cadr (setq-cont-clauses cont))
                                                     (setq-cont-env cont))
                                              arg))
                                  (apply-continuation (setq-cont-cont cont) arg)))
        ((catch-cont-p cont)    (if (not (symbolp arg))
                                    (apply-continuation
                                     errcont
                                     (format nil "catch: first argument not a symbol"))
                                    (myeval (caddr (catch-cont-clauses cont))
                                            (catch-cont-env cont)
                                            (catch-cont-block-env cont)
                                            (catch-cont-go-env cont)
                                            (acons arg
                                                   (catch-cont-cont cont)
                                                   (catch-cont-catch-env cont))
                                            (catch-cont-errcont cont)
                                            (catch-cont-cont cont))))
        ((throw-cont-p cont)    (myeval (caddr (throw-cont-clauses cont))
                                        (throw-cont-env cont)
                                        (throw-cont-block-env cont)
                                        (throw-cont-go-env cont)
                                        (throw-cont-catch-env cont)
                                        (throw-cont-errcont cont)
                                        (make-throw2-cont
                                         :prev-arg arg
                                         :catch-env (throw-cont-catch-env cont)
                                         :errcont (throw-cont-errcont cont))))
        ((throw2-cont-p cont)   (assoc-2 (throw2-cont-prev-arg cont)
                                         (throw2-cont-catch-env cont)
                                         (lambda (cont-res)
                                           (funcall cont-res arg))
                                         (lambda (key)
                                           (funcall (throw2-cont-errcont cont)
                                                    (format
                                                     nil
                                                     "throw: matching ~A catch is not found"
                                                     key)))))
        ((evtagbody-cont-p cont) (evtagbody (evtagbody-cont-body cont)
                                            (evtagbody-cont-env cont)
                                            (unicont-block-env cont)
                                            (unicont-go-env cont)
                                            (unicont-catch-env cont)
                                            (unicont-errcont cont)
                                            (unicont-cont cont)))
        ((evlis-cont-p cont)    (evlis (evlis-cont-fn cont)
                                       (cdr (evlis-cont-unevaled cont))
                                       (cons arg (evlis-cont-evaled cont))
                                       (evlis-cont-env cont)
                                       (unicont-block-env cont)
                                       (unicont-go-env cont)
                                       (unicont-catch-env cont)
                                       (unicont-errcont cont)
                                       (unicont-cont cont)))
        (t (error 'unknown-continuation :cont cont))))
;; CPS-версия ASSOC
(defun assoc-2 (key alist success failure) ;; NB!: inverted order of
                                           ;; successinuations (for lookup)
  (cond ((null alist)              (funcall failure key))
        ((equal key (caar alist))  (funcall success (cdar alist)))
        (t                         (assoc-2 key (cdr alist) success failure))))
;; Новая функция lookup
;; environment
(defparameter *glob-env* nil)
(defun lookup (symb env errcont cont)
  (assoc-2 symb env
           (lambda (x)
             (apply-continuation cont x))
           (lambda (key)
             (assoc-2 key *glob-env*
                      (lambda (x) ;; возможно ошибка (была) тут
                        (apply-continuation cont x))
                      (lambda (key)
                        (apply-continuation
                         errcont
                         (format
                          nil "UNBOUD VARIABLE [~A] ~%LOCAL ENV: [~A] ~%GLOBAL ENV: [~A]"
                          key env *glob-env*)))))))
;; Структура замыкания
(defstruct closure
  body
  env
  block-env
  go-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 go-env catch-env errcont cont)
  (cond ((null unevaled)  (myapply fn (reverse evaled) catch-env errcont cont))
        (t                (myeval (car unevaled) env block-env go-env catch-env errcont
                                  (make-evlis-cont
                                   :fn fn
                                   :unevaled unevaled
                                   :evaled evaled
                                   :env env
                                   :block-env block-env
                                   :go-env go-env
                                   :catch-env catch-env
                                   :errcont errcont
                                   :cont cont)))))
(defun myapply (fn args catch-env errcont cont)
  (cond
    ((equal fn 'car)             (apply-continuation cont (caar args)))
    ((equal fn 'cdr)             (apply-continuation cont (cdar args)))
    ((equal fn 'cons)            (apply-continuation cont (cons (car args) (cadr args))))
    ((equal fn 'null)            (if (null (cdr args))
                                     (apply-continuation cont (null (car args)))
                                     (error 'invalid-number-of-arguments :fn fn)))
    ((equal fn '+)               (apply-continuation cont (evadd args 0)))
    ((equal fn '*)               (apply-continuation cont (evmul args 1)))
    ((closure-p fn)              (evprogn (closure-body fn)
                                          (pairlis (closure-args fn)
                                                   args
                                                   (closure-env fn))
                                          (closure-block-env fn)
                                          (closure-go-env fn)
                                          catch-env
                                          errcont cont))
    ((equal fn 'print)           (apply-continuation cont (print (car args))))
    ((equal fn 'list)            (apply-continuation cont args))
    ((equal fn 'call/cc)         (myapply (car args) (list cont) catch-env errcont cont))
    ((functionp fn)              (apply fn args))      ; interim hack
    ((unicont-p fn)              (apply-continuation fn (car args)))
    ;;  ((identity-cont-p fn)        (apply-continuation fn (car args))) ;; for identity
    (t (error 'unknown-function :fn fn))))
;; CPS-вариант MYEVAL и все что к нему относится
(defun evcond (clauses env block-env go-env catch-env errcont cont)
  (cond ((null clauses)  (apply-continuation cont nil))
        (t               (myeval (caar clauses) env block-env go-env catch-env errcont
                                 (make-evcond-cont
                                  :clauses clauses
                                  :env env
                                  :block-env block-env
                                  :go-env go-env
                                  :catch-env catch-env
                                  :errcont errcont
                                  :cont cont)))))
(defun evprogn (lst env block-env go-env catch-env errcont cont)
  (cond ((null lst)         (apply-continuation cont nil))
        ((null (cdr lst))   (myeval (car lst) env block-env go-env catch-env errcont cont))
        (t                  (myeval (car lst) env block-env go-env catch-env errcont
                                    (make-evprogn-cont
                                     :clauses lst
                                     :env env
                                     :block-env block-env
                                     :go-env go-env
                                     :catch-env catch-env
                                     :errcont errcont
                                     :cont cont)))))
(defun evand (exps env block-env go-env catch-env errcont cont)
  (cond ((null exps)       (apply-continuation cont T))
        ((null (cdr exps)) (myeval (car exps) env block-env go-env catch-env errcont cont))
        (t                 (myeval (car exps) env block-env go-env catch-env errcont
                                   (make-and-cont
                                    :exps (cdr exps)
                                    :env env
                                    :block-env block-env
                                    :go-env go-env
                                    :catch-env catch-env
                                    :errcont errcont
                                    :cont cont)))))
(defun evor (exps env block-env go-env catch-env errcont cont)
  (cond ((null exps)       (apply-continuation cont nil))
        ((null (cdr exps)) (myeval (car exps) env block-env go-env catch-env errcont cont))
        (t                 (myeval (car exps) env block-env go-env catch-env errcont
                                   (make-or-cont
                                    :exps (cdr exps)
                                    :env env
                                    :block-env block-env
                                    :go-env go-env
                                    :catch-env catch-env
                                    :errcont errcont
                                    :cont 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 go-env catch-env errcont cont)
  (cond ((null exps)  (evprogn exp
                               (pairlis vars (reverse evald-exps) env)
                               block-env go-env catch-env
                               errcont cont))
        (t            (myeval (car exps) env block-env go-env catch-env errcont
                              (make-evlet-cont
                               :vars vars
                               :exps exps
                               :evald-exps evald-exps
                               :exp exp
                               :env env
                               :block-env block-env
                               :go-env go-env
                               :catch-env catch-env
                               :errcont errcont
                               :cont cont)))))
(defun evletstar (varpairs exp env block-env go-env catch-env errcont cont)
  (cond ((null varpairs)  (evprogn exp env block-env go-env catch-env errcont cont))
        (t                (myeval (cadar varpairs) env block-env go-env catch-env errcont
                                  (make-evletstar-cont
                                   :varpairs varpairs
                                   :exp exp
                                   :env env
                                   :block-env block-env
                                   :go-env go-env
                                   :catch-env catch-env
                                   :errcont errcont
                                   :cont cont)))))
(defun evthrow (exp env block-env go-env catch-env errcont cont)
  (myeval (cadr exp) env block-env go-env catch-env errcont
          (make-throw-cont
           :clauses exp
           :env env
           :block-env block-env
           :go-env go-env
           :catch-env catch-env
           :errcont errcont
           :cont cont)))
(defun tagbody-check-tag (exp cont errcont)
  (cond ((null exp) (funcall cont))
        ((and (symbolp (car exp))
              (member (car exp) (cdr exp)))
         (funcall errcont (car exp)))
        (t (tagbody-check-tag (cdr exp) cont errcont))))
(defun evtagbody (body env block-env go-env catch-env errcont cont)
  (cond ((null (car body))      (apply-continuation cont nil))
        ((symbolp (car body))   (evtagbody (cdr body) env block-env go-env catch-env errcont cont))
        (t                      (myeval (car body) env block-env go-env catch-env errcont
                                        (make-evtagbody-cont
                                         :body (cdr body)
                                         :env  env
                                         :block-env block-env
                                         :go-env go-env
                                         :catch-env catch-env
                                         :errcont errcont
                                         :cont cont)))))
(defun tagbody-slice (exp res)
  (cond ((null exp) res)
        ((symbolp (car exp))  (tagbody-slice (cdr exp) (cons exp res)))
        (t                    (tagbody-slice (cdr exp) res))))
(defun is-cont-subset (target-cont cont)
  (cond ((equal target-cont cont) t)    ;; positive
        ((functionp cont) nil)          ;; negative
        (t (is-cont-subset target-cont (cdr cont)))))
(defun make-go-env (tagbody-body env block-env go-env catch-env errcont cont)
  (let* ((conts (mapcar #'(lambda (x) ;; продолжения, нарезанные из tagbody
                            (make-go-cont
                             :slice x
                             :env env
                             :block-env block-env
                             :go-env go-env ;; этот слот будем setf-эфить
                             :catch-env  catch-env
                             :errcont errcont
                             :cont cont))
                        (tagbody-slice tagbody-body nil)))
         ;; пары (символ . продолжение) нарезанные из
         ;; tagbody и добавленные в окружение
         (new-go-env (append (mapcar #'(lambda (go-cont)
                                         (cons (car (go-cont-slice go-cont))
                                               go-cont))
                                     conts)
                             go-env)))
    ;; изменяем поля go-env, записывая в них new-go-env
    ;; во всех созданных продолжениях
    (loop :for elt-cont :in conts :do
       (setf (go-cont-go-env elt-cont)
             new-go-env))
    ;; возвращаем новое окружение
    new-go-env))
(defun apply-go-continuation (go-cont)
  (evtagbody (go-cont-slice go-cont)
             (go-cont-env go-cont)
             (go-cont-block-env go-cont)
             (go-cont-go-env go-cont)
             (go-cont-catch-env go-cont)
             (go-cont-errcont go-cont)
             (go-cont-cont go-cont)))
(defun myeval (exp env block-env go-env catch-env errcont cont)
  (cond
    ((null exp)                  (apply-continuation cont 'nil))
    ((equal 't exp)              (apply-continuation cont 't))
    ((member exp '(+ * car cdr cons null print list call/cc repl))  (apply-continuation cont exp))
    ((numberp exp)               (apply-continuation cont exp))
    ((symbolp exp)               (lookup exp env errcont cont))
    ((equal (car exp) 'quote)    (apply-continuation cont (cadr exp)))
    ((equal (car exp) 'if)       (myeval (cadr exp) env block-env go-env catch-env errcont
                                         (make-if-cont
                                          :clauses exp
                                          :env env
                                          :block-env block-env
                                          :go-env go-env
                                          :catch-env catch-env
                                          :errcont errcont
                                          :cont cont)))
    ((equal (car exp) 'cond)     (evcond (cdr exp)
                                         env block-env go-env catch-env
                                         errcont cont))
    ((equal (car exp) 'progn)    (evprogn (cdr exp)
                                          env block-env go-env catch-env
                                          errcont cont))
    ((equal (car exp) 'and)      (evand (cdr exp)
                                        env block-env go-env catch-env
                                        errcont cont))
    ((equal (car exp) 'or)       (evor  (cdr exp)
                                        env block-env go-env catch-env
                                        errcont cont))
    ((equal (car exp) 'let)      (evlet (mapcar #'car (cadr exp))
                                        (mapcar #'cadr (cadr exp))
                                        nil
                                        (cddr exp)
                                        env block-env go-env catch-env
                                        errcont cont))
    ((equal (car exp) 'let*)     (evletstar (cadr exp)
                                            (cddr exp)
                                            env block-env go-env catch-env
                                            errcont cont))
    ;; стало
    ((equal (car exp) 'defun)         (progn
                                        (push (cons (cadr exp)
                                                    (make-closure :body (cdddr exp)
                                                                  :block-env block-env
                                                                  :env env
                                                                  :go-env go-env
                                                                  :args (caddr exp)))
                                              *glob-env*)
                                        (apply-continuation cont (cadr exp))))
    ;; было
    ((equal (car exp) 'defun)         (progn
                                        (push (cons (cadr exp)
                                                    (make-closure :body (cdddr exp)
                                                                  :env env
                                                                  :block-env block-env
                                                                  :go-env go-env
                                                                  :args (caddr exp)))
                                              *glob-env*)
                                        (funcall cont (cadr exp))))
    ;; стало
    ((equal (car exp) 'setq)     (myeval (caddr exp) env block-env go-env catch-env errcont
                                         (make-setq-cont
                                          :clauses exp
                                          :env env
                                          :block-env block-env
                                          :go-env go-env
                                          :catch-env catch-env
                                          :errcont errcont
                                          :cont cont)))
    ;; было
    ((equal (car exp) 'setq)     (myeval (caddr exp) env block-env go-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)   (apply-continuation cont (make-closure :body (cddr exp)
                                                                        :block-env block-env
                                                                        :env env
                                                                        :go-env go-env
                                                                        :args (cadr exp))))
    ;; было
    ((equal (car exp) 'lambda)   (funcall cont (make-closure :body (cddr exp)
                                                             :env env
                                                             :block-env block-env
                                                             :go-env go-env
                                                             :args (cadr exp))))
    ((equal (car exp) 'block)    (myeval (caddr exp)
                                         env
                                         (acons (cadr exp)
                                                cont
                                                block-env)
                                         go-env catch-env errcont cont))
    ((equal (car exp) 'return-from)
                                 (if (not (symbolp (cadr exp)))
                                     (apply-continuation
                                      errcont (format nil "return-from: first argument not a symbol"))
                                     (myeval (caddr exp) env block-env go-env catch-env errcont
                                             (lambda (x)
                                               (assoc-2 (cadr exp) block-env
                                                        (lambda (y)
                                                          (if (is-cont-subset y cont)
                                                              (apply-continuation y x)
                                                              (apply-continuation
                                                               errcont
                                                               (format nil "return-from: attempt to RETURN-FROM to ~A that no longer exists" (cadr exp)))))
                                                        (lambda (y)
                                                          (apply-continuation
                                                           errcont (format nil "return-from: undefined return block ~A" y))))))))
    ((equal (car exp) 'catch)    (myeval (cadr exp) env block-env go-env catch-env errcont
                                         (make-catch-cont
                                          :clauses exp
                                          :env env
                                          :block-env block-env
                                          :go-env go-env
                                          :catch-env catch-env
                                          :errcont errcont
                                          :cont cont)))
    ((equal (car exp) 'throw)    (evthrow exp
                                          env block-env go-env catch-env
                                          errcont cont))
    ((equal (car exp) 'return-from)
                                 (if (not (symbolp (cadr exp)))
                                     (apply-continuation
                                      errcont (format nil "return-from: first argument not a symbol"))
                                     (myeval (caddr exp) env block-env go-env catch-env errcont
                                             (lambda (x)
                                               (assoc-2 (cadr exp) block-env
                                                        (lambda (y)
                                                          (if (is-cont-subset y cont)
                                                              (apply-continuation y x)
                                                              (apply-continuation
                                                               errcont
                                                               (format nil "return-from: attempt to RETURN-FROM to ~A that no longer exists" (cadr exp)))))
                                                        (lambda (y)
                                                          (apply-continuation
                                                           errcont (format nil "return-from: undefined return block ~A" y))))))))
    ((equal (car exp) 'catch)    (myeval (cadr exp) env block-env go-env catch-env errcont
                                         (make-catch-cont
                                          :clauses exp
                                          :env env
                                          :block-env block-env
                                          :go-env go-env
                                          :catch-env catch-env
                                          :errcont errcont
                                          :cont cont)))
    ((equal (car exp) 'throw)    (evthrow exp
                                          env block-env go-env catch-env
                                          errcont cont))
    ((equal (car exp) 'tagbody)  (tagbody-check-tag
                                  (cdr exp)
                                  (lambda ()
                                    (evtagbody (cdr exp) env block-env
                                               (make-go-env (cdr exp)
                                                            env block-env go-env catch-env
                                                            errcont cont)
                                               catch-env errcont cont))
                                  (lambda (x)
                                    (apply-continuation
                                     errcont
                                     (format
                                      nil
                                      "tagbody: The tag ~A appears more than once in a tagbody"
                                      x)))))
    ;; стало
    ((equal (car exp) 'go)       (assoc-2 (cadr exp) go-env
                                          (lambda (go-cont)
                                            (apply-go-continuation go-cont))
                                          (lambda (go-label)
                                            (apply-continuation
                                             errcont
                                             (format nil "go: wrong target ~A" go-label)))))
    ;; промежуточный вариант
    ((equal (car exp) 'go)       (assoc-2 (cadr exp) go-env
                                          (lambda (x)
                                            (apply-continuation x 'NOT-A-PARAM))
                                          (lambda (x)
                                            (apply-continuation
                                             errcont
                                             (format nil "go: wrong target ~A" x)))))
    ;; было
    ((equal (car exp) 'go)       (assoc-2 (cadr exp) go-env
                                          (lambda (x)
                                            (funcall x))
                                          (lambda (x)
                                            (funcall
                                             errcont
                                             (format nil "go: wrong target ~A" x)))))
    ((equal (car exp) 'labels)   (let* ((alist (mapcar (lambda (label) ;; формируем список пар (имя . nil)
                                                         (cons (car label) nil))
                                                       (cadr exp)))
                                        (new-env (append alist env))   ;; добавим к списку пар предыдущее окружение
                                        (closures (mapcar (lambda (label)
                                                            ;; создаем замыкание, указывающее (env) на созданные переменные (содержащие пока nil)
                                                            (make-closure :body (cddr label) ;; implicit progn
                                                                          :block-env block-env
                                                                          :env new-env
                                                                          :go-env go-env
                                                                          :args (cadr label)))
                                                          (cadr exp))))
                                   ;; alist:    '((zzz . nil) (xxx . nil))
                                   ;; new-env:  '((zzz . nil) (xxx . nil) (old . #:closure))
                                   ;; closures: '(#:closure #:closure) ;; у этих замыканий :env указывает на new-env
                                   (assert (equal (length alist) (length closures)))
                                   (loop
                                      :for aelt     :in alist
                                      :for closure  :in closures
                                      :do (rplacd aelt closure))
                                   ;; получаем:
                                   ;; alist:    '((zzz . #:closure) (xxx . #:closure))
                                   ;; И передаем new-env в качестве окружения
                                   (evprogn (cddr exp) new-env block-env go-env catch-env errcont cont)))
    ((equal (car exp) 'reset)    (apply-continuation cont (myeval (cadr exp)
                                                                  env block-env go-env catch-env
                                                                  errcont #'identity)))
    ((equal (car exp) 'shift)    (myeval (caddr exp)
                                         (acons (cadr exp) cont env)
                                         block-env go-env catch-env
                                         errcont cont))
    (t
     (myeval (car exp) env block-env go-env catch-env errcont
             (lambda (x)
               (evlis x (cdr exp) nil env block-env go-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 nil #'err #'ok)))
(assert (equal '((1 . 2) 3 . 4) (myeval '(cons (cons 1 2) (cons 3 4)) nil nil nil nil #'err #'ok)))
(assert (equal 2 (myeval '(car (cons 2 3)) nil nil nil nil #'err #'ok)))
(assert (equal 3 (myeval '(cdr (cons 2 3)) nil nil nil nil #'err #'ok)))
(assert (equal '(1 . 2) (myeval '(car (cons (cons 1 2) (cons 3 4))) nil nil nil nil #'err #'ok)))
(assert (equal '(3 . 4) (myeval '(cdr (cons (cons 1 2) (cons 3 4))) nil nil nil nil #'err #'ok)))
;; Тесты для cons-ячеек, вычисляемых в окружении
(assert (equal 1 (myeval '(car a) '((a . (1 . 2))) nil nil nil #'err #'ok)))
(assert (equal 2 (myeval '(cdr a) '((a . (1 . 2))) nil nil nil #'err #'ok)))
(assert (equal 3 (myeval '(car b) '((a . (1 . 2)) (b . (3 . 4))) nil nil nil #'err #'ok)))
;; Тесты для NULL
(assert (equal T (myeval '(null ()) nil nil nil nil #'err #'ok)))
(assert (equal T (myeval '(null nil) nil nil nil nil #'err #'ok)))
(assert (equal NIL (myeval '(null T) nil nil nil nil #'err #'ok)))
(assert (equal T (myeval '(null a) '((a . ())) nil nil nil #'err #'ok)))
;; Тесты для NULL, с аргументом, вычисляемые в окружении
(assert (equal NIL (myeval '(null a) '((a . T)) nil nil nil #'err #'ok)))
(assert (equal NIL (myeval '(null a) '((a . 1)) nil 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 nil #'err #'ok)))
(assert (equal (+ 2)            (myeval '(+ 2) nil nil nil nil #'err #'ok)))
(assert (equal (+ 2 3)          (myeval '(+ 2 3) nil nil nil nil #'err #'ok)))
(assert (equal (+ 2 3 4)        (myeval '(+ 2 3 4) nil nil nil nil #'err #'ok)))
(assert (equal (+ 2 (+ 3 4))    (myeval '(+ 2 (+ 3 4)) nil nil nil nil #'err #'ok)))
(assert (equal (+ 2 (+ 3 4) 5)  (myeval '(+ 2 (+ 3 4) 5) nil nil nil nil #'err #'ok)))
;; Тесты для умножения
(assert (equal 1                (myeval '(*) nil nil nil nil #'err #'ok)))
(assert (equal (* 2)            (myeval '(* 2) nil nil nil nil #'err #'ok)))
(assert (equal (* 2 3)          (myeval '(* 2 3) nil nil nil nil #'err #'ok)))
(assert (equal (* 2 3 4)        (myeval '(* 2 3 4) nil nil nil nil #'err #'ok)))
(assert (equal (* 2 (* 3 4))    (myeval '(* 2 (* 3 4)) nil nil nil nil #'err #'ok)))
(assert (equal (* 2 (* 3 4) 5)  (myeval '(* 2 (* 3 4) 5) nil nil nil nil #'err #'ok)))
;; Тесты для сложения в окружении
(assert (equal 0
               (myeval '(+) nil nil nil nil #'err #'ok)))
(assert (equal (let ((a 2))
                 (+ a))
               (myeval '(+ a)
                       '((a . 2))
                       nil nil nil #'err #'ok)))
(assert (equal (let ((a 2) (b 3))
                 (+ a b))
               (myeval '(+ a b)
                       '((a . 2) (b . 3))
                       nil 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 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 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 nil #'err #'ok)))
;; Тесты для умножения  в окружении
(assert (equal 1
               (myeval '(*) nil nil nil nil #'err #'ok)))
(assert (equal (let ((a 2))
                 (* a))
               (myeval '(* a)
                       '((a . 2))
                       nil nil nil #'err #'ok)))
(assert (equal (let ((a 2) (b 3))
                 (* a b))
               (myeval '(* a b)
                       '((a . 2) (b . 3))
                       nil 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 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 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 nil #'err #'ok)))
;; Тесты для применения CLOSURE
(assert (equal 1 (myeval '(((lambda (x)
                              (lambda (y) x))
                            1)
                           2)
                         nil 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 nil #'err #'identity))))
(assert (equal (print 12)
               (myeval '(print 12) nil 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 nil #'err #'identity))))
(assert (equal (let ((a 12))
                 (print a))
               (myeval '(print a)
                       '((b . 23) (a . 12))
                       nil nil nil #'err #'ok)))
;; Тест для EVLIS
(assert (equal 4           (evlis '+     '(1 (+ 1 2))   nil nil nil nil nil  #'err #'ok)))
(assert (equal (+ 1 3 5)   (evlis '+     '(1 (+ 1 2) 5) nil nil nil nil nil  #'err #'ok)))
(assert (equal '(1 3 5)    (evlis 'list  '(1 (+ 1 2) 5) nil 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 nil  #'err #'ok)))
;; Тесты для LIST
(assert (equal '(1 14) (myeval '(list 1 (+ 2 (* 3 4)))
                               nil nil nil nil #'err #'ok)))
(assert (equal '(3 6 42)
               (myeval '(list (+ 1 2) (* 2 3) 42) nil 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 nil #'err #'ok)))
;; Тесты для CALL/CC
(assert (equal 14 (myeval '(+ 1 2 (call/cc (lambda (x) (+ 3 4) (x (+ 5 6)) (+7 8))))
                          nil nil nil nil #'err #'ok)))
;; Тесты для MYEVAL
;; Тесты для самовычисляемых форм
(assert (equal T (myeval 'T nil nil nil nil #'err #'ok)))
(assert (equal NIL (myeval 'NIL nil nil nil nil #'err #'ok)))
(assert (equal 999 (myeval 999 nil nil nil nil #'err #'ok)))
;; Тесты для вычисления символов
(assert (equal 6 (myeval 'b '((a . 3) (b . 6)) nil nil nil #'err #'ok)))
(assert (equal "error" (car (myeval 'b nil nil nil nil
                                    #'(lambda (x) (cons "error" x))
                                    #'ok))))
;; Тесты для QUOTE
(assert (equal '(+ 1 2) (myeval '(quote (+ 1 2)) nil nil nil nil #'err #'ok)))
;; Тесты для IF
(assert (equal 2 (myeval '(if () 1 2) nil nil nil nil #'err #'ok)))
(assert (equal 1 (myeval '(if (null ()) 1 2) nil nil nil nil #'err #'ok)))
;; Тесты для IF, где условие вычисляется в окружении
(assert (equal 2 (myeval '(if a 1 2) '((a . ())) nil nil nil #'err #'ok)))
(assert (equal 1 (myeval '(if a 1 2) '((a . 1)) nil nil nil #'err #'ok)))
;; Тесты для EVCOND
(assert (equal 2   (evcond '((t 2)   (t 1)) nil nil nil nil #'err #'ok)))
(assert (equal 1   (evcond '((nil 2) (t 1)) nil nil nil nil #'err #'ok)))
(assert (equal nil (evcond '((nil 2) (nil 1)) nil nil nil nil #'err #'ok)))
;; Тесты для EVCOND, где участвует окружение
(assert (equal 2 (evcond '((a 2) (b 1))
                         '((a . 1) (b . ()))
                         nil nil nil #'err #'ok)))
(assert (equal 1 (evcond '((a 2) (b 1))
                         '((a . nil) (b . T))
                         nil nil nil #'err #'ok)))
;; Тесты для COND
(assert (equal 2 (myeval '(cond
                           (() 1)
                           (1 2))
                         nil nil nil nil #'err #'ok)))
(assert (equal 2 (myeval '(cond
                           (a 1)
                           (b 2))
                         '((a . ()) (b . 1))
                         nil nil nil #'err #'ok)))
(assert (equal 1 (myeval '(cond
                           (a 1)
                           (b 2))
                         '((a . 1) (b . ()))
                         nil nil nil #'err #'ok)))
;; Тест для EVPROGN
(assert (equal 2 (evprogn '(1 2) nil nil nil nil  #'err #'ok)))
;; Тест для EVPROGN в окружении
(assert (equal 3 (evprogn '(a b c)
                          '((a . 1) (b . 2) (c . 3))
                           nil nil nil #'err #'ok)))
;; Тест для PROGN
(assert (equal 3 (myeval '(progn 1 2 3) nil nil nil nil #'err #'ok)))
;; Тест для PROGN в окружении
(assert (equal 3 (myeval '(progn a b c) '((a . 1) (b . 2) (c . 3))
                         nil nil nil #'err #'ok)))
;; Тесты для EVAND
(assert (equal (and)           (evand '() nil nil nil nil #'err #'ok)))
(assert (equal (and 1)         (evand '(1) nil nil nil nil #'err #'ok)))
(assert (equal (and nil)       (evand '(nil) nil nil nil  nil #'err #'ok)))
(assert (equal (and 1 nil)     (evand '(1 nil) nil nil nil nil #'err #'ok)))
(assert (equal (and 1 2 nil)   (evand '(1 2 nil) nil nil nil nil #'err #'ok)))
(assert (equal (and 1 2 3)     (evand '(1 2 3) nil nil nil nil #'err #'ok)))
(assert (equal (and 1 2 nil 3) (evand '(1 2 nil 3) nil nil nil nil #'err #'ok)))
;; Тесты для EVAND в окружении
(assert (equal (let ((a nil))
                 (and nil))
               (evand '(a) '((a . nil)) nil nil nil #'err #'ok)))
(assert (equal (let ((a 1))
                 (and a))
               (evand '(a) '((a . 1)) nil nil nil #'err #'ok)))
(assert (equal (let ((a 1)
                     (b nil))
                 (and a b))
               (evand '(a b) '((a . 1) (b . nil)) 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 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 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 nil #'err #'ok)))
;; Тесты для AND
(assert (equal (and)                (myeval '(and) nil nil nil nil #'err #'ok)))
(assert (equal (and 1)              (myeval '(and 1) nil nil nil nil #'err #'ok)))
(assert (equal (and nil)            (myeval '(and nil) nil nil nil nil #'err #'ok)))
(assert (equal (and 1 nil)          (myeval '(and 1 nil) nil nil nil nil #'err #'ok)))
(assert (equal (and 1 2 nil)        (myeval '(and 1 2 nil) nil nil nil nil #'err #'ok)))
(assert (equal (and 1 2 3)          (myeval '(and 1 2 3) nil nil nil nil #'err #'ok)))
(assert (equal (and 1 (and 1 2) 3)  (myeval '(and 1 (and 1 2) 3) nil nil nil nil
                                            #'err #'ok)))
(assert (equal (and 1 (and 1 nil) 3)  (myeval '(and 1 (and 1 nil) 3) nil nil nil nil
                                              #'err #'ok)))
;; Тесты для AND в окружении
(assert (equal (let ((a nil))
                 (and nil))
               (myeval '(and a) '((a . nil)) nil nil nil #'err #'ok)))
(assert (equal (let ((a 1))
                 (and a))
               (myeval '(and a) '((a . 1)) nil nil nil #'err #'ok)))
(assert (equal (let ((a 1)
                     (b nil))
                 (and a b))
               (myeval '(and a b) '((a . 1) (b . nil)) 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 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 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 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 nil
                       #'err #'ok)))
;; Тесты для EVOR
(assert (equal (or)                   (evor '() nil nil nil nil #'err #'ok)))
(assert (equal (or nil 1)             (evor '(nil 1) nil nil nil nil #'err #'ok)))
(assert (equal (or nil nil 1)         (evor '(nil nil 1) nil nil nil nil #'err #'ok)))
(assert (equal (or nil 1 2)           (evor '(nil 1 2) nil nil nil nil #'err #'ok)))
(assert (equal (or 1 2 3)             (evor '(1 2 3) nil nil nil nil #'err #'ok)))
(assert (equal (or nil nil 3 nil)     (evor '(nil nil 3 nil) nil nil nil nil #'err #'ok)))
;; Тесты для EVOR в окружении
(assert (equal (let ((a nil))
                 (or a))
               (evor '(a) '((a . nil)) nil nil nil #'err #'ok)))
(assert (equal (let ((a 1))
                 (or a))
               (evor '(a) '((a . 1)) nil nil nil #'err #'ok)))
(assert (equal (let ((a nil)
                     (b 1))
                 (or a b))
               (evor '(a b) '((a . nil) (b . 1)) nil 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 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 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 nil
                     #'err #'ok)))
;; Тесты для OR
(assert (equal (or)                  (myeval '(or) nil nil nil nil #'err #'ok)))
(assert (equal (or nil 1)            (myeval '(or nil 1) nil nil nil nil #'err #'ok)))
(assert (equal (or nil nil 1)        (myeval '(or nil nil 1) nil nil nil nil #'err #'ok)))
(assert (equal (or nil 1 2)          (myeval '(or nil 1 2) nil nil nil nil #'err #'ok)))
(assert (equal (or nil (or 3 2) 2)   (myeval '(or nil (or 3 2) 2) nil nil nil nil #'err #'ok)))
;; Тесты для OR в окружении
(assert (equal (let ((a nil))
                 (or a))
               (myeval '(or a) '((a . nil)) nil nil nil #'err #'ok)))
(assert (equal (let ((a 1))
                 (or a))
               (myeval '(or a) '((a . 1)) nil nil nil #'err #'ok)))
(assert (equal (let ((a nil)
                     (b 1))
                 (or a b))
               (myeval '(or a b) '((a . nil) (b . 1)) nil 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 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 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 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 nil #'err #'ok)))
;; Тесты для LET
(assert (equal '(1 . 2) (myeval '(let ((a 1)
                                       (b 2))
                                  (cons a b))
                                  nil nil nil nil
                                  #'err #'ok)))
;; Тесты для EVLETSTAR
(assert (equal 2 (evletstar '((a 1) (b a)) '(4 (+ a b)) nil 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 nil #'err #'ok)))
;; Тесты для DEFUN
(assert (equal 64 (progn
                    (setf *glob-env* nil)
                    (myeval '(defun alfa (x) (* x x)) nil nil nil nil #'err #'ok)
                    (prog1 (myeval '(alfa 8) nil 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 nil #'err #'ok)
                     (prog1 (myeval '(alfa 8) nil 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 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 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 nil #'err #'ok)
                              *glob-env*)
                   (setf *glob-env* nil)))))
;; Тесты для LAMBDA
(assert (equal 3 (myeval '((lambda (x) (+ 1  x)) 2)
                         nil nil nil nil #'err #'ok)))
;; Тесты для LAMBDA в окружении
(assert (equal 5 (myeval '(let ((y 3))
                           ((lambda (x) (+ y x)) 2))
                         nil 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 nil #'err #'ok)))
;; Тесты для BLOCK
(assert (equal nil (myeval '(block testblock)
                           nil nil nil nil #'err #'ok)))
(assert (equal 3 (myeval '(block testblock 3)
                         nil nil nil nil #'err #'ok)))
;; Тесты для RETURN-FROM
(assert (equal 3 (myeval '(block testblock (return-from testblock (+ 1 2)) 777)
                         nil nil nil nil #'err #'ok)))
(assert (equal "error" (myeval '(block testblock (return-from notblock (+ 1 2)) 777)
                               nil nil nil nil #'(lambda (x) "error") #'ok)))
(assert (equal "error" (myeval '(progn (return-from not-found-block (+ 1 2)) 777)
                               nil nil nil nil (lambda (x) "error")
                               #'ok)))
;; Тест RETURN-FROM в лексической области видимости
(assert (equal 12 (progn
                    (setf *glob-env* nil)
                    (prog1 (myeval '(progn
                                     (defun foo (x)
                                       (block in-lambda-block
                                         (return-from in-lambda-block
                                           (+ x 2))
                                         777))
                                     (foo 10))
                                   nil nil nil nil (lambda (x) "error")
                                   #'ok)
                      (setf *glob-env* nil)))))
;; Тест RETURN-FROM в динамической области видимости (должна быть ошибка)
(assert (equal "error" (progn
                         (setf *glob-env* nil)
                         (prog1 (myeval '(progn
                                          (defun foo (x)
                                            (return-from in-lambda-block
                                              (+ x 2))
                                            777)
                                          (block in-lambda-block
                                            (foo 10)))
                                        nil nil nil nil (lambda (x) "error")
                                        #'ok)
                           (setf *glob-env* nil)))))
;; Тест на ошибку недостижимого блока
(assert (equal "error" (myeval '((block the-block (lambda () (return-from the-block nil))))
                               nil nil nil nil (lambda (x) "error")
                               #'ok)))
;; Тест на отсутствие ошибки при возврате в достижимый блок
(assert (equal 123 (myeval '(block the-block (return-from the-block 123))
                           nil nil nil nil (lambda (x) "error")
                           #'ok)))
;; Тесты для CATCH
(assert (equal nil (myeval '(catch 'zzz)
                           nil nil nil nil #'err #'ok)))
(assert (equal 3 (myeval '(catch 'zzz 3)
                         nil nil nil nil #'err #'ok)))
;; Тесты для THROW
(assert (equal 3 (myeval '(catch 'testcatch (throw 'testcatch (+ 1 2)) 777)
                         nil nil nil nil #'err #'ok)))
(assert (equal "error" (myeval '(catch 'testcatch (throw 'notcatch (+ 1 2)) 777)
                               nil nil nil nil
                               #'(lambda (x) "error")
                               #'ok)))
(assert (equal "error" (myeval '(progn (throw 'not-found-catch (+ 1 2)) 777)
                               nil nil nil nil (lambda (x) "error")
                               #'ok)))
;; Тест THROW в лексической области видимости
(assert (equal 12 (progn
                    (setf *glob-env* nil)
                    (prog1 (myeval '(progn
                                     (defun foo (x)
                                       (catch 'in-lambda-catch
                                         (throw 'in-lambda-catch
                                           (+ x 2))
                                         777))
                                     (foo 10))
                                   nil nil nil nil (lambda (x) "error")
                                   #'ok)
                      (setf *glob-env* nil)))))
;; Тест THROW в динамической области видимости (должно сработать)
(assert (equal 12 (progn
                    (setf *glob-env* nil)
                    (prog1 (myeval '(progn
                                     (defun foo (x)
                                       (throw 'in-lambda-catch
                                         (+ x 2))
                                       777)
                                     (catch 'in-lambda-catch
                                       (foo 10)))
                                   nil nil nil nil (lambda (x) "error")
                                   #'ok)
                      (setf *glob-env* nil)))))
;; Тесты для TAGBODY
(assert (equal nil (myeval '(tagbody a 1)
                           nil nil nil nil #'err #'ok)))
(assert (equal nil (myeval '(tagbody a 1 b 2)
                           nil nil nil nil #'err #'ok)))
;; Тесты для GO
(assert (equal '(1 . 4) (myeval '(let ((alfa 0))
                                  (tagbody
                                   a (setq alfa 1)
                                   b (go d)
                                   c (setq alfa (cons alfa 3))
                                   d (setq alfa (cons alfa 4)))
                                  alfa)
                                nil nil nil nil #'err #'ok)))
;; Тесты для "обратного хода" GO
(assert (equal '(1 . 5) (myeval '(let ((alfa 0))
                                  (tagbody
                                   a (go d)
                                   b (setq alfa 1)
                                   c (go e)
                                   d (go b)
                                   e (setq alfa (cons alfa 5)))
                                  alfa)
                                nil nil nil nil #'err #'ok)))
;; Тесты для LABELS
(assert (equal (labels ((zzz (lst acc)
                          (print acc)
                          (cond ((null lst) acc)
                                (t (zzz (cdr lst) (+ 1 acc))))))
                 (print 888)
                 (zzz '(1 2 3) 0))
               (myeval '(labels ((zzz (lst acc)
                                  (print acc)
                                  (cond ((null lst) acc)
                                        (t (zzz (cdr lst) (+ 1 acc))))))
                         (print 888)
                         (zzz '(1 2 3) 0))
                         nil nil nil nil #'err #'ok)))
(assert (equal (with-output-to-string (*standard-output*)
                 (labels ((zzz (lst acc)
                            (print acc)
                            (cond ((null lst) acc)
                                  (t (zzz (cdr lst) (+ 1 acc))))))
                   (print 888)
                   (zzz '(1 2 3) 0)))
               (with-output-to-string (*standard-output*)
                 (myeval '(labels ((zzz (lst acc)
                                    (print acc)
                                    (cond ((null lst) acc)
                                          (t (zzz (cdr lst) (+ 1 acc))))))
                           (print 888)
                           (zzz '(1 2 3) 0))
                         nil nil nil nil #'err #'identity))))
;; Тесты для RESET
(assert (equal 8 (myeval '(progn
                            (+ 1 (reset (+ 2 3)) 2))
                            nil nil nil nil #'err #'ok)))
;; Тесты для SHIFT/RESET
(assert (equal 44 (myeval '(let ((foo))
                            (+ 1 (reset (+ 2 (shift f (progn (setq foo f) 4)))))
                            (foo 42))
                          nil nil nil nil #'err #'ok)))
;; REPL
(defun repl (prompt catch-env errcont cont)
  (format t "~%~A> " prompt)
  (finish-output)
  (myeval (read) nil nil nil (acons 'exit cont catch-env)
    #'(lambda (x)
        (princ x)
        (terpri)
        (finish-output)
        (repl prompt catch-env errcont cont))
    #'(lambda (x)
        (princ x)
        (terpri)
        (finish-output)
        (repl prompt catch-env errcont cont))))
;; (repl)
Яндекс.Метрика
Home