Migration (partielle) des tests vers equiv-tests.lisp
This commit is contained in:
Georges Dupéron
parent
c25810fed5
commit
5730fef6aa
|
|
@ -1,21 +1,225 @@
|
|||
(require 'squash-lisp "squash-lisp")
|
||||
(require 'mini-meval "mini-meval")
|
||||
|
||||
(defun test-expr-in-all (expr)
|
||||
(defun expr-equiv-p (expr &optional (expected nil expected-p))
|
||||
(let ((res-eval (eval expr))
|
||||
(sql nil))
|
||||
(unless (equalp res-eval (mini-meval expr))
|
||||
(return-from test-expr-in-all "mini-meval differs from-eval"))
|
||||
(setq sql (squash-lisp-1 expr))
|
||||
(unless (squash-lisp-1-check sql)
|
||||
(return-from test-expr-in-all "squash-lisp-1-check failed"))
|
||||
(unless (equalp res-eval (eval (squash-lisp-1-wrap sql)))
|
||||
(return-from test-expr-in-all "squash-lisp-1 differs from-eval"))
|
||||
;; (setq sql (squash-lisp-2 (squash-lisp-1 expr)))
|
||||
;; (unless (squash-lisp-2-check sql)
|
||||
;; (return-from test-expr-in-all "squash-lisp-2-check failed"))
|
||||
;; (unless (equalp res-eval (eval (squash-lisp-2-wrap sql)))
|
||||
;; (return-from test-expr-in-all "squash-lisp-2 differs from-eval"))
|
||||
(temp nil))
|
||||
(setq temp (mini-meval expr))
|
||||
(unless (equalp res-eval temp)
|
||||
(return-from expr-equiv-p (format nil "mini-meval differs from eval : ~a vs ~a" res-eval temp)))
|
||||
(when expected-p
|
||||
(unless (equalp expected temp)
|
||||
(return-from expr-equiv-p "mini-meval differs from expected value")))
|
||||
(setq temp (squash-lisp-1 expr))
|
||||
(unless (squash-lisp-1-check temp)
|
||||
(return-from expr-equiv-p "squash-lisp-1-check failed"))
|
||||
(unless (equalp res-eval (eval (squash-lisp-1-wrap temp)))
|
||||
(return-from expr-equiv-p "squash-lisp-1 differs from eval"))
|
||||
;; (setq temp (squash-lisp-2 (squash-lisp-1 expr)))
|
||||
;; (unless (squash-lisp-2-check temp)
|
||||
;; (return-from expr-equiv-p "squash-lisp-2-check failed"))
|
||||
;; (unless (equalp res-eval (eval (squash-lisp-2-wrap temp)))
|
||||
;; (return-from expr-equiv-p "squash-lisp-2 differs from eval"))
|
||||
t))
|
||||
|
||||
(defmacro deftest-equiv (module test &optional (expected nil expected-p))
|
||||
`(deftest ,module (expr-equiv-p ,test . ,(if expected-p (list expected) nil))
|
||||
t))
|
||||
|
||||
(deftest-equiv (mini-meval constante)
|
||||
(mini-meval 42 etat)
|
||||
42)
|
||||
|
||||
(deftest (mini-meval appel-fonction)
|
||||
(mini-meval '(+ 2 3) etat)
|
||||
5)
|
||||
|
||||
(deftest (mini-meval appel-fonction)
|
||||
(mini-meval '(+ 2 (+ 3 4)) etat)
|
||||
9)
|
||||
|
||||
(deftest (mini-meval variable)
|
||||
(mini-meval 'x (push-local etat 'x 'variable 42))
|
||||
42)
|
||||
|
||||
(deftest (mini-meval appel-fonction-et-variable)
|
||||
(mini-meval '(+ x x 3) (push-local etat 'x 'variable 42))
|
||||
87)
|
||||
|
||||
(deftest (mini-meval appel-fonction-et-variable)
|
||||
(mini-meval '(+ x (+ 3 x)) (push-local etat 'x 'variable 42))
|
||||
87)
|
||||
|
||||
(deftest (mini-meval lambda extérieur)
|
||||
(funcall (mini-meval '(lambda (x) x) etat) 3)
|
||||
3)
|
||||
|
||||
(deftest (mini-meval lambda extérieur)
|
||||
(funcall (mini-meval '(lambda (x) (+ x 3)) etat) 4)
|
||||
7)
|
||||
|
||||
(deftest (mini-meval lambda immédiat)
|
||||
(mini-meval '((lambda (x) (+ x 3)) 4) etat)
|
||||
7)
|
||||
|
||||
(deftest (mini-meval let)
|
||||
(mini-meval '(let ((x 3) (y 4)) (+ x y)) etat)
|
||||
7)
|
||||
|
||||
(deftest (mini-meval let)
|
||||
(mini-meval '(let ((x 3) (y 4) (z 5)) (let ((z (+ x y)) (w z)) (list x y z w))) etat)
|
||||
'(3 4 7 5))
|
||||
|
||||
(deftest (mini-meval let*)
|
||||
(mini-meval '(let ((x 3) (y 4) (z 5)) (let* ((z (+ x y)) (w z)) (list x y z w))) etat)
|
||||
'(3 4 7 7))
|
||||
|
||||
;; TODO
|
||||
;; (deftest (mini-meval let-nil)
|
||||
;; (mini-meval '(let (a (x 3) y) (list a x y)) etat)
|
||||
;; '(nil 3 nil))
|
||||
|
||||
;; (deftest (mini-meval let-nil)
|
||||
;; (mini-meval '(let* ((x 4) y (z 5)) (list a x y)) etat)
|
||||
;; '(4 nil 5))
|
||||
|
||||
(deftest (mini-meval progn)
|
||||
(mini-meval '(progn 1 2 3 4) etat)
|
||||
4)
|
||||
|
||||
(deftest (mini-meval quote)
|
||||
(mini-meval ''x etat)
|
||||
'x)
|
||||
|
||||
(deftest (mini-meval macrolet)
|
||||
(mini-meval '(labels ((qlist (a b) (list a b)))
|
||||
(list
|
||||
(qlist 'a 'b)
|
||||
(macrolet ((qlist (x y) (list 'list (list 'quote x) (list 'quote y))))
|
||||
(qlist 'a 'b))
|
||||
(qlist 'a 'b)))
|
||||
etat)
|
||||
'((a b) ('a 'b) (a b)))
|
||||
|
||||
(deftest (mini-meval setf setq)
|
||||
(mini-meval '(let ((x 42)) (list x (setq x 123) x) etat))
|
||||
'(42 123 123))
|
||||
|
||||
(deftest (mini-meval funcall)
|
||||
(mini-meval '(funcall #'+ 1 2 3) etat)
|
||||
'6)
|
||||
|
||||
(deftest (mini-meval apply)
|
||||
(mini-meval '(apply #'+ 1 2 (list (+ 1 2) 4)) etat)
|
||||
'10)
|
||||
|
||||
(deftest (mini-meval function external)
|
||||
(mini-meval '#'+ etat)
|
||||
#'+)
|
||||
|
||||
(deftest (mini-meval function external)
|
||||
(mini-meval '(funcall #'+ 1 2 3) etat)
|
||||
'6)
|
||||
|
||||
(deftest (mini-meval call-function external)
|
||||
(mini-meval '(#'+ 2 3) etat)
|
||||
5)
|
||||
|
||||
(deftest (mini-meval call-function lambda)
|
||||
(mini-meval '(#'(lambda (x) (+ x 40)) 2) etat)
|
||||
42)
|
||||
|
||||
(deftest (mini-meval lambda optional)
|
||||
(mini-meval '((lambda (x &optional (y 2)) (list x y)) 1) etat)
|
||||
'(1 2))
|
||||
|
||||
(deftest (mini-meval lambda closure single-instance)
|
||||
(mini-meval '(let ((foo (let ((y 1)) (cons (lambda (x) (list x y)) (lambda (z) (setq y (+ y z)) nil)))))
|
||||
(list (funcall (car foo) 4) (funcall (cdr foo) 5) (funcall (car foo) 4))) etat)
|
||||
'((4 1) nil (4 6)))
|
||||
|
||||
(deftest (mini-meval lambda closure multiple-instances)
|
||||
(mini-meval '(labels ((counter (&optional (ctr 0)) (cons (lambda () ctr) (lambda (&optional (x 1)) (setq ctr (+ ctr x)) nil))))
|
||||
(let ((foo0 (counter))
|
||||
(foo42 (counter 42)))
|
||||
(list
|
||||
(funcall (car foo0)) ;; show 0
|
||||
(funcall (car foo42)) ;; show 42
|
||||
(funcall (cdr foo0)) ;; add 0
|
||||
(funcall (car foo0)) ;; show 0
|
||||
(funcall (cdr foo42)) ;; add 42
|
||||
(funcall (car foo42)) ;; show 42
|
||||
(funcall (car foo0)) ;; shwo 0
|
||||
(funcall (car foo42)) ;; show 42
|
||||
(funcall (cdr foo42) 6) ;; add 42 (+ 6)
|
||||
(funcall (cdr foo0) 5) ;; add 0 (+ 5)
|
||||
(funcall (car foo42)) ;; show 42
|
||||
(funcall (car foo0))))) ;; show 0
|
||||
etat)
|
||||
'(0 42 nil 1 nil 43 1 43 nil nil 49 6))
|
||||
|
||||
(deftest (mini-meval labels)
|
||||
(mini-meval '(labels ((foo (x) (+ x 1)))
|
||||
(list
|
||||
(foo 3)
|
||||
(labels ((foo (x) (+ x 3)))
|
||||
(foo 3))))
|
||||
etat)
|
||||
'(4 6))
|
||||
|
||||
(deftest (mini-meval labels)
|
||||
(mini-meval '(< 2 3) etat)
|
||||
t)
|
||||
|
||||
(deftest (mini-meval flet)
|
||||
(mini-meval '(labels ((foo (x) (+ x 1)))
|
||||
(list
|
||||
(foo 3)
|
||||
(flet ((foo (x) (+ x 3)))
|
||||
(foo 3))))
|
||||
etat)
|
||||
'(foo 4 6))
|
||||
|
||||
(deftest (mini-meval labels)
|
||||
(mini-meval '(labels ((fibo (n) (if (< n 2) 1 (+ (fibo (- n 1)) (fibo (- n 2)))))) ;; fibo 0 -> 1; 1 -> 1; 2 -> 2 ...
|
||||
(list
|
||||
(fibo 5)
|
||||
(labels ((fibo (n) (if (< n 3) 1 (+ (fibo (- n 1)) (fibo (- n 2)))))) ;; fibo 1 -> 1; 2 -> 1; 3 -> 2 ...
|
||||
(fibo 5))
|
||||
(fibo 5)))
|
||||
etat)
|
||||
'(fibo 8 5 8))
|
||||
|
||||
(deftest (mini-meval flet)
|
||||
(mini-meval '(labels ((fibo (n) (if (< n 2) 1 (+ (fibo (- n 1)) (fibo (- n 2)))))) ;; fibo 0 -> 1; 1 -> 1; 2 -> 2 ...
|
||||
(list
|
||||
(fibo 5)
|
||||
(flet ((fibo (n) (if (< n 3) 1 (+ (fibo (- n 1)) (fibo (- n 2)))))) ;; fibo 1 -> 1; 2 -> 1; 3 -> 2 ...
|
||||
(fibo 5))))
|
||||
etat)
|
||||
;; Le flet ne permet pas les définitions récursives, donc le fibo
|
||||
;; de l'extérieur est appellé après le 1er niveau de récursion.
|
||||
'(fibo 8 8))
|
||||
|
||||
(deftest (mini-meval tagbody)
|
||||
(mini-meval '(let ((x 0)) (tagbody foo (setq x 1) (go baz) bar (setq x 2) baz) x))
|
||||
1)
|
||||
|
||||
(deftest (mini-meval tagbody)
|
||||
(mini-meval '(let ((x 0)) (tagbody foo (setq x 1) (go 42) bar (setq x 2) 42) x))
|
||||
1)
|
||||
|
||||
(deftest (mini-meval tagbody)
|
||||
(mini-meval '(tagbody foo (list 1) 42 (list 2) baz (list 3)) etat)
|
||||
nil)
|
||||
|
||||
(deftest (mini-meval block)
|
||||
(mini-meval '(block foo 1 (return-from foo 4) 2))
|
||||
4)
|
||||
|
||||
(deftest (mini-meval block)
|
||||
(mini-meval '(block foo 1 2))
|
||||
2)
|
||||
|
||||
|
||||
(provide 'equiv-tests)
|
||||
|
|
|
|||
|
|
@ -290,6 +290,7 @@ Mini-meval est un meval très simple destiné à évaluer les macros et les autr
|
|||
Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il faut donc qu'il puisse maintenir son état entre les appels.
|
||||
|#
|
||||
(defun mini-meval (expr &optional (etat (list nil nil nil)))
|
||||
(print etat)
|
||||
#|
|
||||
L'algorithme d'évaluation est très simple et suit le schéma donné dans CLTL 5.1.3 :
|
||||
1) Si l'expression est une forme spéciale, on la traite de manière particulière
|
||||
|
|
@ -511,66 +512,7 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
|
|||
|
||||
(deftestvar mini-meval etat (make-etat list + - cons car cdr < > <= >= =))
|
||||
|
||||
(deftest (mini-meval constante)
|
||||
(mini-meval 42 etat)
|
||||
42)
|
||||
|
||||
(deftest (mini-meval appel-fonction)
|
||||
(mini-meval '(+ 2 3) etat)
|
||||
5)
|
||||
|
||||
(deftest (mini-meval appel-fonction)
|
||||
(mini-meval '(+ 2 (+ 3 4)) etat)
|
||||
9)
|
||||
|
||||
(deftest (mini-meval variable)
|
||||
(mini-meval 'x (push-local etat 'x 'variable 42))
|
||||
42)
|
||||
|
||||
(deftest (mini-meval appel-fonction-et-variable)
|
||||
(mini-meval '(+ x x 3) (push-local etat 'x 'variable 42))
|
||||
87)
|
||||
|
||||
(deftest (mini-meval appel-fonction-et-variable)
|
||||
(mini-meval '(+ x (+ 3 x)) (push-local etat 'x 'variable 42))
|
||||
87)
|
||||
|
||||
(deftest (mini-meval lambda extérieur)
|
||||
(funcall (mini-meval '(lambda (x) x) etat) 3)
|
||||
3)
|
||||
|
||||
(deftest (mini-meval lambda extérieur)
|
||||
(funcall (mini-meval '(lambda (x) (+ x 3)) etat) 4)
|
||||
7)
|
||||
|
||||
(deftest (mini-meval lambda immédiat)
|
||||
(mini-meval '((lambda (x) (+ x 3)) 4) etat)
|
||||
7)
|
||||
|
||||
(deftest (mini-meval let)
|
||||
(mini-meval '(let ((x 3) (y 4)) (+ x y)) etat)
|
||||
7)
|
||||
|
||||
(deftest (mini-meval let)
|
||||
(mini-meval '(let ((x 3) (y 4) (z 5)) (let ((z (+ x y)) (w z)) (list x y z w))) etat)
|
||||
'(3 4 7 5))
|
||||
|
||||
(deftest (mini-meval let*)
|
||||
(mini-meval '(let ((x 3) (y 4) (z 5)) (let* ((z (+ x y)) (w z)) (list x y z w))) etat)
|
||||
'(3 4 7 7))
|
||||
|
||||
;; TODO
|
||||
;; (deftest (mini-meval let-nil)
|
||||
;; (mini-meval '(let (a (x 3) y) (list a x y)) etat)
|
||||
;; '(nil 3 nil))
|
||||
|
||||
;; (deftest (mini-meval let-nil)
|
||||
;; (mini-meval '(let* ((x 4) y (z 5)) (list a x y)) etat)
|
||||
;; '(4 nil 5))
|
||||
|
||||
(deftest (mini-meval progn)
|
||||
(mini-meval '(progn 1 2 3 4) etat)
|
||||
4)
|
||||
;; La plupart des tests sont dans eqiv-tests.lisp
|
||||
|
||||
(deftest (mini-meval defvar)
|
||||
(mini-meval '(progn (defvar x 42) x) etat)
|
||||
|
|
@ -589,10 +531,6 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
|
|||
(mini-meval '(progn (defun double (x) (+ x x)) (double 3)) etat)
|
||||
6)
|
||||
|
||||
(deftest (mini-meval quote)
|
||||
(mini-meval ''x etat)
|
||||
'x)
|
||||
|
||||
(deftest (mini-meval defmacro)
|
||||
(mini-meval '(progn (defmacro qlist (x y) (list 'list (list 'quote x) (list 'quote y))) (qlist a b)) etat)
|
||||
'(a b))
|
||||
|
|
@ -609,29 +547,9 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
|
|||
'((a b) ('a 'b) (a b)))
|
||||
|
||||
(deftest (mini-meval setf setq)
|
||||
(mini-meval '(list (defvar x 42) x (setq x 123) x) etat)
|
||||
(mini-meval '(progn (debug 'a) (print etat) (list (defvar x 42) x (setq x 123) x) etat))
|
||||
'(x 42 123 123))
|
||||
|
||||
(deftest (mini-meval funcall)
|
||||
(mini-meval '(funcall #'+ 1 2 3) etat)
|
||||
'6)
|
||||
|
||||
(deftest (mini-meval apply)
|
||||
(mini-meval '(apply #'+ 1 2 (list (+ 1 2) 4)) etat)
|
||||
'10)
|
||||
|
||||
(deftest (mini-meval function external)
|
||||
(mini-meval '#'+ etat)
|
||||
#'+)
|
||||
|
||||
(deftest (mini-meval function external)
|
||||
(mini-meval '(funcall #'+ 1 2 3) etat)
|
||||
'6)
|
||||
|
||||
(deftest (mini-meval call-function external)
|
||||
(mini-meval '(#'+ 2 3) etat)
|
||||
5)
|
||||
|
||||
(deftest (mini-meval function internal)
|
||||
(funcall (mini-meval '(progn (defun foo (x) (+ x 40)) #'foo) etat) 2)
|
||||
'42)
|
||||
|
|
@ -648,14 +566,6 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
|
|||
(mini-meval '(progn (defun foo (x) (+ x 40)) (#'foo 2)) etat)
|
||||
42)
|
||||
|
||||
(deftest (mini-meval call-function lambda)
|
||||
(mini-meval '(#'(lambda (x) (+ x 40)) 2) etat)
|
||||
42)
|
||||
|
||||
(deftest (mini-meval lambda optional)
|
||||
(mini-meval '((lambda (x &optional (y 2)) (list x y)) 1) etat)
|
||||
'(1 2))
|
||||
|
||||
(deftest (mini-meval lambda closure single-instance)
|
||||
(mini-meval '(progn
|
||||
(defvar foo (let ((y 1)) (cons (lambda (x) (list x y)) (lambda (z) (setq y (+ y z)) nil))))
|
||||
|
|
@ -701,10 +611,6 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
|
|||
etat)
|
||||
'(foo 4 6))
|
||||
|
||||
(deftest (mini-meval labels)
|
||||
(mini-meval '(< 2 3) etat)
|
||||
t)
|
||||
|
||||
(deftest (mini-meval labels)
|
||||
(mini-meval '(list
|
||||
(defun fibo (n) (if (< n 2) 1 (+ (fibo (- n 1)) (fibo (- n 2))))) ;; fibo 0 -> 1; 1 -> 1; 2 -> 2 ...
|
||||
|
|
@ -728,24 +634,4 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
|
|||
(deftest-error (mini-meval error)
|
||||
(mini-meval '(error "Some user error message.")))
|
||||
|
||||
(deftest (mini-meval tagbody)
|
||||
(mini-meval '(let ((x 0)) (tagbody foo (setq x 1) (go baz) bar (setq x 2) baz) x))
|
||||
1)
|
||||
|
||||
(deftest (mini-meval tagbody)
|
||||
(mini-meval '(let ((x 0)) (tagbody foo (setq x 1) (go 42) bar (setq x 2) 42) x))
|
||||
1)
|
||||
|
||||
(deftest (mini-meval tagbody)
|
||||
(mini-meval '(tagbody foo (list 1) 42 (list 2) baz (list 3)) etat)
|
||||
nil)
|
||||
|
||||
(deftest (mini-meval block)
|
||||
(mini-meval '(block foo 1 (return-from foo 4) 2))
|
||||
4)
|
||||
|
||||
(deftest (mini-meval block)
|
||||
(mini-meval '(block foo 1 2))
|
||||
2)
|
||||
|
||||
(provide 'mini-meval)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user