suzanne.soy/2010-m1s1-compilation
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Ajout du test unitaire d'environnement

Browse Source
This commit is contained in:
Bertrand BRUN 2010-10-19 16:32:29 +02:00
parent e55e3641a0
commit af2b28f7e5
2 changed files with 88 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

91
environnement.lisp
View File

@ -22,14 +22,17 @@
(defvar exemple-env-stack (defvar exemple-env-stack
'(;; Environnement le plus bas (dernières définitions par ordre '(;; Environnement le plus bas (dernières définitions par ordre
;; chronologique). ;; chronologique).
((x . plop)) ("DEFUN"
(x . plop))
;; Un autre environnement (définitions "plus vieilles"). ;; Un autre environnement (définitions "plus vieilles").
((y . "#lambda") ("LET"
(y . "#lambda")
(x . "bijour") (x . "bijour")
(z . 123)) (z . 123))
;; Top-level. Environnement le plus haut (définitions "globales" ;; Top-level. Environnement le plus haut (définitions "globales"
;; faites avec defun, defvar etc.). ;; faites avec defun, defvar etc.).
((y . 56) ("TOP-LEVEL"
(y . 56)
(x . 42) (x . 42)
(foo . "#lambda")))) (foo . "#lambda"))))
@ -37,60 +40,104 @@
(defun empty-env-stack () (defun empty-env-stack ()
"Constructeur de la pile d'environnements." "Constructeur de la pile d'environnements."
'(())) (list (list "TOP-LEVEL")))
(defun push-new-env (env-stack) (defun push-new-env (env-stack name)
"Crée un nouvel environnement, l'ajoute à ENV-STACK et renvoie la "Crée un nouvel environnement, l'ajoute à ENV-STACK et renvoie la
version modifiée (sans altérer l'original). version modifiée (sans altérer l'original).
Le paramètre ENV-STACK est toute la pile d'environnements." Le paramètre ENV-STACK est toute la pile d'environnements."
(cons '() env-stack)) (cons (list name) env-stack))
(defun add-binding (env-stack name value) (defun add-binding (env-stack name value)
"Ajoute une liaison au dernier environnement (le plus bas)." "Ajoute une liaison au dernier environnement (le plus bas)."
(setf (car env-stack) (setf (cdar env-stack)
(cons (cons name value) (cons (cons name value)
(car env-stack))) (cdar env-stack)))
env-stack) env-stack)
(defun set-binding (env-stack name new-value) (defun set-binding (env-stack name new-value)
"Modifie la valeur associée à une liaison." "Modifie la valeur associée à une liaison."
(setf (cdr (get-binging name)) (setf (cdr (get-binding env-stack name))
new-value) new-value)
env-stack) env-stack)
(defun get-binding-value (env-stack name) (defun get-binding-value (env-stack name)
"Récupère la valeur associée a NAME ." "Récupère la valeur associée a NAME ."
(cdr (get-binding name))) (cdr (get-binding env-stack name)))
(defun get-binding (env-stack name) (defun get-binding (env-stack name)
"Récupère la liaison correspondant à NAME ." "Récupère la liaison correspondant à NAME ."
(if (atom env-stack) (if (atom env-stack)
nil ; TODO : Penser à peut-être mettre un warn ou error. nil ; TODO : Penser à peut-être mettre un warn ou error.
(let ((ass (assoc name (car env-stack)))) (let ((ass (assoc name (cdar env-stack))))
(if ass ass (if ass ass
(get-binding (cdr env-stack) name))))) (get-binding (cdr env-stack) name)))))
(defun top-level (env-stack) (defun top-level-env-stack (env-stack)
"Recupere la pile d'environnement contenant uniquement "Recupere la pile d'environnement contenant uniquement
l'environnement top-level" l'environnement top-level"
(if (atom (cdr env-stack)) (if (atom (cdr env-stack))
env-stack env-stack
(top-level (cdr env-stack)))) (top-level-env-stack (cdr env-stack))))
(defun add-top-level-binding (env-stack name value) (defun add-top-level-binding (env-stack name value)
"Ajoute une liaison \"globale\" à l'environnement top-level." "Ajoute une liaison \"globale\" à l'environnement top-level."
(add-binding (top-level env-stack) name value)) (add-binding (top-level-env-stack env-stack) name value)
env-stack)
(defun set-top-level-binding (env-stack name new-value) ;; modifie une definition (defun set-top-level-binding (env-stack name new-value) ;; modifie une definition
"Modifie la valeur associée à une liaison \"globale\" de "Modifie la valeur associée à une liaison \"globale\" de
l'environnement top-level." l'environnement top-level."
(set-binding (top-level env-stack) name new-value)) (set-binding (top-level-env-stack env-stack) name new-value)
env-stack)
(defun test-env (num) (defun print-env-stack (env-stack)
(case num (if (atom env-stack)
(0 (push-new-env (empty-env-stack))) nil
(1 (push-new-env exemple-env-stack)) (progn (format t "~&~a: " (caar env-stack))
(2 (add-binding (push-new-env (empty-env-stack)) 'x 42)) (mapcar (lambda (b) (format t "~& ~w = ~w" (car b) (cdr b)))
(3 (add-binding (add-binding (push-new-env (empty-env-stack)) 'x 42) 'y 56)) (cdar env-stack))
)) (print-env-stack (cdr env-stack)))))
;;Test Unitaire
(load "test-unitaire")
(deftest environnement
(push-new-env (empty-env-stack) "TEST")
'(("TEST") ("TOP-LEVEL")))
(deftest environnement
(push-new-env (copytree exemple-env-stack) "TEST")
(cons '("TEST") exemple-env-stack))
(deftest environnement
(add-binding (empty-env-stack) 'x 42)
'(("TOP-LEVEL" (x . 42))))
(deftest environnement
(add-binding (push-new-env (empty-env-stack) "FOO-BAR") 'x 42)
'(("FOO-BAR" (x . 42)) ("TOP-LEVEL")))
(deftest environnement
(add-binding (add-binding (empty-env-stack) 'x 42) 'y 56)
'(("TOP-LEVEL" (y . 56) (x . 42))))
;; TODO : Rajouter un test d'erreur => Georges!!!!!!
;(deftest environnement (set-binding (empty-env-stack) 'x 42) nil)
(deftest environnement
(set-binding (add-binding (empty-env-stack) 'x 42) 'x .42)
'(("TOP-LEVEL" (x . .42))))
(deftest environnement
(get-binding (copytree '(("TOP-LEVEL" (X . 42))))
'x)
'(x . 42))
(deftest environnement
(get-binding-value (copytree '(("FOO" (Z . 42)) ("TOP-LEVEL" (x . 42))))
'x)
42)
(deftest environnement
(top-level-env-stack (copytree '(("BAR" (X . 42))
("TOP-LEVEL" (X . 24) (Z . 73)))))
'(("TOP-LEVEL" (X . 24) (Z . 73))))
(deftest environnement
(add-top-level-binding (copytree '(("TEST" (X . 42)) ("TOP-LEVEL" (Y . 56))))
'Z 78)
'(("TEST" (X . 42)) ("TOP-LEVEL" (Z . 78) (Y . 56))))
(deftest environnement
(set-top-level-binding (copytree '(("LEVEL2" (X . 42)) ("TOP-LEVEL" (Y . 56))))
'Y "42")
'(("LEVEL2" (X . 42)) ("TOP-LEVEL" (Y . "42"))))

37
test-unitaire.lisp
View File

@ -12,37 +12,38 @@
(let ((failures 0) (let ((failures 0)
(modules (if (eq T (car modules)) (modules (if (eq T (car modules))
(mapcar #'car tests) (mapcar #'car tests)
modules))) modules)))
(if (every (lambda (mod) (if (every (lambda (mod)
(if (member (car mod) modules) (if (member (car mod) modules)
(progn (progn
(format t "Module ~a :~&" (car mod)) (format t "Module ~w :~&" (car mod))
(mapcar (lambda (test) (mapcar (lambda (test)
(let ((res (eval (car test)))) (let* ((res (eval (car test)))
(if (equal (cdr test) res) (expect (eval (cdr test))))
(format t " [SUCCESS] ~a~&" (car test)) (if (equal expect res)
(progn (format t " [FAILURE] Test : ~a~& got : ~a~& expected : ~a~&" (car test) res (cdr test)) (format t " [SUCCESS] ~w~&" (car test))
(progn (format t " [FAILURE] Test : ~w~& got : ~w~& expected : ~w~&" (car test) res expect)
(setf failures (+ failures 1)))))) (setf failures (+ failures 1))))))
(cdr mod)))) (reverse (cdr mod)))))
(if (not (= failures 0)) (if (not (= failures 0))
(format t "Module ~a failed ~a tests. Stopping." (car mod) failures)) (format t "Module ~w failed ~w tests. Stopping.~&" (car mod) failures))
(= failures 0)) (= failures 0))
tests) tests)
(progn (format t "All modules passed all tests successfully.") (progn (format t "All modules passed all tests successfully.~&")
t) t)
nil))) nil)))
(defun show-test () (defun show-test ()
tests)) tests))
;; Test de debugage du test unitaire ;; Test de debugage du test unitaire
(deftest environnement nil nil) ;(deftest environnement nil nil)
(deftest environnement (eq 42 42) T) ;; Test qui fail ;(deftest environnement (eq 42 42) T) ;; Test qui fail
(deftest vm T T) ;(deftest vm T T)
(deftest environnement2 (eq 42 42) nil) ;(deftest environnement2 (eq 42 42) nil)
(show-test) ;(show-test)
(run-test environnement) ;(run-test environnement)
;; TODO : every ne mappe pas la liste dans le bon ordre, et vm est ;; TODO : every ne mappe pas la liste dans le bon ordre, et vm est
;; exécuté avant environnement quel que soit l'ordre des paramètres. ;; exécuté avant environnement quel que soit l'ordre des paramètres.
(run-test environnement vm) ;(run-test environnement vm)
(run-test environnement vm environnement2) ;(run-test environnement vm environnement2)
(run-test t) ;; t => tous ;(run-test t) ;; t => tous