environnement.lisp (5434B)
1 ;; Gestion de l'environnement 2 3 ;; Attention : 4 ;; - Lorsqu'on fait un setf, ça renvoie la valeur affectée, pas 5 ;; l'objet modifié. Si on veut le renvoyer, il faut explicitement 6 ;; le mettre après le setf. 7 ;; - Les environnements sont partagés entre toutes les clôtures et 8 ;; autres qui les utilisent. Par ex. : 9 ;; (let ((x 0)) 10 ;; (lambda () (setf (x) (+ x 1))) 11 ;; (lambda () x)) 12 ;; Dans ce cas, les deux lambdas ont accès au même x, dans le même 13 ;; environnement. La modification par l'une des fonctions se 14 ;; répercute sur la valeur accédée par l'autre. 15 ;; - Lorsqu'on définit une fonction, il faut mettre juste après la 16 ;; liste des paramètres une chaîne de caractères qui documente la 17 ;; fonction (une docstring). 18 ;; - L'environnement top-level est partage par tous le monde 19 20 ;; Exemple de la structure env-stack après création de deux 21 ;; environnements en plus du top-level et ajout de plusieurs laisons. 22 (require 'test-unitaire "test-unitaire") 23 (erase-tests environnement) 24 (deftestvar environnement exemple-env-stack 25 '(;; Environnement le plus bas (dernières définitions par ordre 26 ;; chronologique). 27 ("DEFUN" 28 (x . plop)) 29 ;; Un autre environnement (définitions "plus vieilles"). 30 ("LET" 31 (y . "#lambda") 32 (x . "bijour") 33 (z . 123)) 34 ;; Top-level. Environnement le plus haut (définitions "globales" 35 ;; faites avec defun, defvar etc.). 36 ("TOP-LEVEL" 37 (y . 56) 38 (x . 42) 39 (foo . "#lambda")))) 40 41 ;; '((...) (...) (...)) => 3 environnement dans env-stack 42 43 (defun empty-env-stack () 44 "Constructeur de la pile d'environnements." 45 (list (list (copy-seq "TOP-LEVEL")))) 46 47 (defun push-new-env (env-stack name) 48 "Crée un nouvel environnement, l'ajoute à ENV-STACK et renvoie la 49 version modifiée (sans altérer l'original). 50 Le paramètre ENV-STACK est toute la pile d'environnements." 51 (cons (list name) env-stack)) 52 53 (defun add-binding (env-stack name value) 54 "Ajoute une liaison au dernier environnement (le plus bas)." 55 (setf (cdar env-stack) 56 (cons (cons name value) 57 (cdar env-stack))) 58 env-stack) 59 60 (defun get-binding (env-stack name) 61 "Récupère la liaison correspondant à NAME ." 62 (if (atom env-stack) 63 nil ; TODO : Penser à peut-être mettre un warn ou error. 64 (let ((ass (assoc name (cdar env-stack)))) 65 (if ass ass 66 (get-binding (cdr env-stack) name))))) 67 68 (defun set-binding (env-stack name new-value) 69 "Modifie la valeur associée à une liaison." 70 (setf (cdr (get-binding env-stack name)) 71 new-value) 72 env-stack) 73 74 (defun get-binding-value (env-stack name) 75 "Récupère la valeur associée a NAME ." 76 (cdr (get-binding env-stack name))) 77 78 (defun top-level-env-stack (env-stack) 79 "Recupere la pile d'environnement contenant uniquement 80 l'environnement top-level" 81 (if (atom (cdr env-stack)) 82 env-stack 83 (top-level-env-stack (cdr env-stack)))) 84 85 (defun get-top-level-binding (env-stack name) 86 "Récupère la liaison au top-level correspondant à NAME ." 87 (get-binding (top-level-env-stack env-stack) name)) 88 89 90 (defun add-top-level-binding (env-stack name value) 91 "Ajoute une liaison \"globale\" à l'environnement top-level." 92 (add-binding (top-level-env-stack env-stack) name value) 93 env-stack) 94 95 (defun set-top-level-binding (env-stack name new-value) ;; modifie une definition 96 "Modifie la valeur associée à une liaison \"globale\" de 97 l'environnement top-level." 98 (set-binding (top-level-env-stack env-stack) name new-value) 99 env-stack) 100 101 (defun print-env-stack (env-stack) 102 (let ((*print-circle* t)) 103 (if (atom env-stack) 104 nil 105 (progn (format t "~&~a: " (caar env-stack)) 106 (mapcar (lambda (b) (format t "~& ~w = ~w" (car b) (cdr b))) 107 (cdar env-stack)) 108 (print-env-stack (cdr env-stack)))))) 109 110 ;;Test Unitaire 111 (deftest environnement 112 (push-new-env (env-var (empty-env-stack)) "TEST") 113 '(("TEST") "TOP-LEVEL")) 114 (deftest environnement 115 (push-new-env exemple-env-stack "TEST") 116 (cons '("TEST") exemple-env-stack)) 117 (deftest environnement 118 (add-binding (empty-env-stack) 'x 42) 119 '(("TOP-LEVEL" (x . 42)))) 120 (deftest environnement 121 (add-binding (push-new-env (empty-env-stack) "FOO-BAR") 'x 42) 122 '(("FOO-BAR" (x . 42)) ("TOP-LEVEL"))) 123 (deftest environnement 124 (add-binding (add-binding (empty-env-stack) 'x 42) 'y 56) 125 '(("TOP-LEVEL" (y . 56) (x . 42)))) 126 ;; TODO : Rajouter un test d'erreur => Georges!!!!!! 127 ;(deftest environnement (set-binding (empty-env-stack) 'x 42) nil) 128 (deftest environnement 129 (set-binding (add-binding (empty-env-stack) 'x 42) 'x .42) 130 '(("TOP-LEVEL" (x . .42)))) 131 (deftest environnement 132 (get-binding '(("TOP-LEVEL" (X . 42))) 133 'x) 134 '(x . 42)) 135 (deftest environnement 136 (get-binding-value '(("FOO" (Z . 42)) ("TOP-LEVEL" (x . 42))) 137 'x) 138 42) 139 (deftest environnement 140 (top-level-env-stack '(("BAR" (X . 42)) 141 ("TOP-LEVEL" (X . 24) (Z . 73)))) 142 '(("TOP-LEVEL" (X . 24) (Z . 73)))) 143 (deftest environnement 144 (add-top-level-binding (copy-tree '(("TEST" (X . 42)) ("TOP-LEVEL" (Y . 56)))) 145 'Z 78) 146 '(("TEST" (X . 42)) ("TOP-LEVEL" (Z . 78) (Y . 56)))) 147 (deftest environnement 148 (set-top-level-binding (copy-tree '(("LEVEL2" (X . 42)) ("TOP-LEVEL" (Y . 56)))) 149 'Y "42") 150 '(("LEVEL2" (X . 42)) ("TOP-LEVEL" (Y . "42")))) 151 152 (provide 'environnement)