Table of Contents

План работ

Цель этого этапа - создание лексического окружения (в дополнение к динамическому окружению и глобальному окружению, которые у нас уже есть). Так мы решаем funarg-problem, проблему функционального аргумента. Проблема возникает в программах на языках, которые поддерживают функции как объекты первого класса (first-class sitizens): позволяюn передавать функции в качестве параметров и возвращать функции из функций.

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

Есть 2 типа этой проблемы:

  • downward - когда в функцию передается функция [TODO:gmm] Подробнее, с примером
  • upward - когда вызывающая функция ссылается на окружение вызываемой после завершения вызова

В качестве примера upward возьмем такой код:

;; UPWARD FUNARG PROBLEM

;; Создадим функцию F, которая возвращает функцию в замыкании по X
(setq f (lambda (x)
           (lambda (y)
             (+ x y))))

;; С помощью F создадим функцию G
(setq g (funcall f 5))

;; В этой функции X ссылается на 10, но после возврата из FUNCALL окружение, где X=10
;; уже не существует

;; тут при вызове Y=10, а X ссылается на несуществующее окружение
(funcall g 10)

;; Чтобы получить верный ответ (15) нужно сохранять окружение в момент создания замыкания
;; тогда даже такой код будет давать 15
(let ((x 30))
  (funcall g 10))

Еще один интересный пример upward funarg problem:

(defun compose (f g)
  (lambda (x) (funcall f (funcall g x))))

(funcall (compose #'car #'cdr) '(1 2 3 4))

;; Более развернутый вариант этого:

;; Создадим функцию COMPOSE, возвращую лямбду, которая
;; примененяет первый функциональный аргумент ко второму.
(setq compose (lambda (f g)
                (lambda (x)
                  (funcall f (funcall g x)))))

;; Создадим функцию F, которая является функцией,
;; применяющий CAR к CDR
(setq f (funcall compose #'car #'cdr))

;; Вызовем полученную функцию F от списка (хотим получить 2)
(funcall f '(1 2 3 4))

Когда мы возвращаем лямбду из compose мы теряем окружение (динамическое окружение, содержащее f и g осталось в месте где лямбда определялась) и у нас нет никакого способа применить f к (funcall g x), так как у нас уже нет g в окружении.

Таким образом это upward funarg problem [TODO:gmm] Правильно рассуждаю? [TODO:gmm] Нужен корректный пример downward funarg problem

Нам нужно уметь замыкать окружение лексически, тогда лямбда возвратит замыкание, где у нас будут связанные f и g.

Трассировка выполнения еще более наглядно поясняет upward

;; Трассируем такой код:
(((lambda (x)
    (lambda (y) x))
  1)
 2)

0: (MYEVAL (((LAMBDA (X) (LAMBDA (Y) X)) 1) 2) NIL)
  1: (MYEVAL ((LAMBDA (X) (LAMBDA (Y) X)) 1) NIL)
    2: (MYEVAL (LAMBDA (X) (LAMBDA (Y) X)) NIL)       ;; вычисляем car формы
    2: MYEVAL returned (LAMBDA (X) (LAMBDA (Y) X))    ;; lambda вычисляется в себя
    2: (MYEVAL 1 NIL)                                 ;; вычисляем первый аргумет 1
    2: MYEVAL returned 1                              ;; числа самовычислимы
    2: (MYAPPLY (LAMBDA (X) (LAMBDA (Y) X)) (1) NIL)  ;; применяем первую лямбду
      3: (MYEVAL (LAMBDA (Y) X) ((X . 1)))            ;; тело первой лямбды -- вторая лямбда  -> тут будет замыкание
      3: MYEVAL returned (LAMBDA (Y) X)               ;; лямбда вычисляется в себя
    2: MYAPPLY returned (LAMBDA (Y) X)
  1: MYEVAL returned (LAMBDA (Y) X)
  1: (MYEVAL 2 NIL)                                   ;; вычисляем второй аргумент
  1: MYEVAL returned 2                                ;; он самовычислим
  1: (MYAPPLY (LAMBDA (Y) X) (2) NIL)                 ;; применяем лямбду (вторую), но обрати внимание на окружение
    2: (MYEVAL X ((Y . 2)))                           ;; окуржение ((x . 1)) пропало

;; CL-вариант
(defun mymapcar (fn lst)
  (cond ((null lst) nil)
        (t (cons (funcall fn (car lst))
                 (mymapcar fn (cdr lst))))))


;; MICROLISP-вариант
(defun mymapcar (fn lst)
  (cond ((null lst) nil)
        (t (cons (fn (car lst))
                 (mymapcar fn (cdr lst))))))


(defun foo (lst)
    (mymapcar (lambda (i) (cons i lst)) '(1 2 3)))

(foo '(a b c))

CL-USER>
((1 a b c)
 (2 a b c)
 (3 a b c))

microlisp>
((1 1 2 3) (2 2 3) (3 3))

Теперь рассмотрим downward

;; DOWNWARD FUNARG PROBLEM

;; Создадим свой mapcar
(defun mymapcar (fn lst)
  (cond ((null lst) nil)
        (t (cons (funcall fn (car lst))
                 (mymapcar fn (cdr lst))))))

;; Создадим функцию FOO, которая принимает список LST и использует
;; MYMAPCAR чтобы сконсить его с каждым из элементов списка (1 2 3)
(defun foo (lst)
  (mymapcar (lambda (i)
              (cons i lst))
            '(1 2 3)))

;; Когда мы вызовем ... TODO
(foo '(a b c))

=> ((1 A B C)
    (2 A B C)
    (3 A B C))

Окружения и MyApply

Это глобальное окружение, которое было сделано на предыдущем этапе и функция поиска в нем (lookup), тут ничего не поменялось.

(defparameter *glob-env* nil)

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

Чтобы сделать лексическое окружение, нужно создать структуру замыкания:

(defstruct closure
  body
  env
  args)

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

((closure-p fn)              (myeval (closure-body fn)
                                     (pairlis (closure-args fn)
                                              args
                                              (closure-env fn))))

Этим куском кода мы заменяем обработку 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_3>>
(defun myapply (fn args env)
  (cond
    <<myapply_car_cdr_cons_3>>
    <<myapply_null_3>>
    <<myapply_ariph_3>>
    <<myapply_closure_3>>
    (t (error 'unknown-function :fn fn))))

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

<<myapply_car_cdr_cons_3_test>>
<<myapply_null_3_test>>
<<evaddmul_3_test>>
<<myapply_ariph_3_test>>
<<myapply_func_symb_3_test>>
;; TODO : нужен тест для closure в apply
<<myapply_closure_3_test>>

Работа с 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-предикат

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

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

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

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

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

Этот кейс удаляем, потому что у нас это вычисление теперь производится в myeval

((symbolp fn)                (let ((it (lookup fn env)))
                               (if (null it)
                                   (error 'function-not-found-error :fn fn)
                                   (myapply (cdr it) args env))))

И тест видоизменяется, чтобы проверить вычисление в глобальном окружении [TODO:gmm] Тут я не уверен что правильный тест

(assert (equal 49 (progn
                    (setf *glob-env* nil)
                    (myeval '(defun alfa (x) (* x x)) nil)
                    (myeval '(setq beta 7) nil)
                    (prog1 (myeval '(alfa beta) nil)
                      (setf *glob-env* nil)))))
;; (assert (equal "error"
;;                (handler-case (myeval '(alfa beta) '((beta . 7)))
;;                  (FUNCTION-NOT-FOUND-ERROR (condition) "error"))))

CANCEL 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_evcond_3>>
<<myeval_evprogn_3>>
<<myeval_evlis_3>>
<<myeval_evand_3>>
<<myeval_evor_3>>
<<myeval_mypairlis_3>>
<<myeval_evletstar_3>>

(defun myeval (lst env)
  (cond
    <<myeval_number_3>>
    <<myeval_symb_3>>
    <<myeval_quote_3>>
    <<myeval_if_3>>
    <<myeval_cond_3>>
    <<myeval_progn_3>>
    <<myeval_print_3>>
    <<myeval_list_3>>
    <<myeval_and_3>>
    <<myeval_or_3>>
    <<myeval_let_3>>
    <<myeval_letstar_3>>
    <<myeval_defun_3>>
    <<myeval_setq_3>>
    <<myeval_lambda_3>>
    (t
     (myapply (myeval (car lst) env)
              (evlis (cdr lst) nil env)
              env))))
<<myeval_number_3_test>>
<<myeval_symb_3_test>>
<<myeval_quote_3_test>>
<<myeval_if_3_test>>
<<myeval_evcond_3_test>>
<<myeval_cond_3_test>>
<<myeval_evprogn_3_test>>
<<myeval_progn_3_test>>
<<myeval_print_3_test>>
<<myeval_evlis_3_test>>
<<myeval_list_3_test>>
<<myeval_evand_3_test>>
<<myeval_and_3_test>>
<<myeval_evor_3_test>>
<<myeval_or_3_test>>
<<myeval_mypairlis_3_test>>
<<myeval_let_3_test>>
<<myeval_letstar_3_test>>
<<myeval_defun_3_test>>
<<myeval_setq_3_test>>
<<myeval_lambda_3_test>>

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

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

(defun evlis (unevaled evaled env)
  (cond ((null unevaled)  (reverse evaled))
        (t                (evlis (cdr unevaled)
                                 (cons (myeval (car unevaled) env)
                                       evaled)
                                 env))))
;; Тесты для 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)))))
((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 (lst env)
  (cond ((null lst)        (and))
        ((null (cdr lst))  (and (myeval (car lst) env)))
        (t                 (and (myeval (car lst) env)
                                (evand (cdr lst) 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)))
;; Тесты для 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)))))
((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 (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)))))

OR

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

((equal (car lst) 'or)       (evor  (cdr lst) env))

Протестируем or:

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

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

При создании функции мы создаем замыкание, в которое кладем тело функции, текущее окружение и аргументы функции.

((equal (car lst) 'defun)         (progn
                                    (push (cons (cadr lst)
                                                (make-closure :body (cadddr lst)
                                                              :env env
                                                              :args (caddr lst)))
                                          *glob-env*)
                                    (cadr lst)))

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

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

SETQ

((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 1 (myeval '(let ((alfa 2))
                           (setq alfa 1)
                           alfa)
                         nil)))
(assert (equal '((ALFA . 1))
             (progn
               (setf *glob-env* nil)
               (myeval '(setq alfa 1) nil)
               (prog1 *glob-env*
                 (setf *glob-env* nil)))))

LAMBDA

При обработке формы, начинающейся с вызова lambda мы должны создать замыкание:

((equal (car lst) 'lambda)   (make-closure :body (caddr lst) :env env :args (cadr lst)))
;; Тесты для LAMBDA
(assert (equal 3 (myeval '((lambda (x) (+ 1  x)) 2)
                         nil)))
;; Тесты для LAMBDA в окружении
(assert (equal 5 (myeval '(let ((y 3))
                           ((lambda (x) (+ y x)) 2))
                         nil)))

Repl

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

Итоги

<<errors_3>>
<<lookup_3>>
<<closure_3>>
<<myapply_3>>
<<myeval_3>>
<<myapply_3_test>>
<<myeval_3_test>>
<<repl_3>>

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

(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-error (error)
  ((fn :initarg :fn  :reader fn))
  (:report
   (lambda (condition stream)
     (format stream "Error in MYAPPLY: function not found: ~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*))))
(defstruct closure
  body
  env
  args)
(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))
    ((closure-p fn)              (myeval (closure-body fn)
                                         (pairlis (closure-args fn)
                                                  args
                                                  (closure-env fn))))
    (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)
                                                    (make-closure :body (cadddr lst)
                                                                  :env env
                                                                  :args (caddr 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)   (make-closure :body (caddr lst) :env env :args (cadr lst)))
    (t
     (myapply (myeval (car lst) env)
              (evlis (cdr lst) nil env)
              env))))
;; Тесты для 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 (progn
                    (setf *glob-env* nil)
                    (myeval '(defun alfa (x) (* x x)) nil)
                    (myeval '(setq beta 7) nil)
                    (prog1 (myeval '(alfa beta) nil)
                      (setf *glob-env* nil)))))
;; (assert (equal "error"
;;                (handler-case (myeval '(alfa beta) '((beta . 7)))
;;                  (FUNCTION-NOT-FOUND-ERROR (condition) "error"))))
;; TODO : нужен тест для closure в apply

(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)))))
;; Тест для MYPAIRLIS
(assert (equal '(( a . 1) (b . 2) ( c . 3) (z . 6) (y . 77))
               (mypairlis '(a b c) '(1 2 3) '((z . 6) (y . 77)))))
(assert (equal "error"
               (handler-case (mypairlis '(a b c) nil '((z . 6) (y . 77)))
                 (MYPAIRLIS-ERROR (condition) "error"))))
(assert (equal "error"
               (handler-case (mypairlis nil '(1 2 3) '((z . 6) (y . 77)))
                 (MYPAIRLIS-ERROR (condition) "error"))))
;; Тест для LET
(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 64 (progn
                    (setf *glob-env* nil)
                    (myeval '(defun alfa (x) (* x x)) nil)
                    (prog1 (myeval '(alfa 8) nil)
                      (setf *glob-env* nil)))))
;; Тест для SETQ
(assert (equal 1 (myeval '(let ((alfa 2))
                           (setq alfa 1)
                           alfa)
                         nil)))
(assert (equal '((ALFA . 1))
               (progn
                 (setf *glob-env* nil)
                 (myeval '(setq alfa 1) nil)
                 (prog1 *glob-env*
                   (setf *glob-env* nil)))))
;; Тесты для LAMBDA
(assert (equal 3 (myeval '((lambda (x) (+ 1  x)) 2)
                         nil)))
;; Тесты для LAMBDA в окружении
(assert (equal 5 (myeval '(let ((y 3))
                           ((lambda (x) (+ y x)) 2))
                         nil)))
(defun repl ()
  (princ "microlisp>")
  (princ (myeval (read) nil))
  (terpri)
  (finish-output)
  (repl))
Яндекс.Метрика
Home