commit 5730fef6aa32a0240800089eaf0ba6f91dd96b46
parent c25810fed503c37a1a9fb12f338b0aa1dd94af4b
Author: Georges Dupéron <jahvascriptmaniac+github@free.fr>
Date: Sun, 9 Jan 2011 07:30:25 +0100
Migration (partielle) des tests vers equiv-tests.lisp
Diffstat:
| M | lisp/equiv-tests.lisp | | | 232 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++----- |
| M | lisp/mini-meval.lisp | | | 120 | ++----------------------------------------------------------------------------- |
2 files changed, 221 insertions(+), 131 deletions(-)
diff --git a/lisp/equiv-tests.lisp b/lisp/equiv-tests.lisp
@@ -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)
diff --git a/lisp/mini-meval.lisp b/lisp/mini-meval.lisp
@@ -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))))
@@ -702,10 +612,6 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
'(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 ...
(fibo 5)
@@ -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)
