Table of Contents

План работ

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

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

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

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

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

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

MyApply

(define-condition unknown-function (error)
  ((fn :initarg :fn  :reader fn))
  (:report
   (lambda (condition stream)
     (format stream "Error in MYAPPLY: unknown-function: ~A"
             (fn condition)))))
<<evaddmul_6>>
<<evlis_6>>
(defun myapply (fn args catch-env errcont cont)
  (cond
    <<myapply_car_cdr_cons_6>>
    <<myapply_null_6>>
    <<myapply_ariph_6>>
    <<myapply_closure_6>>
    <<myapply_print_6>>
    <<myapply_list_6>>
    (t (error 'unknown-function :fn fn))))
<<myapply_car_cdr_cons_6_test>>
<<myapply_null_6_test>>
<<evaddmul_6_test>>
<<myapply_ariph_6_test>>
<<myapply_closure_6_test>>
<<myapply_print_6_test>>
<<myapply_evlis_6_test>>
<<myapply_list_6_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))))

Добавляем еще один nil

;; Тесты 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)))

Добавляем еще один nil

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

Добавляем еще один nil

;; Тесты для сложения
(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

Чтобы передать go-env в 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))

Добавляем еще один nil

;; Тесты для применения 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))))

Добавляем еще один nil

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

Добавляем go-env.

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

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

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

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

MyEval

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

  • tagbody
  • go
<<myeval_evcond_6>>
<<myeval_evprogn_6>>
<<myeval_evand_6>>
<<myeval_evor_6>>
<<myeval_mypairlis_6>>
<<myeval_evlet_6>>
<<myeval_evletstar_6>>
<<myeval_evtagbody_6>>
(defun myeval (exp env block-env go-env catch-env errcont cont)
  (cond
    <<myeval_number_6>>
    <<myeval_symb_6>>
    <<myeval_quote_6>>
    <<myeval_if_6>>
    <<myeval_cond_6>>
    <<myeval_progn_6>>
    <<myeval_and_6>>
    <<myeval_or_6>>
    <<myeval_let_6>>
    <<myeval_letstar_6>>
    <<myeval_defun_6>>
    <<myeval_setq_6>>
    <<myeval_lambda_6>>
    <<myeval_block_6>>
    <<myeval_return_from_6>>
    <<myeval_catch_6>>
    <<myeval_throw_6>>
    <<myeval_tagbody_6>>
    <<myeval_go_6>>
    (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_6_test>>
<<myeval_symb_6_test>>
<<myeval_quote_6_test>>
<<myeval_if_6_test>>
<<myeval_evcond_6_test>>
<<myeval_cond_6_test>>
<<myeval_evprogn_6_test>>
<<myeval_progn_6_test>>
<<myeval_evand_6_test>>
<<myeval_and_6_test>>
<<myeval_evor_6_test>>
<<myeval_or_6_test>>
<<myeval_mypairlis_6_test>>
<<myeval_evlet_6_test>>
<<myeval_let_6_test>>
<<myeval_evletstar_6_test>>
<<myeval_letstar_6_test>>
<<myeval_defun_6_test>>
<<myeval_setq_6_test>>
<<myeval_lambda_6_test>>
<<myeval_block_6_test>>
<<myeval_return_from_6_test>>
<<myeval_catch_6_test>>
<<myeval_throw_6_test>>
<<myeval_tagbody_6_test>>
<<myeval_go_6_test>>

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

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

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

;; Тесты для самовычисляемых форм
(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))

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

;; Тесты для вычисления символов
(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)))

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

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

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

Пробрасываем go-env:

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

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

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

Пробрасываем go-env:

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

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

((equal (car exp) 'cond)     (evcond (cdr exp)
                                     env block-env go-env catch-env
                                     errcont cont))

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

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

Пробрасываем go-env:

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

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

((equal (car exp) 'progn)    (evprogn (cdr exp)
                                      env block-env go-env catch-env
                                      errcont cont))

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

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

Пробрасываем go-env:

(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

Пробрасываем go-env:

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

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

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

Добавляем go-env:

(defun evlet (vars exps evald-exps exp env block-env go-env catch-env errcont cont)
  (cond ((null exps)  (evprogn exp
                               (pairlis vars (reverse evald-exps) env)
                               block-env go-env catch-env
                               errcont cont))
        (t            (myeval (car exps) env block-env go-env catch-env errcont
                              (lambda (x)
                                (evlet vars (cdr exps) (cons x evald-exps) exp
                                       env block-env go-env catch-env
                                       errcont cont))))))

Добавляем еще один nil

;; Тесты для EVLET
(assert (equal 3 (evlet '(a b) '(1 2) nil '(4 (+ a b)) nil nil nil nil #'err #'ok)))

Добавляем go-env:

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

Добавляем еще один nil

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

LET*

Пробрасываем go-env:

(defun evletstar (varpairs exp env block-env go-env catch-env errcont cont)
  (cond ((null varpairs)  (evprogn exp env block-env go-env catch-env errcont cont))
        (t                (myeval (cadar varpairs) env block-env go-env catch-env errcont
                                  (lambda (x)
                                    (evletstar (cdr varpairs) exp
                                               (acons (caar varpairs) x env)
                                               block-env go-env catch-env
                                               errcont cont))))))

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

;; Тесты для EVLETSTAR
(assert (equal 2 (evletstar '((a 1) (b a)) '(4 (+ a b)) nil nil nil nil #'err #'ok)))

Добавляем go-env в вызов:

((equal (car exp) 'let*)     (evletstar (cadr exp)
                                        (cddr exp)
                                        env block-env go-env catch-env
                                        errcont cont))

Добавляем еще один nil

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

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

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

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

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

Пробрасываем go-env:

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

Тесты получают дополнительный 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

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

((equal (car exp) 'lambda)   (funcall cont (make-closure :body (cddr exp)
                                                         :env env
                                                         :block-env block-env
                                                         :go-env go-env
                                                         :args (cadr exp))))

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

;; Тесты для LAMBDA
(assert (equal 3 (myeval '((lambda (x) (+ 1  x)) 2)
                         nil nil nil nil #'err #'ok)))
;; Тесты для LAMBDA в окружении
(assert (equal 5 (myeval '(let ((y 3))
                           ((lambda (x) (+ y x)) 2))
                         nil nil nil nil #'err #'ok)))
;; Тесты на IMPLICIT-PROGN в LAMBDA
(assert (equal 8 (myeval '(let ((y 3))
                           ((lambda (x)
                              (setq y 6)
                              (+ y x)) 2))
                         nil nil nil nil #'err #'ok)))

BLOCK

Пробрасываем go-env:

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

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

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

Пробрасываем go-env:

((equal (car exp)
        'return-from)        (if (not (symbolp (cadr exp)))
                                 (funcall errcont
                                          (format nil
                                                  "return-from: first argument not a symbol"))
                                 (myeval (caddr exp) env block-env 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))))))))

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

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

Пробрасываем go-env:

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

Тесты получают дополнительный 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

Пробрасываем go-env:

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

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

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

Когда мы хотим обрабатывать формы вида:

(tagbody
 a
   (progn 1)
 b
   (progn 2)
 c
   (progn))

Мы хотим иметь возможность с помощью go переходить в любую из форм, из тех что лежат за метками. Для того чтобы обеспечить это, мы должны нарезать форму tagbody на "хвосты", каждый из которых представляет собой остаток формы, отрезанный от метки:

((TAGBODY (A (PROGN 1) (B (PROGN 2) (C (PROGN)))))
 (A (PROGN 1) (B (PROGN 2) (C (PROGN))))
 (B (PROGN 2) (C (PROGN)))
 (C (PROGN)))

Это дает нам возможность найти такой остаток по метке. Функция tagbody-slice делает это:

(defun tagbody-slice (exp)
  (cond ((null exp)           nil)
        ((symbolp (car exp))  (cons exp  (tagbody-slice (cdr exp))))
        (t                    (tagbody-slice (cdr exp)))))

Однако мы можем сделать хвосторекурсивный ее вариант:

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

Он выдает нам результат в обратном порядке:

((C (PROGN))
 (B (PROGN 2) (C (PROGN)))
 (A (PROGN (C (PROGN))) (B (PROGN 2) (C (PROGN))))
 (TAGBODY (A (PROGN (C (PROGN))) (B (PROGN 2) . (C (PROGN))))))

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

После этого мы добавим список этих точечных пар к окружению go-env и перезапишем go-env чтобы сделать его циклическим. Если не сделать циклический go-env то мы не сможем например дважды перейти по одной метке.

Однако нам потребуется еще проверить ситуации, когда одна и та же метка встречается дважды. Это делает функция tagbody-check-tag.

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

Теперь мы почти готовы написать evtagbody, задача которого - рекурсивно евалить формы внутри tagbody

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

И, наконец, закончим определением в myeval

((equal (car exp) 'tagbody)  (tagbody-check-tag (cdr exp)
                                                (lambda ()
                                                  (setq go-env
                                                        (append (mapcar #'(lambda (x)
                                                                            (cons (car x)
                                                                                  (lambda ()
                                                                                    (evtagbody x env block-env go-env catch-env errcont cont))))
                                                                        (tagbody-slice (cdr exp) nil))
                                                                go-env))
                                                  (evtagbody (cdr exp) env block-env
                                                             go-env
                                                             catch-env errcont cont))
                                                (lambda (x)
                                                  (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

При создании go мы ищем в go-env соответствующую пару по имени и вызываем продолжение. Если такая пара не найдена - это ошибка.

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

REPL

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

Итоги

;; CPS-версия ASSOC
<<assoc_6>>
;; Классы ошибок
<<errors_6>>
;; Новая функция lookup
<<lookup_6>>
;; Структура замыкания
<<closure_6>>
;; CPS-вариант MYAPPLY и все что к нему относится
<<myapply_6>>
;; CPS-вариант MYEVAL и все что к нему относится
<<myeval_6>>
;; Тестируем новый lookup
<<lookup_6_test>>
;; Функции для тестирования CPS-функций
<<ok_err_6>>
;; Тесты для MYAPPLY
<<myapply_6_test>>
;; Тесты для MYEVAL
<<myeval_6_test>>
;; REPL
<<repl_6>>
;; (repl)

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

;; CPS-версия ASSOC
(defun assoc-2 (key alist cont errcont) ;; NB!: inverted order of
  ;; continuations (for lookup)
  (cond ((null alist)              (funcall errcont key))
        ((equal key (caar alist))  (funcall cont    (cdar alist)))
        (t                         (assoc-2 key (cdr alist) cont errcont))))
;; Классы ошибок
(define-condition unknown-function (error)
  ((fn :initarg :fn  :reader fn))
  (:report
   (lambda (condition stream)
     (format stream "Error in MYAPPLY: unknown-function: ~A"
             (fn condition)))))
(define-condition invalid-number-of-arguments (error)
  ((fn :initarg :fn  :reader fn))
  (:report
   (lambda (condition stream)
     (format stream "Error in MYAPPLY: invalid-number-of-arguments: ~A"
             (fn condition)))))
(define-condition mypairlis-error (error)
  ((lst1 :initarg :lst1  :reader lst1)
   (lst2 :initarg :lst2  :reader lst2))
  (:report
   (lambda (condition stream)
     (format stream "Error in MYPAIRLIS: wrong params:~%'~A~%'~A"
             (lst1 condition) (lst2 condition)))))
;; Новая функция lookup
;; environment
(defparameter *glob-env* nil)
;; lookup
(defun lookup (symb env errcont cont)
  (assoc-2 symb env cont
           (lambda (key)
             (assoc-2 key *glob-env* cont
                      (lambda (key)
                        (funcall errcont
                                 (format
                                  nil
                                  "UNBOUD VARIABLE [~A] ~%LOCAL ENV: [~A] ~%GLOBAL ENV: [~A]"
                                  key env *glob-env*)))))))
;; Структура замыкания
(defstruct closure
  body
  env
  block-env
  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)              (myeval (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))
    (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))  (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)      (funcall cont (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 (cadddr 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 (caddr 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)))))
    (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)))
;; Тесты для 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)))
;; REPL
(defun repl ()
  (princ "microlisp>")
  (finish-output)
  (princ (myeval (read) nil #'identity #'identity))
  (terpri)
  (finish-output)
  (repl))
;; (repl)
Яндекс.Метрика
Home