Table of Contents

План работ

На предыдущем этапе мы получили labels. Продолжая добавлять конструкции управления, добавим call/cc, shift и reset. Изменится не очень много, мы добавим несколько clauses в myeval и myapply.

Кроме того, мы изменим наш repl так, чтобы иметь возможность вызывать его при возникновении ошибок.

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

(defun assoc-2 (key alist cont errcont) ;; NB!: inverted order of
                                        ;; continuations (for lookup)
  (cond ((null alist)              (funcall errcont key))
        ((equal key (caar alist))  (funcall cont    (cdar alist)))
        (t                         (assoc-2 key (cdr alist) cont errcont))))
(assert (equal "ok:123"
               (assoc-2 'alfa '((alfa . 123))
                        (lambda (x) (format nil "ok:~A" x))
                        (lambda (x) (format nil "err:~A" x)))))
(assert (equal "err:ALFA"
               (assoc-2 'alfa '((beta . 123))
                        (lambda (x) (format nil "ok:~A" x))
                        (lambda (x) (format nil "err:~A" x)))))
;; environment
(defparameter *glob-env* nil)
;; lookup
(defun lookup (symb env errcont cont)
  (assoc-2 symb env cont
           (lambda (key)
             (assoc-2 key *glob-env* cont
                      (lambda (key)
                        (funcall errcont
                                 (format
                                  nil
                                  "UNBOUD VARIABLE [~A] ~%LOCAL ENV: [~A] ~%GLOBAL ENV: [~A]"
                                  key env *glob-env*)))))))
;; test lookup
(assert (equal "ok:123" (lookup 'aaa '((aaa . 123))
                                (lambda (x) (format nil "err:~A" x))
                                (lambda (x) (format nil "ok:~A" x)))))
(assert (equal nil      (lookup 'aaa '((bbb . 123))
                                (lambda (x) (declare (ignore x)) nil)
                                (lambda (x) (format nil "ok:~A" x)))))

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

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

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

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

MyApply

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

  • call/cc
  • repl
(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_8>>
<<evlis_8>>
(defun myapply (fn args catch-env errcont cont)
  (cond
    <<myapply_car_cdr_cons_8>>
    <<myapply_null_8>>
    <<myapply_ariph_8>>
    <<myapply_closure_8>>
    <<myapply_print_8>>
    <<myapply_list_8>>
    <<myapply_callcc_8>>
    (t (error 'unknown-function :fn fn))))
<<myapply_car_cdr_cons_8_test>>
<<myapply_null_8_test>>
<<evaddmul_8_test>>
<<myapply_ariph_8_test>>
<<myapply_closure_8_test>>
<<myapply_print_8_test>>
<<myapply_evlis_8_test>>
<<myapply_list_8_test>>
<<myapply_callcc_8_test>>

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

((equal fn 'car)             (funcall cont (caar args)))
((equal fn 'cdr)             (funcall cont (cdar args)))
((equal fn 'cons)            (funcall cont (cons (car args) (cadr args))))
;; Тесты cons, car, cdr
(assert (equal '(1 . 2) (myeval '(cons 1 2) nil nil nil 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)))))
((equal fn 'null)            (if (null (cdr args))
                                 (funcall cont (null (car args)))
                                 (error 'invalid-number-of-arguments :fn fn)))
;; Тесты для NULL
(assert (equal T (myeval '(null ()) nil nil nil 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)))
((equal fn '+)               (funcall cont (evadd args 0)))
((equal fn '*)               (funcall 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

Чтобы был implicit progn мы вызываем evprogn а не myeval

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

((equal fn 'print)           (funcall cont (print (car args))))
;; Тесты для PRINT в сравнении с host-овым print
(assert (equal (with-output-to-string (*standard-output*)
                 (print 12))
               (with-output-to-string (*standard-output*)
                 (myeval '(print 12) nil nil nil 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

(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
                                  (lambda (x)
                                    (evlis fn
                                           (cdr unevaled)
                                           (cons x evaled)
                                           env block-env go-env catch-env
                                           errcont cont))))))
((equal fn 'list)            (funcall 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

Когда мы встречаем инструкцию call/cc мы ожидаем, что она содержит лямбду, которая принимает один функциональный аргумент. Мы хотим вычислить (apply) эту лямбду, передав ей в качестве этого аргумента текущее продолжение.

Когда эта лямбда попадает в myapply она будет представлена как функция (пока у нас нет объектов-функций) и нам останется только применить эту функцию к ее аргументу.

((equal fn 'call/cc)         (myapply (car args) (list cont) catch-env errcont cont))
((functionp fn)              (apply fn args))      ; interim hack

Чтобы написать тест на call/cc мы можем сформировать такое выражение. Здесь в call/cc передается продолжение из интерпретатора, которое будет вызвано внутри лямбды и вернет результат "11", который станет частью выражения "(+ 1 2 [])".

;; Тесты для 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

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

  • reset
  • shift
<<myeval_evcond_8>>
<<myeval_evprogn_8>>
<<myeval_evand_8>>
<<myeval_evor_8>>
<<myeval_mypairlis_8>>
<<myeval_evlet_8>>
<<myeval_evletstar_8>>
<<myeval_evthrow_8>>
<<myeval_evtagbody_8>>
(defun myeval (exp env block-env go-env catch-env errcont cont)
  (cond
    <<myeval_number_8>>
    <<myeval_symb_8>>
    <<myeval_quote_8>>
    <<myeval_if_8>>
    <<myeval_cond_8>>
    <<myeval_progn_8>>
    <<myeval_and_8>>
    <<myeval_or_8>>
    <<myeval_let_8>>
    <<myeval_letstar_8>>
    <<myeval_defun_8>>
    <<myeval_setq_8>>
    <<myeval_lambda_8>>
    <<myeval_block_8>>
    <<myeval_return_from_8>>
    <<myeval_catch_8>>
    <<myeval_throw_8>>
    <<myeval_tagbody_8>>
    <<myeval_go_8>>
    <<myeval_labels_8>>
    <<myeval_reset_8>>
    <<myeval_shift_8>>
    (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_8_test>>
<<myeval_symb_8_test>>
<<myeval_quote_8_test>>
<<myeval_if_8_test>>
<<myeval_evcond_8_test>>
<<myeval_cond_8_test>>
<<myeval_evprogn_8_test>>
<<myeval_progn_8_test>>
<<myeval_evand_8_test>>
<<myeval_and_8_test>>
<<myeval_evor_8_test>>
<<myeval_or_8_test>>
<<myeval_mypairlis_8_test>>
<<myeval_evlet_8_test>>
<<myeval_let_8_test>>
<<myeval_evletstar_8_test>>
<<myeval_letstar_8_test>>
<<myeval_defun_8_test>>
<<myeval_setq_8_test>>
<<myeval_lambda_8_test>>
<<myeval_block_8_test>>
<<myeval_return_from_8_test>>
<<myeval_catch_8_test>>
<<myeval_throw_8_test>>
<<myeval_tagbody_8_test>>
<<myeval_go_8_test>>
<<myeval_labels_8_test>>
<<myeval_reset_8_test>>
<<myeval_shift_8_test>>

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

Добавляем call/cc и repl в список встроенных функций.

((null exp)                  (funcall cont 'nil))
((equal t exp)               (funcall cont 't))
((member exp '(+ * car cdr cons null print list call/cc repl))  (funcall cont exp))
((numberp exp)               (funcall 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))))

Цитирование

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

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

((equal (car exp) 'if)       (myeval (cadr exp) env block-env go-env catch-env errcont
                                     (lambda (x)
                                       (if x
                                           (myeval (caddr exp)
                                                   env block-env go-env catch-env
                                                   errcont cont)
                                           (myeval (cadddr exp)
                                                   env block-env go-env catch-env
                                                   errcont 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

(defun evcond (exp env block-env go-env catch-env errcont cont)
  (cond ((null exp)  (funcall cont nil))
        (t           (myeval (caar exp) env block-env go-env catch-env errcont
                             (lambda (x)
                               (if x
                                   (myeval (cadar exp)
                                           env block-env go-env catch-env
                                           errcont cont)
                                   (evcond (cdr exp)
                                           env block-env go-env catch-env
                                           errcont 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

(defun evprogn (lst env block-env go-env catch-env errcont cont)
  (cond ((null lst)         (funcall 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
                                    (lambda (x)
                                      (evprogn (cdr lst)
                                               env block-env go-env catch-env
                                               errcont 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

(defun evand (args env block-env catch-env go-env errcont cont)
  (cond ((null args)        (funcall cont T))
        ((null (cdr args))  (myeval (car args) env block-env catch-env go-env errcont cont))
        (t                  (myeval (car args) env block-env catch-env go-env errcont
                                    (lambda (x)
                                      (if (null x)
                                          (funcall cont nil)
                                          (evand (cdr args) env block-env catch-env go-env
                                                 errcont 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

(defun evor (args env block-env go-env catch-env errcont cont)
  (cond ((null args)        (funcall cont nil))
        ((null (cdr args))  (myeval (car args) env block-env go-env catch-env errcont cont))
        (t                  (myeval (car args) env block-env go-env catch-env errcont
                                    (lambda (x)
                                      (if (not (null x))
                                          (funcall cont x)
                                          (evor (cdr args) env block-env go-env catch-env
                                                errcont 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"))))
(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
                              (lambda (x)
                                (evlet vars (cdr exps) (cons x evald-exps) exp
                                       env block-env go-env catch-env
                                       errcont 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*

(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
                                  (lambda (x)
                                    (evletstar (cdr varpairs) exp
                                               (acons (caar varpairs) x env)
                                               block-env go-env catch-env
                                               errcont 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

((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))))
;; Тесты для 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

((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))))
;; Тесты для 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

((equal (car exp) 'lambda)   (funcall cont (make-closure :body (cddr exp)
                                                         :env env
                                                         :block-env block-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

((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))))))))
;; Тесты для 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)))))

CATCH

((equal (car exp) 'catch)    (myeval (cadr exp) env block-env go-env catch-env errcont
                                     (lambda (symb-res)
                                       (if (not (symbolp symb-res))
                                           (funcall errcont
                                                    (format nil "catch: first argument not a symbol"))
                                           (myeval (caddr exp)
                                                   env
                                                   block-env
                                                   go-env
                                                   (acons symb-res
                                                          cont
                                                          catch-env)
                                                   errcont 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

Для того, чтобы облегчить себе следующий этап, определим вспомогательную функцию evthrow:

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

Тогда вызов из функции myeval станет таким:

((equal (car exp) 'throw)    (evthrow exp
                                      env block-env go-env catch-env
                                      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_check_tag_8>>
(defun evtagbody (body env block-env go-env catch-env errcont cont)
  (cond ((null (car body))      (funcall 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
                                        (lambda (x)
                                          (declare (ignore x))
                                          (evtagbody (cdr body) env block-env go-env catch-env errcont cont))))))
<<tagbody_slice_8>>
((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)
                                                  (funcall errcont (format nil "tagbody: The tag ~A appears more than once in a tagbody" x)))))
;; Тесты для 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

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

Когда мы встречаем reset мы как бы "сбрасываем стек", т.е. вычисляем внутреннюю форму в "identity-continuation", в результате чего эта форма возвращает значение. Это значение мы передаем как параметр продолжения cont.

((equal (car exp) 'reset)    (funcall 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

В выражении (shift x form) SHIFT биндит к переменной x продолжение cont. Поэтому (даже снаружи формы) можно будет вызвать x как функцию и перейти в это продолжение. В этом это похоже на call/cc.

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

Тут мы сохраняем продолжение в переменной и используем его, чтобы возвращаться в него и вычислять то что происходит между reset и shift.

;; Тесты для 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

Мы выносим repl в отдельный раздел и изменем его так, чтобы он:

  • принимал приглашение ввода
  • принимал catch-env
  • при каждом рекурсивном вызове добавлял в catch-env пару (exit . текущее продолжение)

Это позволяет нам делать (trow 'exit) всякий раз, когда нам нужно выйти из repl. Если у нас repl вызывается там, где произошла ошибка, мы можем исправить ее выйти из 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_8>>
;; CPS-версия ASSOC
<<assoc_8>>
;; Новая функция lookup
<<lookup_8>>
;; Структура замыкания
<<closure_8>>
;; CPS-вариант MYAPPLY и все что к нему относится
<<myapply_8>>
;; CPS-вариант MYEVAL и все что к нему относится
<<myeval_8>>
;; Тестируем новый lookup
<<lookup_8_test>>
;; Функции для тестирования CPS-функций
<<ok_err_8>>
;; Тесты для MYAPPLY
<<myapply_8_test>>
;; Тесты для MYEVAL
<<myeval_8_test>>
;; REPL
<<repl_8>>
;; (repl)

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

(setq *print-circle* T)
;; Классы ошибок
(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)))))
;; CPS-версия ASSOC
(defun assoc-2 (key alist cont errcont) ;; NB!: inverted order of
  ;; continuations (for lookup)
  (cond ((null alist)              (funcall errcont key))
        ((equal key (caar alist))  (funcall cont    (cdar alist)))
        (t                         (assoc-2 key (cdr alist) cont errcont))))
;; Новая функция lookup
;; environment
(defparameter *glob-env* nil)
;; lookup
(defun lookup (symb env errcont cont)
  (assoc-2 symb env cont
           (lambda (key)
             (assoc-2 key *glob-env* cont
                      (lambda (key)
                        (funcall errcont
                                 (format
                                  nil
                                  "UNBOUD VARIABLE [~A] ~%LOCAL ENV: [~A] ~%GLOBAL ENV: [~A]"
                                  key env *glob-env*)))))))
;; Структура замыкания
(defstruct closure
  body
  env
  block-env
  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
                                  (lambda (x)
                                    (evlis fn
                                           (cdr unevaled)
                                           (cons x evaled)
                                           env block-env go-env catch-env
                                           errcont cont))))))
(defun myapply (fn args catch-env errcont cont)
  (cond
    ((equal fn 'car)             (funcall cont (caar args)))
    ((equal fn 'cdr)             (funcall cont (cdar args)))
    ((equal fn 'cons)            (funcall cont (cons (car args) (cadr args))))
    ((equal fn 'null)            (if (null (cdr args))
                                     (funcall cont (null (car args)))
                                     (error 'invalid-number-of-arguments :fn fn)))
    ((equal fn '+)               (funcall cont (evadd args 0)))
    ((equal fn '*)               (funcall cont (evmul args 1)))
    ((closure-p fn)              (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)           (funcall cont (print (car args))))
    ((equal fn 'list)            (funcall cont args))
    ((equal fn 'call/cc)         (myapply (car args) (list cont) catch-env errcont cont))
    ((functionp fn)              (apply fn args))      ; interim hack
    (t (error 'unknown-function :fn fn))))
;; CPS-вариант MYEVAL и все что к нему относится
(defun evcond (exp env block-env go-env catch-env errcont cont)
  (cond ((null exp)  (funcall cont nil))
        (t           (myeval (caar exp) env block-env go-env catch-env errcont
                             (lambda (x)
                               (if x
                                   (myeval (cadar exp)
                                           env block-env go-env catch-env
                                           errcont cont)
                                   (evcond (cdr exp)
                                           env block-env go-env catch-env
                                           errcont cont)))))))
(defun evprogn (lst env block-env go-env catch-env errcont cont)
  (cond ((null lst)         (funcall 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
                                    (lambda (x)
                                      (evprogn (cdr lst)
                                               env block-env go-env catch-env
                                               errcont cont))))))
(defun evand (lst env block-env go-env catch-env errcont cont)
  (cond ((null lst)        (funcall cont (and)))
        ((null (cdr lst))  (myeval (car lst) env block-env go-env catch-env errcont
                                   (lambda (x)
                                     (funcall cont
                                              (and x)))))
        (t                 (myeval (car lst) env block-env go-env catch-env errcont
                                   (lambda (x)
                                     (funcall cont
                                              (and x
                                                   (evand (cdr lst)
                                                          env block-env go-env catch-env
                                                          errcont cont))))))))
(defun evor (lst env block-env go-env catch-env errcont cont)
  (cond ((null lst)        (funcall cont (or)))
        ((null (cdr lst))  (myeval (car lst) env block-env go-env catch-env errcont
                                   (lambda (x)
                                     (funcall cont
                                              (or x)))))
        (t                 (myeval (car lst) env block-env go-env catch-env errcont
                                   (lambda (x)
                                     (funcall cont
                                              (or x
                                                  (evor (cdr lst)
                                                        env block-env go-env catch-env
                                                        errcont cont))))))))
(defun mypairlis (lst1 lst2 alist)
  (cond ((and (null lst1) (null lst2))  alist)
        ((or  (null lst1) (null lst2))  (error 'mypairlis-error :lst1 lst1 :lst2 lst2))
        (t                              (cons (cons (car lst1)
                                                    (car lst2))
                                              (mypairlis (cdr lst1)
                                                         (cdr lst2)
                                                         alist)))))
(defun evlet (vars exps evald-exps exp env block-env 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
                              (lambda (x)
                                (evlet vars (cdr exps) (cons x evald-exps) exp
                                       env block-env go-env catch-env
                                       errcont 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
                                  (lambda (x)
                                    (evletstar (cdr varpairs) exp
                                               (acons (caar varpairs) x env)
                                               block-env go-env catch-env
                                               errcont 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))      (funcall 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
                                        (lambda (x)
                                          (declare (ignore x))
                                          (evtagbody (cdr body) env block-env go-env catch-env errcont 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 myeval (exp env block-env go-env catch-env errcont cont)
  (cond
    ((null exp)                  (funcall cont 'nil))
    ((equal t exp)               (funcall cont 't))
    ((member exp '(+ * car cdr cons null print list call/cc repl))  (funcall cont exp))
    ((numberp exp)               (funcall cont exp))
    ((symbolp exp)               (lookup exp env errcont cont))
    ((equal (car exp) 'quote)    (funcall cont (cadr exp)))
    ((equal (car exp) 'if)       (myeval (cadr exp) env block-env go-env catch-env errcont
                                         (lambda (x)
                                           (if x
                                               (myeval (caddr exp)
                                                       env block-env go-env catch-env
                                                       errcont cont)
                                               (myeval (cadddr exp)
                                                       env block-env go-env catch-env
                                                       errcont 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)
                                                                  :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
                                         (lambda (val)
                                           (if (null (assoc (cadr exp) env))
                                               (if (null (assoc (cadr exp) *glob-env*))
                                                   (push (cons (cadr exp) val)
                                                         *glob-env*)
                                                   (rplacd (assoc (cadr exp) *glob-env*) val))
                                               (rplacd (assoc (cadr exp) env) val))
                                           (funcall cont val))))
    ((equal (car exp) 'lambda)   (funcall cont (make-closure :body (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)))
         (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))))))))
    ((equal (car exp) 'catch)    (myeval (cadr exp) env block-env go-env catch-env errcont
                                         (lambda (symb-res)
                                           (if (not (symbolp symb-res))
                                               (funcall errcont
                                                        (format nil "catch: first argument not a symbol"))
                                               (myeval (caddr exp)
                                                       env
                                                       block-env
                                                       go-env
                                                       (acons symb-res
                                                              cont
                                                              catch-env)
                                                       errcont cont)))))
    ((equal (car exp) 'throw)    (myeval (cadr exp) env block-env go-env catch-env errcont
                                         (lambda (symb-res)
                                           (myeval (caddr exp) env block-env go-env catch-env errcont
                                                   (lambda (exp-res)
                                                     (assoc-2 symb-res catch-env
                                                              (lambda (cont-res)
                                                                (funcall cont-res exp-res))
                                                              (lambda (key)
                                                                (funcall errcont
                                                                         (format nil "throw: matching ~A catch is not found" key)))))))))
    ((equal (car exp) 'return-from)
     (if (not (symbolp (cadr exp)))
         (funcall errcont
                  (format nil
                          "return-from: first argument not a symbol"))
         (myeval (caddr exp) env block-env 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))))))))
    ((equal (car exp) 'catch)    (myeval (cadr exp) env block-env go-env catch-env errcont
                                         (lambda (symb-res)
                                           (if (not (symbolp symb-res))
                                               (funcall errcont
                                                        (format nil "catch: first argument not a symbol"))
                                               (myeval (caddr exp)
                                                       env
                                                       block-env
                                                       go-env
                                                       (acons symb-res
                                                              cont
                                                              catch-env)
                                                       errcont cont)))))
    ((equal (car exp) 'throw)    (myeval (cadr exp) env block-env go-env catch-env errcont
                                         (lambda (symb-res)
                                           (myeval (caddr exp) env block-env go-env catch-env errcont
                                                   (lambda (exp-res)
                                                     (assoc-2 symb-res catch-env
                                                              (lambda (cont-res)
                                                                (funcall cont-res exp-res))
                                                              (lambda (key)
                                                                (funcall errcont
                                                                         (format nil "throw: matching ~A catch is not found" key)))))))))
    ((equal (car exp) '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)
                                                      (funcall 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 (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 (caddr label)
                                                                          :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)    (funcall 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)))
;; Тесты для 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)))
;; Тесты для 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)))
;; Тесты для 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)))
;; Тесты для 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)))
;; Тесты для 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)))
;; Тесты для 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)))
;; Тесты для 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)))))
;; Тесты для 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)))
;; Тесты для 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)))))
;; Тесты для 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 3 (myeval '(labels ((zzz (lst acc)
;;                                     (cond ((null lst) acc)
;;                                           (t (zzz (cdr lst) (+ 1 acc))))))
;;                            (zzz '(1 2 3) 0))
;;                          nil nil nil nil #'err #'ok)))
;; Тесты для 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