lisp-2

Table of Contents

План работ

Ранее мы научили наш лисп вычислять символы в окружении. Однако в нем пока еще невозможно определить функцию вне того места, где она применяется. Чтобы добавить эту функциональность нам нужен defun.

Поскольку для простоты мы будем помещать и переменные и функции в одно и то же глобальное окружение (таким образом наш лисп будет являться lisp1) мы можем аналогичным образом сделать setq.

Чтобы сделать эти две вещи мы должны научиться искать и выполнять присваивание в глобальном окружении.

Также, в этом этапе у нас появляется разделение на функции и специальные операторы. В отличии от функций, специальные операторы могут не вычислять свои аргументы. Чтобы применять функции к их вычисленным аргументам мы добавим myapply. В myapply мы будем помещать встроенные функциии, а в myeval останутся специальные операторы.

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

Создадим переменную, которая будет хранить глобальное окружение. Еще нам понадобится lookup. Это функция, которая ищет (и возвращает) значение переданного ей символа сначала в локальном, а потом, если в локальном окружении символ не найден, и в глобальном окружении.

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

MyApply

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

Если в 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_2>>
(defun myapply (fn args env)
  (cond
    <<myapply_car_cdr_cons_2>>
    <<myapply_null_2>>
    <<myapply_ariph_2>>
    <<myapply_func_symb_2>>
    <<myapply_lambda_2>>
    (t (error 'unknown-function :fn fn))))

И отдельно вынесем тесты:

<<myapply_car_cdr_cons_2_test>>
<<myapply_null_2_test>>
<<evaddmul_2_test>>
<<myapply_ariph_2_test>>
<<myapply_func_symb_2_test>>
<<myapply_lambda_2_test>>

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

Добавлено вычисление символов-функций, так, чтобы использовать lookup в глобальном окружении.

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

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

NULL-предикат

Здесь мы добавим ошибку, если в 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))
                                 (null (car args))
                                 (error 'invalid-number-of-arguments :fn fn)))

[TODO:gmm] Надо проверять в тестах возникновение этой ошибки:

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

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

Из-за того, что теперь арифметические функции вызываются из myapply (см. раздел MyEval), функции evadd и evmul получают уже вычисленные (оцененные, evaled) аргументы. Поэтому им теперь не нужно вызывать myeval для аргументов.

Раз им не нужно вызывать myeval, то больше нет нужды в параметре env, поэтому его тоже можно убрать.

(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 и evmul те, которые проверяют, могут ли evadd и evmul вычислить вложенную форму, такую как, например,

(evadd '(2 (+ 3 4)) 0 nil)

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

Убираем лишние тесты:

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

Вычисление символов-функций

Нам нужно вычислить функцию по ее символу, стоящему в начале списка.

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

(define-condition function-not-found-in-env-error (error)
  ((fn :initarg :fn  :reader fn))
  (:report
   (lambda (condition stream)
     (format stream "Error in MYAPPLY: function not found in env: ~A"
             (fn condition)))))

И будем сигнализировать ее в этой ситуации:

((symbolp fn)                (let ((it (lookup fn env)))
                               (if (null it)
                                   (error 'function-not-found-in-env-error :fn fn)
                                   (myapply (cdr it) args env))))
;; Тесты для вычисления символов-функций
(assert (equal 49 (myeval '(alfa beta) '((alfa . (lambda (x) (* x x)))
                                         (beta . 7)))))
;; Эта часть закомментирована, так как мы всегда получим ошибку
;; "переменная не найдена", а не "функция не найдена"
;; (assert (equal "error"
;;                (handler-case (myeval '(alfa beta) '((beta . 7)))
;;                  (FUNCTION-NOT-FOUND-IN-ENV-ERROR (condition) "error"))))

LAMBDA

((equal (car fn) 'lambda)    (myeval (car (cddr fn))
                                     (pairlis (car (cdr fn))
                                              args
                                              env)))
(assert (equal '(42 . 42) (myeval '((lambda (x)
                                      (cons x x))
                                    42) nil)))
(assert (equal '(42 . 17) (myeval '((lambda (x y)
                                      (cons x y))
                                    42 17) nil)))

MyEval

Большинство компонентов myeval остаются без изменений. Но, теперь, имея глобальное окружение мы можем определить defun и setq. Иметь глобальное окружение - это не единственный и возможно не самый лучший способ получить defun и setq:

  • В Common Lisp, например, нет глобального окружения вообще. Т.е. defun в CL работает с самим символом, а не с окружением. Это, очевидно, ошибка первых разработчиков лиспа, унаследованная CL. Почему?
    • Во-первых, возникает различия в реализации локальных и глобальных переменных. Похожие концепции должны быть реализованны одинаково (consistency). В ранних лиспах такого несоответсвия не было, т.к. в символах хранились и локальные переменные. Такая реализация называлась shallow binding. Shallow binding — значения хранятся в символах, deep binding - значения хранятся в окружениях. Shallow binding осложнила переход к lexical scope, т.к. нет простой реализации lexical scope в shallow binding.
    • Во-вторых, попытка сделать модули в shallow binding приводит к пакетам CL, что плохо. Пакеты — самая глупая идея CL. Обобщить же окружения на случай модулей довольно просто — это система локалей языка T. [TODO:gmm] Подробнее рассказать про локали языка Т.
  • В "чистой" семантике, при реализации setq мы не вызываем rplacd, а при реализации defun не пользуемся setq, т.е. не ссылаемся на фонноймановскую машину. https://groups.csail.mit.edu/mac/ftpdir/scheme-mail/HTML/rrrs-1988/msg00134.html http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.133.1426&rep=rep1&type=pdf

Второе важное изменение связано с разделением интерпретатора на две части: myapply и myeval. Мы больше не формируем ошибку, если ни одно из условий COND в myeval не совпало с формой. Вместо этого мы предополагаем, что это вызов функции, а значит необходимо оценить его аргументы и передать в в myapply:

  • имя функци
  • вычисленные аргументы
  • окружение

И наконец третье изменение, совсем небольшое, происходит из-за того, что мы сделаем вызов evlis хвосторекурсивным. Это добавляет дополнительный параметр-аккумулятор в вызов evlis. См раздел LIST для подробностей.

<<myeval_evcond_2>>
<<myeval_evprogn_2>>
<<myeval_evlis_2>>
<<myeval_evand_2>>
<<myeval_evor_2>>
<<myeval_mypairlis_2>>
<<myeval_evletstar_2>>
(defun myeval (lst env)
  (cond
    <<myeval_number_2>>
    <<myeval_symb_2>>
    <<myeval_quote_2>>
    <<myeval_if_2>>
    <<myeval_cond_2>>
    <<myeval_progn_2>>
    <<myeval_print_2>>
    <<myeval_list_2>>
    <<myeval_and_2>>
    <<myeval_or_2>>
    <<myeval_let_2>>
    <<myeval_letstar_2>>
    <<myeval_defun_2>>
    <<myeval_setq_2>>
    <<myeval_lambda_2>>
    (t
     (myapply (myeval (car lst) env)
              (evlis (cdr lst) nil env)
              env))))

Также определим тесты

<<myeval_number_2_test>>
<<myeval_symb_2_test>>
<<myeval_quote_2_test>>
<<myeval_if_2_test>>
<<myeval_evcond_2_test>>
<<myeval_cond_2_test>>
<<myeval_evprogn_2_test>>
<<myeval_progn_2_test>>
<<myeval_print_2_test>>
<<myeval_evlis_2_test>>
<<myeval_list_2_test>>
<<myeval_evand_2_test>>
<<myeval_and_2_test>>
<<myeval_evor_2_test>>
<<myeval_or_2_test>>
<<myeval_let_2_test>>
<<myeval_letstar_2_test>>
<<myeval_defun_2_test>>
<<myeval_setq_2_test>>
<<myeval_lambda_2_test>>

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

Добавляем в самовычисляемые формы car cdr cons и null, потому что мы добавляем рекурсивное вычисление форм в конец cond в myeval. Если мы не сделаем это - эти символы будут пытаться вычислиться как символы в окружении.

((null lst)                  nil)
((equal t lst)               t)
((member lst '(+ * car cdr cons null))  lst)
((numberp lst)               lst)
;; Тесты для самовычисляемых форм
(assert (equal T (myeval 'T nil)))
(assert (equal NIL (myeval 'NIL nil)))
(assert (equal 999 (myeval 999 nil)))

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

Добавим ошибку, если символ не найден в окружении

(define-condition var-not-found-error (error)
  ((vari :initarg :vari  :reader vari))
  (:report
   (lambda (condition stream)
     (format stream "Error in MYEVAL: variable not found: ~A"
             (vari condition)))))

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

((symbolp lst)               (let ((it (lookup lst env)))
                               (if (null it)
                                   (error 'var-not-found-error :vari lst)
                                   (cdr it))))
;; Тесты для вычисления символов в окружении
(assert (equal 6 (myeval 'b '((a . 3) (b . 6)))))
(assert (equal "error"
               (handler-case (myeval 'b nil)
                 (VAR-NOT-FOUND-ERROR (condition) "error"))))

Цитирование

((equal (car lst) 'quote)    (cadr lst))
;; Тесты для QUOTE
(assert (equal '(+ 1 2) (myeval '(quote (+ 1 2)) nil)))

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

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

COND

(defun evcond (lst env)
  (cond ((null lst)               nil)
        ((myeval (caar lst) env)  (myeval (cadar lst) env))
        (t                        (evcond (cdr lst) env))))
;; Тесты для EVCOND
(assert (equal 2   (evcond '((t 2)   (t 1)) nil)))
(assert (equal 1   (evcond '((nil 2) (t 1)) nil)))
(assert (equal nil (evcond '((nil 2) (nil 1)) nil)))
;; Тесты для EVCOND, где участвует окружение
(assert (equal 2 (evcond '((a 2) (b 1))
                         '((a . 1) (b . ())))))
(assert (equal 1 (evcond '((a 2) (b 1))
                         '((a . nil) (b . T)))))
((equal (car lst) 'cond)     (evcond (cdr lst) env))
;; Тесты для COND
(assert (equal 2 (myeval '(cond
                           (() 1)
                           (1 2))
                         nil)))
;; Тесты для COND в окружении
(assert (equal 2 (myeval '(cond
                         (a 1)
                         (b 2))
                       '((a . ()) (b . 1)))))
(assert (equal 1 (myeval '(cond
                           (a 1)
                           (b 2))
                         '((a . 1) (b . ())))))

PROGN

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

Без изменений

((equal (car lst) 'progn)    (evprogn (cdr lst) env))

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

;; Тест для PROGN
(assert (equal 3 (myeval '(progn 1 2 3) nil)))
;; Тест для PROGN в окружении
(assert (equal 3 (myeval '(progn a b c) '((a . 1) (b . 2) (c . 3)))))

PRINT

((equal (car lst) 'print)    (print (myeval (cadr lst)  env)))
;; Тесты для PRINT
(assert (equal (with-output-to-string (*standard-output*)
                 (print 12))
               (with-output-to-string (*standard-output*)
                 (myeval '(print 12) nil))))
(assert (equal (print 12)
               (myeval '(print 12) nil)))
;; Тесты для 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))))))
(assert (equal (let ((a 12))
                 (print a))
               (myeval '(print a) '((b . 23) (a . 12)))))

LIST

Улучшим наш evlis, сделав его хвосторекурсивным. Для этого добавим параметр-аккумулятор, который будет накапливать результат вычисления. Итак, evlis, полученный на предыдущем шаге выглядит так:

(defun evlis (lst env)
  (cond ((null lst)  nil)
        (t           (cons (myeval (car lst) env)
                           (evlis (cdr lst) env)))))

Переименуем lst в unevaled:

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

Преобразуем рекурсию в хвостовую с аккумулятором:

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

Теперь, на каждом шаге рекурсии evlis берет первый элемент списка unevaled и оценивает его. Результат оценки добавляется в начало списка evaled. Когда рекурсия завершается (т.е. unevaled пуст) мы переворачиваем список evaled, чтобы восстановить правильный порядок. Таким образом, получается что хвосторекурсивный evlis эффективно оценивает все переданные ему формы в окружении env.

Протестируем новый evlis

;; Тесты для EVLIS
(assert (equal '(3 6 42)
               (evlis '((+ 1 2) (* 2 3) 42) nil nil)))
;; Тесты для EVLIS в окружении
(assert (equal '(3 6 42)
               (evlis '((+ a b) (* b c) 42)
                      nil
                      '((a . 1) (b . 2) (c . 3) (d . 4)))))

Вызывать evlis теперь следует с дополнительным параметром-аккумулятором

((equal (car lst) 'list)     (evlis (cdr lst) nil env))
;; Тесты для LIST
(assert (equal '(3 6 42)
               (myeval '(list (+ 1 2) (* 2 3) 42) nil)))
;; Тесты для LIST в окружении
(assert (equal '(3 6 42)
               (myeval '(list (+ a b) (* b c) 42)
                       '((a . 1) (b . 2) (c . 3) (d . 4)))))

AND

(defun evand (args env)
  (cond ((null args)        T)
        ((null (cdr args))  (myeval (car args) env))
        (t                  (let ((tmp (myeval (car args) env)))
                              (if (null tmp)
                                  nil
                                  (evand (cdr args) env))))))
;; Тесты для EVAND
(assert (equal (and)           (evand '() nil)))
(assert (equal (and 1)         (evand '(1) nil)))
(assert (equal (and nil)       (evand '(nil) nil)))
(assert (equal (and 1 nil)     (evand '(1 nil) nil)))
(assert (equal (and 1 2 nil)   (evand '(1 2 nil) nil)))
(assert (equal (and 1 2 3)     (evand '(1 2 3) nil)))
(assert (equal (and 1 2 nil 3) (evand '(1 2 nil 3) nil)))
;; Тесты для EVAND в окружении
(assert (equal (let ((a nil))
                 (and nil))
               (evand '(a) '((a . nil)))))
(assert (equal (let ((a 1))
                 (and a))
               (evand '(a) '((a . 1)))))
(assert (equal (let ((a 1)
                     (b nil))
                 (and a b))
               (evand '(a b) '((a . 1) (b . nil)))))
(assert (equal (let ((a 1)
                     (b 2)
                     (c nil))
                 (and a b c))
               (evand '(a b c) '((a . 1) (b . 2) (c . nil)))))
(assert (equal (let ((a 1)
                     (b 2)
                     (c 3))
                 (and a b c))
               (evand '(a b c) '((a . 1) (b . 2) (c . 3)))))
(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)))))
((equal (car lst) 'and)      (evand (cdr lst) env))
;; Тесты для AND
(assert (equal (and)                  (myeval '(and) nil)))
(assert (equal (and 1)                (myeval '(and 1) nil)))
(assert (equal (and nil)              (myeval '(and nil) nil)))
(assert (equal (and 1 nil)            (myeval '(and 1 nil) nil)))
(assert (equal (and 1 2 nil)          (myeval '(and 1 2 nil) nil)))
(assert (equal (and 1 2 3)            (myeval '(and 1 2 3) nil)))
(assert (equal (and 1 2 nil 3)        (myeval '(and 1 2 nil 3) nil)))
(assert (equal (and 1 (and 1 2) 3)    (myeval '(and 1 (and 1 2) 3) nil)))
(assert (equal (and 1 (and 1 nil) 3)  (myeval '(and 1 (and 1 nil) 3) nil)))
;; Тесты для AND в окружении
(assert (equal (let ((a nil))
                 (and nil))
               (myeval '(and a) '((a . nil)))))
(assert (equal (let ((a 1))
                 (and a))
               (myeval '(and a) '((a . 1)))))
(assert (equal (let ((a 1)
                     (b nil))
                 (and a b))
               (myeval '(and a b) '((a . 1) (b . nil)))))
(assert (equal (let ((a 1)
                     (b 2)
                     (c nil))
                 (and a b c))
               (myeval '(and a b c) '((a . 1) (b . 2) (c . nil)))))
(assert (equal (let ((a 1)
                     (b 2)
                     (c 3))
                 (and a b c))
               (myeval '(and a b c) '((a . 1) (b . 2) (c . 3)))))
(assert (equal (let ((a 1)
                     (b 2)
                     (c nil)
                     (d 3))
                 (and a b c d))
               (myeval '(and a b c) '((a . 1) (b . 2) (c . nil) (d . 3)))))
(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)))))
(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)))))

[TODO:gmm] Отсюда и далее добавить тестов на побочные эффекты and

OR

(defun evor (args env)
  (cond ((null args)        nil)
        ((null (cdr args))  (myeval (car args) env))
        (t                  (let ((tmp (myeval (car args) env)))
                              (if (not (null tmp))
                                  tmp
                                  (evor (cdr args) env))))))
;; Тесты для EVOR
(assert (equal (or)                   (evor '() nil)))
(assert (equal (or nil 1)             (evor '(nil 1) nil)))
(assert (equal (or nil nil 1)         (evor '(nil nil 1) nil)))
(assert (equal (or nil 1 2)           (evor '(nil 1 2) nil)))
(assert (equal (or 1 2 3)             (evor '(1 2 3) nil)))
(assert (equal (or nil nil 3 nil)     (evor '(nil nil 3 nil) nil)))
;; Тесты для EVOR в окружении
(assert (equal (let ((a nil))
                 (or a))
               (evor '(a) '((a . nil)))))
(assert (equal (let ((a 1))
                 (or a))
               (evor '(a) '((a . 1)))))
(assert (equal (let ((a nil)
                     (b 1))
                 (or a b))
               (evor '(a b) '((a . nil) (b . 1)))))
(assert (equal (let ((a nil)
                     (b nil)
                     (c 3))
                 (or a b c))
               (evor '(a b c) '((a . nil) (b . nil) (c . 3)))))
(assert (equal (let ((a nil)
                     (b 1)
                     (c 2))
                 (or a b c))
               (evor '(a b c) '((a . nil) (b . 1) (c . 2)))))
(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)))))
((equal (car lst) 'or)       (evor  (cdr lst) env))
;; Тесты для OR
(assert (equal (or)                  (myeval '(or) nil)))
(assert (equal (or nil 1)            (myeval '(or nil 1) nil)))
(assert (equal (or nil nil 1)        (myeval '(or nil nil 1) nil)))
(assert (equal (or nil 1 2)          (myeval '(or nil 1 2) nil)))
(assert (equal (or nil (or 3 2) 2)   (myeval '(or nil (or 3 2) 2) nil)))
;; Тесты для OR в окружении
(assert (equal (let ((a nil))
                 (or a))
               (myeval '(or a) '((a . nil)))))
(assert (equal (let ((a 1))
                 (or a))
               (myeval '(or a) '((a . 1)))))
(assert (equal (let ((a nil)
                     (b 1))
                 (or a b))
               (myeval '(or a b) '((a . nil) (b . 1)))))
(assert (equal (let ((a nil)
                     (b nil)
                     (c 3))
                 (or a b c))
               (myeval '(or a b c) '((a . nil) (b . nil) (c . 3)))))
(assert (equal (let ((a nil)
                     (b 1)
                     (c 2))
                 (or a b c))
               (myeval '(or a b c) '((a . nil) (b . 1) (c . 2)))))
(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)))))

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

Добавляем еще один параметр к вызову evlis

((equal (car lst) 'let)      (evprogn (cddr lst) ; implicit progn
                                      (pairlis (mapcar #'car (cadr lst))
                                               (evlis (mapcar #'cadr (cadr lst))
                                                      nil
                                                      env)
                                               env)))
;; Тест для LET
(assert (equal '(1 . 2) (myeval '(let ((a 1)
                                       (b 2))
                                  (cons a b)) nil)))

LET*

(defun evletstar (varpairs exp env)
  (cond ((null varpairs)  (myeval exp env))
        (t                (evletstar (cdr varpairs)
                                     exp
                                     (cons (cons (caar varpairs)
                                                 (myeval (cadar varpairs) env))
                                           env)))))
((equal (car lst) 'let*)     (evletstar (cadr lst)
                                        (caddr lst)
                                        env))
;; Тест для LET*
(assert (equal '(3 1 . 2) (myeval '(let* ((a 1)
                                          (b 2)
                                          (c (+ a b)))
                                    (cons c (cons a b))) nil)))

DEFUN

defun определяем, добавляя в глобальное окружение переменную, содержащую лямбду. Чтобы обеспечит implicit progn мы оборачиваем содержимое лямбды в progn. В соответствии со стандартом defun возвращает имя функции при успешном выполнении.

((equal (car lst) 'defun)    (progn
                               (push (cons (cadr lst)
                                           `(lambda ,(caddr lst)
                                              (progn ,@(cdddr lst))))
                                     *glob-env*)
                               (cadr lst)))

Необходимо протестировать defun:

;; Тест для DEFUN
(assert (equal 49 (progn
                    (setf *glob-env* nil)
                    (prog1 (myeval '(progn
                                     (defun alfa (x) (* x x))
                                     (alfa 7))
                                   nil)
                      (setf *glob-env* nil)))))

SETQ

setq добавляет переменную в глобальное окружение, если lookup не смог ее найти. Иначе он заменяет ее значение.

((equal (car lst) 'setq)     (let ((it (lookup (cadr lst) env))
                                   (val (myeval (caddr lst) env)))
                               (if (null it)
                                   (push (cons (cadr lst) val)
                                         *glob-env*)
                                   (rplacd it val))
                               val))

Тестируем:

;; Тест для SETQ
(assert (equal 49 (progn
                    (setf *glob-env* nil)
                    (prog1 (myeval '(progn
                                     (defun alfa (x) (* x x))
                                     (setq beta 7)
                                     (alfa beta))
                                   nil)
                      (setf *glob-env* nil)))))

LAMBDA

В динамическом окружении мы вычисляем лямбду в саму себя

((equal (car lst) 'lambda)   lst)
;; Тест для LAMBDA
(assert (equal '(42 . 42) (myeval '((lambda (x)
                                      (cons x x))
                                    42) nil)))
(assert (equal '(42 . 17) (myeval '((lambda (x y)
                                      (cons x y))
                                    42 17) nil)))

REPL

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

Итоги

<<errors_2>>
<<lookup_2>>
<<myapply_2>>
<<myeval_2>>
<<repl_2>>
<<myapply_2_test>>
<<myeval_2_test>>

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

(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 function-not-found-in-env-error (error)
  ((fn :initarg :fn  :reader fn))
  (:report
   (lambda (condition stream)
     (format stream "Error in MYAPPLY: function not found in env: ~A"
             (fn condition)))))
(define-condition var-not-found-error (error)
  ((vari :initarg :vari  :reader vari))
  (:report
   (lambda (condition stream)
     (format stream "Error in MYEVAL: variable not found: ~A"
             (vari 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)))))
(defparameter *glob-env* nil)
(defun lookup (symb env)
  (let ((it (assoc symb env)))
    (if (not (null it))
        it
        (assoc symb *glob-env*))))
(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 myapply (fn args env)
  (cond
    ((equal fn 'car)             (caar args))
    ((equal fn 'cdr)             (cdar args))
    ((equal fn 'cons)            (cons (car args) (cadr args)))
    ((equal fn 'null)            (if (null (cdr args))
                                     (null (car args))
                                     (error 'invalid-number-of-arguments :fn fn)))
    ((equal fn '+)               (evadd args 0))
    ((equal fn '*)               (evmul args 1))
    ((symbolp fn)                (let ((it (lookup fn env)))
                                   (if (null it)
                                       (error 'function-not-found-in-env-error :fn fn)
                                       (myapply (cdr it) args env))))
    ((equal (car fn) 'lambda)    (myeval (car (cddr fn))
                                         (pairlis (car (cdr fn))
                                                  args
                                                  env)))
    (t (error 'unknown-function :fn fn))))
(defun evcond (lst env)
  (cond ((null lst)               nil)
        ((myeval (caar lst) env)  (myeval (cadar lst) env))
        (t                        (evcond (cdr lst) env))))
(defun evprogn (lst env)
  (cond ((null lst)        nil)
        ((null (cdr lst))  (myeval (car lst) env))
        (t                 (myeval (car lst) env)
                           (evprogn (cdr lst) env))))
(defun evlis (unevaled evaled env)
  (cond ((null unevaled)  (reverse evaled))
        (t                (evlis (cdr unevaled)
                                 (cons (myeval (car unevaled) env)
                                       evaled)
                                 env))))
(defun evand (lst env)
  (cond ((null lst)        (and))
        ((null (cdr lst))  (and (myeval (car lst) env)))
        (t                 (and (myeval (car lst) env)
                                (evand (cdr lst) env)))))
(defun evor (lst env)
  (cond ((null lst)        (or))
        ((null (cdr lst))  (or (myeval (car lst) env)))
        (t                 (or (myeval (car lst) env)
                               (evor (cdr lst) env)))))
(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 evletstar (varpairs exp env)
  (cond ((null varpairs)  (myeval exp env))
        (t                (evletstar (cdr varpairs)
                                     exp
                                     (cons (cons (caar varpairs)
                                                 (myeval (cadar varpairs) env))
                                           env)))))
(defun myeval (lst env)
  (cond
    ((null lst)                  nil)
    ((equal t lst)               t)
    ((member lst '(+ * car cdr cons null))  lst)
    ((numberp lst)               lst)
    ((symbolp lst)               (let ((it (lookup lst env)))
                                   (if (null it)
                                       (error 'var-not-found-error :vari lst)
                                       (cdr it))))
    ((equal (car lst) 'quote)    (cadr lst))
    ((equal (car lst) 'if)       (if (myeval (cadr lst) env)
                                     (myeval (caddr lst) env)
                                     (myeval (cadddr lst) env)))
    ((equal (car lst) 'cond)     (evcond (cdr lst) env))
    ((equal (car lst) 'progn)    (evprogn (cdr lst) env))
    ((equal (car lst) 'print)    (print (myeval (cadr lst)  env)))
    ((equal (car lst) 'list)     (evlis (cdr lst) nil env))
    ((equal (car lst) 'and)      (evand (cdr lst) env))
    ((equal (car lst) 'or)       (evor  (cdr lst) env))
    ((equal (car lst) 'let)      (evprogn (cddr lst) ; implicit progn
                                          (pairlis (mapcar #'car (cadr lst))
                                                   (evlis (mapcar #'cadr (cadr lst))
                                                          nil
                                                          env)
                                                   env)))
    ((equal (car lst) 'let*)     (evletstar (cadr lst)
                                            (caddr lst)
                                            env))
    ((equal (car lst) 'defun)    (progn
                                   (push (cons (cadr lst)
                                               `(lambda ,(caddr lst)
                                                  ,(cadddr lst)))
                                         *glob-env*)
                                   (cadr lst)))
    ((equal (car lst) 'setq)     (let ((it (lookup (cadr lst) env))
                                       (val (myeval (caddr lst) env)))
                                   (if (null it)
                                       (push (cons (cadr lst) val)
                                             *glob-env*)
                                       (rplacd it val))
                                   val))
    ((equal (car lst) 'lambda)   lst)
    (t
     (myapply (myeval (car lst) env)
              (evlis (cdr lst) nil env)
              env))))
(defun repl ()
  (princ "microlisp>")
  (finish-output)
  (princ (myeval (read) nil))
  (terpri)
  (finish-output)
  (repl))
;; Тесты для cons-ячеек
(assert (equal '(1 . 2) (myeval '(cons 1 2) nil)))
(assert (equal '((1 . 2) 3 . 4) (myeval '(cons (cons 1 2) (cons 3 4)) nil)))
(assert (equal 2 (myeval '(car (cons 2 3)) nil)))
(assert (equal 3 (myeval '(cdr (cons 2 3)) nil)))
(assert (equal '(1 . 2) (myeval '(car (cons (cons 1 2) (cons 3 4))) nil)))
(assert (equal '(3 . 4) (myeval '(cdr (cons (cons 1 2) (cons 3 4))) nil)))
;; Тесты для cons-ячеек, вычисляемых в окружении
(assert (equal 1 (myeval '(car a) '((a . (1 . 2))))))
(assert (equal 2 (myeval '(cdr a) '((a . (1 . 2))))))
(assert (equal 3 (myeval '(car b) '((a . (1 . 2)) (b . (3 . 4))))))
;; Тесты для NULL
(assert (equal T (myeval '(null ()) nil)))
(assert (equal T (myeval '(null nil) nil)))
(assert (equal NIL (myeval '(null T) nil)))
(assert (equal T (myeval '(null a) '((a . ())))))
;; Тесты для NULL, с аргументом, вычисляемые в окружении
(assert (equal NIL (myeval '(null a) '((a . T)))))
(assert (equal NIL (myeval '(null a) '((a . 1)))))
;; Тесты для 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)))
(assert (equal (+ 2)            (myeval '(+ 2) nil)))
(assert (equal (+ 2 3)          (myeval '(+ 2 3) nil)))
(assert (equal (+ 2 3 4)        (myeval '(+ 2 3 4) nil)))
(assert (equal (+ 2 (+ 3 4))    (myeval '(+ 2 (+ 3 4)) nil)))
(assert (equal (+ 2 (+ 3 4) 5)  (myeval '(+ 2 (+ 3 4) 5) nil)))
;; Тесты для умножения
(assert (equal 1                (myeval '(*) nil)))
(assert (equal (* 2)            (myeval '(* 2) nil)))
(assert (equal (* 2 3)          (myeval '(* 2 3) nil)))
(assert (equal (* 2 3 4)        (myeval '(* 2 3 4) nil)))
(assert (equal (* 2 (* 3 4))    (myeval '(* 2 (* 3 4)) nil)))
(assert (equal (* 2 (* 3 4) 5)  (myeval '(* 2 (* 3 4) 5) nil)))
;; Тесты для сложения в окружении
(assert (equal 0
               (myeval '(+) nil)))
(assert (equal (let ((a 2))
                 (+ a))
               (myeval '(+ a)
                       '((a . 2)))))
(assert (equal (let ((a 2) (b 3))
                 (+ a b))
               (myeval '(+ a b)
                       '((a . 2) (b . 3)))))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (+ a b c))
               (myeval '(+ a b c)
                       '((a . 2) (b . 3) (c . 4)))))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (+ a (+ b c)))
               (myeval '(+ a (+ b c))
                       '((a . 2) (b . 3) (c . 4)))))
(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)))))
;; Тесты для умножения  в окружении
(assert (equal 1
               (myeval '(*) nil)))
(assert (equal (let ((a 2))
                 (* a))
               (myeval '(* a)
                       '((a . 2)))))
(assert (equal (let ((a 2) (b 3))
                 (* a b))
               (myeval '(* a b)
                       '((a . 2) (b . 3)))))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (* a b c))
               (myeval '(* a b c)
                       '((a . 2) (b . 3) (c . 4)))))
(assert (equal (let ((a 2) (b 3) (c 4))
                 (* a (* b c)))
               (myeval '(* a (* b c))
                       '((a . 2) (b . 3) (c . 4)))))
(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)))))
;; Тесты для вычисления символов-функций
(assert (equal 49 (myeval '(alfa beta) '((alfa . (lambda (x) (* x x)))
                                         (beta . 7)))))
;; Эта часть закомментирована, так как мы всегда получим ошибку
;; "переменная не найдена", а не "функция не найдена"
;; (assert (equal "error"
;;                (handler-case (myeval '(alfa beta) '((beta . 7)))
;;                  (FUNCTION-NOT-FOUND-IN-ENV-ERROR (condition) "error"))))
(assert (equal '(42 . 42) (myeval '((lambda (x)
                                      (cons x x))
                                    42) nil)))
(assert (equal '(42 . 17) (myeval '((lambda (x y)
                                      (cons x y))
                                    42 17) nil)))
;; Тесты для самовычисляемых форм
(assert (equal T (myeval 'T nil)))
(assert (equal NIL (myeval 'NIL nil)))
(assert (equal 999 (myeval 999 nil)))
;; Тесты для вычисления символов в окружении
(assert (equal 6 (myeval 'b '((a . 3) (b . 6)))))
(assert (equal "error"
               (handler-case (myeval 'b nil)
                 (VAR-NOT-FOUND-ERROR (condition) "error"))))
;; Тесты для QUOTE
(assert (equal '(+ 1 2) (myeval '(quote (+ 1 2)) nil)))
;; Тесты для IF
(assert (equal 2 (myeval '(if () 1 2) nil)))
(assert (equal 1 (myeval '(if (null ()) 1 2) nil)))
;; Тесты для IF, где условие вычисляется в окружении
(assert (equal 2 (myeval '(if a 1 2) '((a . ())))))
(assert (equal 1 (myeval '(if a 1 2) '((a . 1)))))
;; Тесты для EVCOND
(assert (equal 2   (evcond '((t 2)   (t 1)) nil)))
(assert (equal 1   (evcond '((nil 2) (t 1)) nil)))
(assert (equal nil (evcond '((nil 2) (nil 1)) nil)))
;; Тесты для EVCOND, где участвует окружение
(assert (equal 2 (evcond '((a 2) (b 1))
                         '((a . 1) (b . ())))))
(assert (equal 1 (evcond '((a 2) (b 1))
                         '((a . nil) (b . T)))))
;; Тесты для COND
(assert (equal 2 (myeval '(cond
                           (() 1)
                           (1 2))
                         nil)))
;; Тесты для COND в окружении
(assert (equal 2 (myeval '(cond
                           (a 1)
                           (b 2))
                         '((a . ()) (b . 1)))))
(assert (equal 1 (myeval '(cond
                           (a 1)
                           (b 2))
                         '((a . 1) (b . ())))))
;; Тест для EVPROGN
(assert (equal 2 (evprogn '(1 2) nil)))
;; Тест для EVPROGN в окружении
(assert (equal 3 (evprogn '(a b c) '((a . 1) (b . 2) (c . 3)))))
;; Тест для PROGN
(assert (equal 3 (myeval '(progn 1 2 3) nil)))
;; Тест для PROGN в окружении
(assert (equal 3 (myeval '(progn a b c) '((a . 1) (b . 2) (c . 3)))))
;; Тесты для PRINT
(assert (equal (with-output-to-string (*standard-output*)
                 (print 12))
               (with-output-to-string (*standard-output*)
                 (myeval '(print 12) nil))))
(assert (equal (print 12)
               (myeval '(print 12) nil)))
;; Тесты для 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))))))
(assert (equal (let ((a 12))
                 (print a))
               (myeval '(print a) '((b . 23) (a . 12)))))
;; Тесты для EVLIS
(assert (equal '(3 6 42)
               (evlis '((+ 1 2) (* 2 3) 42) nil nil)))
;; Тесты для EVLIS в окружении
(assert (equal '(3 6 42)
               (evlis '((+ a b) (* b c) 42)
                      nil
                      '((a . 1) (b . 2) (c . 3) (d . 4)))))
;; Тесты для LIST
(assert (equal '(3 6 42)
               (myeval '(list (+ 1 2) (* 2 3) 42) nil)))
;; Тесты для LIST в окружении
(assert (equal '(3 6 42)
               (myeval '(list (+ a b) (* b c) 42)
                       '((a . 1) (b . 2) (c . 3) (d . 4)))))
;; Тесты для EVAND
(assert (equal (and)           (evand '() nil)))
(assert (equal (and 1)         (evand '(1) nil)))
(assert (equal (and nil)       (evand '(nil) nil)))
(assert (equal (and 1 nil)     (evand '(1 nil) nil)))
(assert (equal (and 1 2 nil)   (evand '(1 2 nil) nil)))
(assert (equal (and 1 2 3)     (evand '(1 2 3) nil)))
;; Тесты для EVAND в окружении
(assert (equal (let ((a nil))
                 (and nil))
               (evand '(a) '((a . nil)))))
(assert (equal (let ((a 1))
                 (and a))
               (evand '(a) '((a . 1)))))
(assert (equal (let ((a 1)
                     (b nil))
                 (and a b))
               (evand '(a b) '((a . 1) (b . nil)))))
(assert (equal (let ((a 1)
                     (b 2)
                     (c nil))
                 (and a b c))
               (evand '(a b c) '((a . 1) (b . 2) (c . nil)))))
(assert (equal (let ((a 1)
                     (b 2)
                     (c 3))
                 (and a b c))
               (evand '(a b c) '((a . 1) (b . 2) (c . 3)))))
;; Тесты для AND
(assert (equal (and)                (myeval '(and) nil)))
(assert (equal (and 1)              (myeval '(and 1) nil)))
(assert (equal (and nil)            (myeval '(and nil) nil)))
(assert (equal (and 1 nil)          (myeval '(and 1 nil) nil)))
(assert (equal (and 1 2 nil)        (myeval '(and 1 2 nil) nil)))
(assert (equal (and 1 2 3)          (myeval '(and 1 2 3) nil)))
(assert (equal (and 1 (and 1 2) 3)  (myeval '(and 1 (and 1 2) 3) nil)))
;; Тесты для AND в окружении
(assert (equal (let ((a nil))
                 (and nil))
               (myeval '(and a) '((a . nil)))))
(assert (equal (let ((a 1))
                 (and a))
               (myeval '(and a) '((a . 1)))))
(assert (equal (let ((a 1)
                     (b nil))
                 (and a b))
               (myeval '(and a b) '((a . 1) (b . nil)))))
(assert (equal (let ((a 1)
                     (b 2)
                     (c nil))
                 (and a b c))
               (myeval '(and a b c) '((a . 1) (b . 2) (c . nil)))))
(assert (equal (let ((a 1)
                     (b 2)
                     (c 3))
                 (and a b c))
               (myeval '(and a b c) '((a . 1) (b . 2) (c . 3)))))
;; Тесты для EVOR
(assert (equal (or)           (evor '() nil)))
(assert (equal (or nil 1)     (evor '(nil 1) nil)))
(assert (equal (or nil nil 1) (evor '(nil nil 1) nil)))
(assert (equal (or nil 1 2)   (evor '(nil 1 2) nil)))
(assert (equal (or 1 2 3)     (evor '(1 2 3) nil)))
;; Тесты для EVOR в окружении
(assert (equal (let ((a nil))
                 (or a))
               (evor '(a) '((a . nil)))))
(assert (equal (let ((a 1))
                 (or a))
               (evor '(a) '((a . 1)))))
(assert (equal (let ((a nil)
                     (b 1))
                 (or a b))
               (evor '(a b) '((a . nil) (b . 1)))))
(assert (equal (let ((a nil)
                     (b nil)
                     (c 3))
                 (or a b c))
               (evor '(a b c) '((a . nil) (b . nil) (c . 3)))))
(assert (equal (let ((a nil)
                     (b 1)
                     (c 2))
                 (or a b c))
               (evor '(a b c) '((a . nil) (b . 1) (c . 2)))))
;; Тесты для OR
(assert (equal (or)                  (myeval '(or) nil)))
(assert (equal (or nil 1)            (myeval '(or nil 1) nil)))
(assert (equal (or nil nil 1)        (myeval '(or nil nil 1) nil)))
(assert (equal (or nil 1 2)          (myeval '(or nil 1 2) nil)))
(assert (equal (or nil (or 3 2) 2)   (myeval '(or nil (or 3 2) 2) nil)))
;; Тесты для OR в окружении
(assert (equal (let ((a nil))
                 (or a))
               (myeval '(or a) '((a . nil)))))
(assert (equal (let ((a 1))
                 (or a))
               (myeval '(or a) '((a . 1)))))
(assert (equal (let ((a nil)
                     (b 1))
                 (or a b))
               (myeval '(or a b) '((a . nil) (b . 1)))))
(assert (equal (let ((a nil)
                     (b nil)
                     (c 3))
                 (or a b c))
               (myeval '(or a b c) '((a . nil) (b . nil) (c . 3)))))
(assert (equal (let ((a nil)
                     (b 1)
                     (c 2))
                 (or a b c))
               (myeval '(or a b c) '((a . nil) (b . 1) (c . 2)))))
;; Тест для LET
(assert (equal '(1 . 2) (myeval '(let ((a 1)
                                       (b 2))
                                  (cons a b)) nil)))
;; Тест для LET*
(assert (equal '(3 1 . 2) (myeval '(let* ((a 1)
                                          (b 2)
                                          (c (+ a b)))
                                    (cons c (cons a b))) nil)))
;; Тест для DEFUN
(assert (equal 49 (progn
                    (setf *glob-env* nil)
                    (prog1 (myeval '(progn
                                     (defun alfa (x) (* x x))
                                     (alfa 7))
                                   nil)
                      (setf *glob-env* nil)))))
;; Тест для SETQ
(assert (equal 49 (progn
                    (setf *glob-env* nil)
                    (prog1 (myeval '(progn
                                     (defun alfa (x) (* x x))
                                     (setq beta 7)
                                     (alfa beta))
                                   nil)
                      (setf *glob-env* nil)))))
;; Тест для LAMBDA
(assert (equal '(42 . 42) (myeval '((lambda (x)
                                      (cons x x))
                                    42) nil)))
(assert (equal '(42 . 17) (myeval '((lambda (x y)
                                      (cons x y))
                                    42 17) nil)))
Яндекс.Метрика
Home