From 5a9f63794b80a09a5deb5d032ce157e4a27f354a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <jahvascriptmaniac+github@free.fr>
Date: Sun, 28 Nov 2010 19:34:58 +0100
Subject: [PATCH] =?UTF-8?q?Ajout=20du=20support=20partiel=20des=20variable?=
 =?UTF-8?q?s=20sp=C3=A9ciales=20dans=20mini-meval=20(ne=20me=20demmandez?=
 =?UTF-8?q?=20pas=20pourquoi=20j'ai=20fait=20=C3=A7a,=20je=20sais=20plus).?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 bootstrap/7.8.3-dolist-dotimes.lisp |  75 ++++
 implementation/mini-meval.lisp      | 626 +++++++++++++++++++---------
 util.lisp                           |  24 ++
 3 files changed, 534 insertions(+), 191 deletions(-)
 create mode 100644 bootstrap/7.8.3-dolist-dotimes.lisp

diff --git a/bootstrap/7.8.3-dolist-dotimes.lisp b/bootstrap/7.8.3-dolist-dotimes.lisp
new file mode 100644
index 0000000..b956b59
--- /dev/null
+++ b/bootstrap/7.8.3-dolist-dotimes.lisp
@@ -0,0 +1,75 @@
+(defmacro my-dolist (spec &rest body)
+  (let ((var (car spec))
+        (listform (cadr spec))
+        (resultform (caddr spec))
+        (loopsym (make-symbol "loop"))
+        (endsym (make-symbol "end"))
+        (listsym (make-symbol "list")))
+    `(let ((,var nil)
+           (,listsym ,listform))
+       (tagbody
+        ,loopsym
+          (setq ,var (car ,listsym))
+          (when (endp ,listsym)
+            (go ,endsym))
+          (progn ,@body)
+          (setq ,listsym (cdr ,listsym))
+          (go ,loopsym)
+        ,endsym)
+       ,resultform)))
+
+;; (let ((foo 42)) (my-dolist (a '(1 2 3) foo) (print a)))
+;; => 1
+;; => 2
+;; => 3
+;; => 42
+;; (my-dolist (a '(1 2 3)) (print a))
+;; => 1
+;; => 2
+;; => 3
+;; => nil
+;; (my-dolist (a '(1 2 3) a) (print a))
+;; => 1
+;; => 2
+;; => 3
+;; => nil
+;; (my-dolist (a '()) (print a))
+;; => nil
+
+(defmacro my-dotimes (spec &rest body)
+  (let ((var (car spec))
+        (countform (cadr spec))
+        (resultform (caddr spec))
+        (loopsym (make-symbol "loop"))
+        (endsym (make-symbol "end"))
+        (countersym (make-symbol "counter"))
+        (maxsym (make-symbol "max")))
+    `(let ((,var nil)
+           (,maxsym ,countform)
+           (,countersym 0))
+       (tagbody
+        ,loopsym
+          (setq ,var ,countersym)
+          (when (>= ,countersym ,maxsym)
+            (go ,endsym))
+          (progn ,@body)
+          (setq ,countersym (+ ,countersym 1))
+          (go ,loopsym)
+        ,endsym
+          (when (< 0 ,var) (setq ,var 0)))
+       ,resultform)))
+
+;; (my-dotimes (i 3) (print i))
+;; => 0
+;; => 1
+;; => 2
+;; => nil
+;; (my-dotimes (i 3 i) (print i))
+;; => 0
+;; => 1
+;; => 2
+;; => 3
+;; (my-dotimes (i -5 i) (print i))
+;; => 0
+;; (my-dotimes (i -5) (print i))
+;; => nil
diff --git a/implementation/mini-meval.lisp b/implementation/mini-meval.lisp
index 054e8bf..cb3065d 100644
--- a/implementation/mini-meval.lisp
+++ b/implementation/mini-meval.lisp
@@ -1,11 +1,111 @@
 (require 'match "match")
 (require 'util "util")
 
-;; TODO (dans mini-meval et/ou compilateur) :
+(defmacro etat-local (etat)
+  `(car ,etat))
+
+(defmacro etat-global (etat)
+  `(cadr ,etat))
+
+(defmacro etat-special (etat)
+  ;; Variables spéciales et constantes. (ou devrait-on mettre les constantes dans etat-global ?)
+  ;; Note sur les constantes : On ne protège pas contre la modification de parties d'une constante non atomiqe (mais clisp non plus, donc ça va).
+  `(caddr ,etat))
+
+(defun assoc-etat (var type etat)
+  (let ((search (cons var type)))
+    (or (assoc search (etat-special etat) :test #'equal)
+        (assoc search (etat-local   etat) :test #'equal)
+        (assoc search (etat-global  etat) :test #'equal))))
+
+(defun assoc-special (var type etat)
+  (assoc (cons var type) (etat-special etat) :test #'equal))
+
+(defun replace-local (etat new-etat-local)
+  (cons new-etat-local (cdr etat)))
+    
+(defun push-local (etat var type value)
+  (when (and (eq type 'variable) (assoc-etat var 'constant etat))
+    (error "mini-meval : Can't bind ~w : it is a constant." var))
+  (replace-local etat (acons (cons var type) value (etat-local etat))))
+
+(defun push-local-or-special (etat var type value immediate)
+  (let ((association (assoc-special var type etat))
+        (new-etat nil))
+    (if association
+        (progn
+          (setq new-etat (push-local etat var 'special-bakcup (cons association (cdr association))))
+          (if immediate
+              (progn (setf (cdr association) value)
+                     new-etat)
+              (push-local new-etat var 'special-future-phantom (cons association value))))
+        (push-local etat var 'variable value))))
+
+(defun affect-future-specials (new-etat etat)
+  (setq new-etat (etat-local new-etat))
+  (setq etat (etat-local etat))
+  (tagbody
+   loop
+     (when (eq new-etat etat) (go fin))
+     (when (eq (cdaar new-etat) 'special-future-phantom)
+       (setf (cdr (cadar new-etat)) (cddar new-etat)))
+     (setq new-etat (cdr new-etat))
+     (go loop)
+   fin))
+
+(defun pop-special-backups (new-etat etat)
+  (setq new-etat (etat-local new-etat))
+  (setq etat (etat-local etat))
+  (tagbody
+   loop
+     (when (eq new-etat etat) (go fin))
+     (when (eq (cdaar new-etat) 'special-bakcup)
+       (setf (cdr (cadar new-etat)) (cddar new-etat)))
+     (setq new-etat (cdr new-etat))
+     (go loop)
+   fin))
+
+(defun push-global! (etat name type value)
+  (setf (etat-global etat) (acons (cons name type) value (etat-global etat)))
+  etat)
+
+(defun push-special! (etat name type value)
+  (setf (etat-special etat) (acons (cons name type) value (etat-special etat)))
+  etat)
+
+(defun reduce-on-local-1 (new-etat-local callback lists)
+  (let ((res nil))
+    (tagbody
+     loop
+       (when (member nil lists) (go fin))
+       (setq res (apply callback new-etat-local (mapcar #'car lists)))
+       (setq new-etat-local (acons (cons (car res) (cadr res))
+                                   (caddr res)
+                                   new-etat-local))
+       (setq lists (mapcar #'cdr lists))
+       (go loop)
+     fin)
+    new-etat-local))
+
+(defun reduce-on-local (etat callback &rest lists)
+  (if (null lists)
+      etat
+      (replace-local etat (reduce-on-local-1 (etat-local etat) callback lists))))
+
+;; DONE
+;; - loop
+;; - dolist / dotimes
 ;; - match-automaton(tagbody+block)
+
+;; HALF-DONE (TODO)
+;; - read
+;; - warn
+;; - ` (quasiquote)
+
+;; TODO (dans mini-meval et/ou compilateur) :
+;; - syntaxe courte du let
 ;; - declaim
 ;; - format
-;; - ` (quasiquote)
 ;; - setf (écrire la macro)
 ;; - fdefinition, funcctionp, …
 ;; - symbolp, keywordp, keywords non mutables + nil et t, intern, make-symbol
@@ -13,13 +113,10 @@
 ;; - and / or (macros => if)
 ;; - &rest
 ;; - eq (vérifier qu'on préserve bien l'égalité de pointeurs là où il faut) / = / eql / equal / equalp
-;; - load / open / read / close
+;; - load / open / close
 ;; - defvar (gestion correcte des variables spéciales)
-;; - loop
-;; - dolist / dotimes
 ;; - array support (array-total-size, row-major-aref, copy-seq)
 ;; - string support (char=, map, string (symbol => string), format, print)
-;; - warn
 ;; - coder un reverse rapide.
 ;; - transformation de la récursion terminale.
 
@@ -55,11 +152,11 @@
                    (key      other    &allow-other-keys t)
                    (key      aux      &aux)
                    (key      reject   $&)
-                   (key      key      (:keyword . $k) `(,keyword ,(keyword-to-symbol keyword) nil nil))
+                   (key      key      (:keyword . $k) `(,(keyword-to-symbol keyword) ,(keyword-to-symbol keyword) nil nil)) ;; Not in the standard !
                    (key      key      (:var . $$) `(,var ,var nil nil))
-                   (key      key      (:keyword $$ :default _? :svar $$?) `(,keyword ,(keyword-to-symbol keyword) ,(car default) ,(car svar)))
+                   (key      key      (:keyword $$ :default _? :svar $$?) `(,(keyword-to-symbol keyword) ,(keyword-to-symbol keyword) ,(car default) ,(car svar))) ;; Not in the standard !
                    (key      key      (:var $$ :default _? :svar $$?) `(,var ,var ,(car default) ,(car svar)))
-                   (key      key      ((:keyword $k :var $$) :default _? :svar $$?) `(,keyword ,var ,(car default) ,(car svar)))
+                   (key      key      ((:keyword $k :var $$) :default _? :svar $$?) `(,(keyword-to-symbol keyword) ,var ,(car default) ,(car svar)))
                    (other    accept)
                    (other    aux      &aux)
                    (other    reject   $&)
@@ -74,27 +171,116 @@
 ;; (slice-up-lambda-list '(a b &rest))
 ;; (slice-up-lambda-list '(a b))
 
-(declaim (ftype function mini-meval)) ;; récursion mutuelle mini-meval-params / mini-meval
-(defun mini-meval-params (params global local fixed optional rest key other aux)
-  (if fixed
-      (if (endp params)
-          (error "mini-meval-params : not enough parameters !")
-          (mini-meval-params (cdr params) global (acons `(,(car fixed) . variable) (car params) local) (cdr fixed) optional rest key other aux))
-      (if optional
-          (let* ((var (caar optional))
-                 (value (if (endp params)
-                            (mini-meval (cadar optional) global local)
-                            (car params)))
-                 (svar (caddar optional))
-                 (new-local (acons `(,var . variable) value local))
-                 (new-local-2 (if svar
-                                  (acons `(,svar . variable) (endp params) new-local)
-                                  new-local)))
-            (mini-meval-params (cdr params) global new-local-2 nil (cdr optional) rest key other aux))
-          (if rest
-              (mini-meval-params params global (acons `(,(car rest) . variable) params local) nil nil nil key other aux)
-              ;; TODO : finir d'implémenter &key &allow-other-keys &aux &rest (et relire CLTL).
-              local))))
+(declaim (ftype function mini-meval)) ;; récursion mutuelle mini-meval-get-params-from-real -> mini-meval-params / mini-meval
+(defun mini-meval-params (params etat fixed optional rest key other aux)
+  (let ((new-etat etat)
+        (value nil)
+        (svar nil)
+        (current-key)
+        (search-key)
+        (seen-keys))
+    (tagbody
+     fixed
+       (when (endp fixed) (go end-fixed))
+       (when (endp params) (error "mini-meval-params : not enough parameters !"))
+       (setq new-etat (push-local-or-special new-etat (car fixed) 'variable (car params) nil))
+       ;; (setq association (assoc-special (car fixed) 'variable etat))
+       ;; (if association
+       ;;     (push (list association (mini-meval (car params) etat) (cdr association)) restore-special-fixed)
+       ;;     (setq new-etat (push-local new-etat (car fixed) 'variable (car params))))
+       (setq params (cdr params))
+       (setq fixed (cdr fixed))
+       (go fixed)
+     end-fixed
+       (affect-future-specials new-etat etat)
+       ;; (dolist (x restore-special-fixed) (setf (cdar x) (cadr x)))
+     optional
+       (when (endp optional) (go rest))
+       (if (endp params)
+           (setq value (mini-meval (cadar optional) new-etat)) ;; default value
+           (setq value (car params)))
+       (setq new-etat (push-local-or-special new-etat (caar optional) 'variable value t))
+       ;; (setq association (assoc-special (car optional) 'variable etat))
+       ;; (when association
+       ;;   (push (cons association (cdr association)) restore-special-optional)
+       ;;   (setf (cdr association) value))
+       ;; (unless association
+       ;;   (setq new-etat (push-local new-etat (car optional) 'variable value)))
+       (setq svar (caddar optional))
+       (when svar
+         (setq new-etat (push-local-or-special new-etat svar 'variable (endp params) t)))
+       (setq params (cdr params))
+       (setq optional (cdr optional))
+       (go optional)
+     rest
+       (unless rest (go key))
+       (setq new-etat (push-local new-etat (car rest) 'variable params))
+     key
+       (when (or (endp key) (endp params)) (go defaults-keys))
+       (when (endp (cdr params)) (error "mini-meval-params : odd number of key parameters"))
+       (setq search-key (keyword-to-symbol (car params)))
+       (when (eq search-key (caar key))
+         (setq current-key (car key))
+         (push (car current-key) seen-keys)
+         (setq key (cdr key))
+         (go end-assoc-key-loop))
+     assoc-key-loop
+       (when (endp (cdr key))
+         (go unknown-key))
+       (when (eq search-key (caadr key))
+         (setq current-key (cadr key))
+         (push (car current-key) seen-keys)
+         (setf (cdr key) (cddr key))
+         (go end-assoc-key-loop))
+       (go assoc-key-loop)
+     end-assoc-key-loop
+       (setq new-etat (push-local-or-special new-etat (second current-key) 'variable (second params) t))
+       ;; (setq association (assoc-special (second current-key) 'variable etat))
+       ;; (when association
+       ;;   (push (cons association (cdr association)) restore-special-optional)
+       ;;   (setf (cdr association) (cadr params)))
+       ;; (unless association
+       ;;   (setq new-etat (push-local new-etat (car current-key) 'variable (cadr params))))
+       (setq svar (fourth current-key))
+       (when svar
+         (setq new-etat (push-local-or-special new-etat svar 'variable t t)))
+       (go after-unknown-key)
+     unknown-key
+       (unless (or other (member search-key seen-keys))
+         (error "mini-meval-params : invalid key : ~w" (car params)))
+     after-unknown-key
+       (setq key (cdr key))
+       (setq params (cddr params))
+     defaults-keys
+       (dolist (k key)
+         (setq new-etat (push-local-or-special new-etat (second k) 'variable (mini-meval (third k) new-etat) t))
+         (setq svar (fourth k))
+         (when svar
+           (setq new-etat (push-local-or-special new-etat svar 'variable nil t))))
+     aux
+       (when (endp aux) (go fin))
+       (setq new-etat (push-local-or-special new-etat (caar aux) 'variable (mini-meval (cadar aux) new-etat) t))
+       (setq aux (cdr aux))
+     fin)
+    new-etat))
+
+  ;; (if fixed
+  ;;     (if (endp params)
+  ;;         (error "mini-meval-params : not enough parameters !")
+  ;;         (mini-meval-params (cdr params) (push-local etat (car fixed) 'variable (car params)) (cdr fixed) optional rest key other aux))
+  ;;     (if optional
+  ;;         (let* ((var (caar optional))
+  ;;                (value (if (endp params)
+  ;;                           (mini-meval (cadar optional) etat)
+  ;;                           (car params)))
+  ;;                (svar (caddar optional))
+  ;;                (new-etat (push-local etat var 'variable value)))
+  ;;           (when svar (setq new-etat (push-local new-etat svar 'variable (endp params))))
+  ;;           (mini-meval-params (cdr params) new-etat nil (cdr optional) rest key other aux))
+  ;;         (if rest
+  ;;             (mini-meval-params params (push-local etat (car rest) 'variable params) nil nil nil key other aux)
+  ;;             ;; TODO : finir d'implémenter &key &allow-other-keys &aux &rest (et relire CLTL).
+  ;;             etat))))
 ;              (if key
 ;                  (let* ((keyword (first (car key)))
 ;                         (var (second (car key)))
@@ -113,15 +299,15 @@
 ;                                          new-local)))
 ;                    (mini-meval-params params global new-local-2 nil nil nil (cdr key) other aux)
 
-(defun mini-meval-get-params-from-real (etat-global etat-local lambda-list effective-parameters)
+(defun mini-meval-get-params-from-real (etat lambda-list effective-parameters)
   "Lambda-list doit être déjà sliced."
-  (funcall #'mini-meval-params effective-parameters etat-global etat-local
-           (cdr (assoc 'fixed    lambda-list))
-           (cdr (assoc 'optional lambda-list))
-           (cdr (assoc 'rest     lambda-list))
-           (cdr (assoc 'key      lambda-list))
-           (cdr (assoc 'other    lambda-list))
-           (cdr (assoc 'aux      lambda-list))))
+  (mini-meval-params effective-parameters etat
+                     (cdr (assoc 'fixed    lambda-list)) ;; TODO : optimiser ça peut-être...
+                     (cdr (assoc 'optional lambda-list))
+                     (cdr (assoc 'rest     lambda-list))
+                     (cdr (assoc 'key      lambda-list))
+                     (cdr (assoc 'other    lambda-list))
+                     (cdr (assoc 'aux      lambda-list))))
 
 (defun splice-up-tagbody-1 (todo-body body result)
   (if (endp todo-body)
@@ -137,12 +323,13 @@
 (defun splice-up-tagbody (body)
   (splice-up-tagbody-1 (reverse body) nil nil))
 
-(defun mini-meval-error (expr etat-global etat-local &rest message)
-  (error "~w~&expression = ~w~&etat-global = ~w~&etat-local = ~w"
+(defun mini-meval-error (expr etat &rest message)
+  (error "mini-meval : ~w~&expression = ~w~&etat-global = ~w~&etat-local = ~w~&etat-special = ~w"
          (apply #'format nil message)
          expr
-         etat-global
-         etat-local))
+         (etat-global etat)
+         (etat-local etat)
+         (etat-special etat)))
 
 #|
 Mini-meval est un meval très simple destiné à évaluer les macros et les autres directives avec eval-when :compile-toplevel.
@@ -150,7 +337,7 @@ Mini-meval est un meval très simple destiné à évaluer les macros et les autr
 ;; Fonctionnement de mini-meval
 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-global (cons nil nil)) etat-local)
+(defun mini-meval (expr &optional (etat (list nil nil nil)))
   #|
   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
@@ -163,262 +350,307 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
   (cond-match
    expr
    ((debug :id _?)
-    (format t "~&debug :~&  id     = ~w~&  global = ~w~&  local  = ~w" id etat-global etat-local))
+    (format t "~&debug :~&  id     = ~w~&  global = ~w~&  local  = ~w~&etat-special = ~w" id (etat-global etat) (etat-local etat) (etat-special etat)))
    #| 2) Cas des macros |#
    ((:name $$ :params _*)
-    (let ((definition (assoc* `(,name . macro) #'equal etat-local (cdr etat-global))))
+    (let ((definition (assoc-etat name 'macro etat)))
       (if definition
           #| - Si on a une fonction de ce nom dans l'état-local ou dans l'etat-global, on l'exécute. |#
-          (mini-meval (apply (cdr definition) params) etat-global etat-local)
+          (mini-meval (apply (cdr definition) params) etat)
           (else))))
    #| 1) Cas des formes spéciales |#
    ((eval-when :situations ($*) :body _*)
     (if (member :execute situations)
-        (mini-meval body etat-global etat-local)
+        (mini-meval body etat)
         nil))
    ((flet ((:name $ :lambda-list @ :fbody _*)*) :body _*)
     (mini-meval `(progn ,@body)
-                etat-global
-                (reduce* etat-local (lambda (new-etat-local name lambda-list fbody)
-                                      (acons `(,name . function)
-                                             (mini-meval `(lambda ,lambda-list ,@fbody) etat-global etat-local)
-                                             new-etat-local))
-                         name lambda-list fbody)))
+                (reduce-on-local
+                 etat
+                 (lambda (ignore name lambda-list fbody) ignore
+                   (list name 'function (mini-meval `(lambda ,lambda-list ,@fbody) etat)))
+                 name lambda-list fbody)))
    ((labels ((:name $ :lambda-list @ :fbody _*)*) :body _*)
-    (let* ((new-bindings (reduce* nil (lambda (new-bindings name) `(((,name . function) . nil) . ,new-bindings))
-                                  name))
-           (new-etat-local (append new-bindings etat-local)))
-      (mapcar (lambda (name lambda-list fbody)
-                ;; On fait un assoc / setf dans new-bindings, qui ne contient que les fonctions qu'on vient juste d'ajouter, pour éviter
-                ;; le risque inexistant de faire une mutation dans etat-local.
-                ;; TODO : vérifier que ça marche.
-                (setf (cdr (assoc `(,name . function) new-bindings :test #'equal))
-                      (mini-meval `(lambda ,lambda-list ,@fbody) etat-global new-etat-local)))
-              name lambda-list fbody)
-      (mini-meval `(progn ,@body) etat-global new-etat-local)))
+    (let* ((new-etat (reduce-on-local
+                      etat
+                      (lambda (ignore name) ignore (list name 'function nil))
+                      name))
+           (new-etat-local (etat-local new-etat)))
+      (dolist* ((name name) (lambda-list lambda-list) (fbody fbody))
+               (setf (cdr (assoc `(,name . function) new-etat-local :test #'equal))
+                     (mini-meval `(lambda ,lambda-list ,@fbody) new-etat)))
+      (mini-meval `(progn ,@body) new-etat)))
    ((let ((:name $ :value _)*) :body _*)
-    (mini-meval `(progn ,@body)
-                etat-global
-                (reduce* etat-local (lambda (new-etat-local name value)
-                                      (acons `(,name . variable)
-                                             (mini-meval value etat-global etat-local)
-                                             new-etat-local))
-                         name value)))
+    (let ((new-etat etat)
+          (res nil))
+      (dolist* ((name name) (value value))
+               (setq new-etat (push-local-or-special new-etat name 'variable (mini-meval value etat) nil)))
+           ;; (new-etat (reduce-on-local
+           ;;            etat
+           ;;            (lambda (ignore name value) ignore
+           ;;                    (when (assoc-etat name 'constant etat) (error "mini-meval : Can't bind ~w : it is a constant." name))
+           ;;                    (setq association (assoc-special name 'variable etat))
+           ;;                    (when association
+           ;;                      (push (list association (mini-meval value etat) (cdr association)) restore-special))
+           ;;                    (unless association
+           ;;                      (list name 'variable (mini-meval value etat))))
+           ;;            name value)))
+      (affect-future-specials new-etat etat)
+      ;; (dolist (x restore-special) (setf (cdar x) (cadr x)))
+      (setq res (mini-meval `(progn ,@body) new-etat))
+      (pop-special-backups new-etat etat)
+      res))
+      ;; (dolist (x restore-special) (setf (cdar x) (caddr x)))))
    (((? (eq x 'let*)) ((:name $ :value _)*) :body _*)
-    (mini-meval `(progn ,@body)
-                etat-global
-                (reduce* etat-local (lambda (new-etat-local name value)
-                                      (acons `(,name . variable)
-                                             ;; Comme let sauf new-etat-local au lieu de etat-local ici.
-                                             (mini-meval value etat-global new-etat-local)
-                                             new-etat-local))
-                         name value)))
+    (let ((new-etat etat)
+          (res nil))
+      ;; pour chaque variable
+      (dolist* ((name name) (value value))
+               (setq new-etat (push-local-or-special new-etat name 'variable (mini-meval value new-etat) t)))
+           ;; (new-etat (reduce-on-local
+           ;;            etat
+           ;;            (lambda (new-etat-local name value)
+           ;;              (when (assoc-etat name 'constant etat) (error "mini-meval : Can't bind ~w : it is a constant." name))
+           ;;              (setq association (assoc-special name 'variable etat))
+           ;;              (when association
+           ;;                (push (cons association (cdr association)) restore-special)
+           ;;                (setf (cdr association) (mini-meval value (replace-local etat new-etat-local))))
+           ;;              (unless association
+           ;;                (list name 'variable (mini-meval value (replace-local etat new-etat-local)))))
+           ;;            name value)))
+      (setq res (mini-meval `(progn ,@body) new-etat))
+      (pop-special-backups new-etat etat)
+      res))
+      ;; (dolist (x restore-special) (setf (cdar x) (cdr x)))))
    ((macrolet ((:name $ :lambda-list @ :mbody _*)*) :body _*)
     (mini-meval `(progn ,@body)
-                etat-global
-                (reduce* etat-local (lambda (new-etat-local name lambda-list mbody)
-                                      (acons `(,name . macro)
-                                             ;; comme le flet sauf nil au lieu de new-etat-local
-                                             ;; CLTL 7.5 :
-                                             ;; The precise rule is that the macro-expansion functions defined
-                                             ;; by macrolet are defined in the global environment; lexically
-                                             ;; scoped entities that would ordinarily be lexically apparent
-                                             ;; are not visible within the expansion functions.
-                                             (mini-meval `(lambda ,lambda-list ,@mbody) etat-global nil)
-                                             new-etat-local))
-                         name lambda-list mbody)))
+                (let ((etat-sans-local (replace-local etat nil)))
+                  (reduce-on-local
+                   etat
+                   (lambda (ignore name lambda-list mbody) ignore
+                     ;; comme le flet sauf nil au lieu de new-etat-local
+                     ;; CLTL 7.5 :
+                     ;; The precise rule is that the macro-expansion functions defined
+                     ;; by macrolet are defined in the global environment; lexically
+                     ;; scoped entities that would ordinarily be lexically apparent
+                     ;; are not visible within the expansion functions.
+                     (list name 'macro
+                           (mini-meval `(lambda ,lambda-list ,@mbody) etat-sans-local)))
+                   name lambda-list mbody))))
    ((progn :body _*)
-    (car (last (mapcar (lambda (expr) (mini-meval expr etat-global etat-local))
-                       body))))
+    (let ((res nil))
+      (dolist (expr body res)
+        (setq res (mini-meval expr etat)))))
    ((if :condition _ :si-vrai _ :si-faux _?)
-    (if (mini-meval condition etat-global etat-local)
-        (mini-meval si-vrai etat-global etat-local)
+    (if (mini-meval condition etat)
+        (mini-meval si-vrai etat)
         (if si-faux
-            (mini-meval (car si-faux) etat-global etat-local)
+            (mini-meval (car si-faux) etat)
             nil)))
    ((lambda :lambda-list @ :body _*)
-    (let ((sliced-lambda-list (slice-up-lambda-list lambda-list)))
+    (let ((sliced-lambda-list (slice-up-lambda-list lambda-list))
+          (old-etat etat))
       (lambda (&rest effective-parameters)
-        (mini-meval `(progn ,@body)
-                    etat-global
-                    (mini-meval-get-params-from-real etat-global etat-local sliced-lambda-list effective-parameters)))))
+        (let* ((new-etat (mini-meval-get-params-from-real old-etat sliced-lambda-list effective-parameters))
+               (res (mini-meval `(progn ,@body) new-etat)))
+          (pop-special-backups new-etat etat)
+          res))))
    ((defun :name $ :lambda-list @ :body _*)
-    (assoc-set `(,name . function)
-          (mini-meval `(lambda ,lambda-list ,@body) etat-global etat-local)
-          (cdr etat-global)
-          #'equal)
+    (push-global! etat name 'function
+                  (mini-meval `(lambda ,lambda-list ,@body) etat))
     name)
    ((defmacro :name $ :lambda-list @ :body _*)
-    (assoc-set `(,name . macro)
-          (mini-meval `(lambda ,lambda-list ,@body) etat-global etat-local)
-          (cdr etat-global)
-          #'equal)
+    (push-global! etat name 'macro
+                  (mini-meval `(lambda ,lambda-list ,@body) etat))
     name)
    ((defvar :name $ :value _)
-    (assoc-set `(,name . variable)
-          (mini-meval value etat-global etat-local)
-          (cdr etat-global)
-          #'equal)
+    (when (assoc-etat name 'constant etat) (mini-meval-error expr etat "Can't bind ~w : it is a constant." name))
+    (let ((definition (assoc-etat name 'variable etat)))
+      ;; NOTE : if you do a "defvar" while in a "let" that binds the same variable, the result is gibberish and nonsensical.
+      ;; But that case is fairly rare and not worth the effort and run-time cost.
+      (push-special! etat name 'variable
+                     (if definition
+                         (cdr definition)
+                         (mini-meval value etat))))
     name)
    ((setq :name $ :value _)
-    (let ((definition (assoc* `(,name . variable) #'equal etat-local (cdr etat-global))))
+    (let ((definition (assoc-etat name 'variable etat))
+          (real-value (mini-meval value etat))) ;; Faut-il vérifier que NAME n'est pas une constante *avant* de calculer la valeur ?
       (if definition
-          (let ((real-value (mini-meval value etat-global etat-local)))
-            (setf (cdr definition) real-value)
-            real-value)
-          (mini-meval `(defvar ,name ,value) etat-global etat-local))))
+          (setf (cdr definition) real-value)
+          (progn
+            (when (assoc-etat name 'constant etat) (mini-meval-error expr etat "Can't set ~w : it is a constant." name))
+            (push-global! etat name 'variable (mini-meval value etat))))
+      real-value))
    ((function :name $$)
-    (let ((definition (assoc* `(,name . function) #'equal etat-local (cdr etat-global))))
+    (let ((definition (assoc-etat name 'function etat)))
       (if definition
           (cdr definition)
-          (mini-meval-error expr etat-global etat-local "mini-meval : undefined function : ~w." name))))
+          (mini-meval-error expr etat "Undefined function : ~w." name))))
    ;; TODO : #'(lambda ...)
    ((funcall :name _ :params _*)
-    (apply (mini-meval name etat-global etat-local)
-           (mapcar (lambda (x) (mini-meval x etat-global etat-local)) params)))
+    (apply (mini-meval name etat)
+           (mapcar (lambda (x) (mini-meval x etat)) params)))
    ((apply :name _ :p1 _ :params _*)
-    (let ((fun (mini-meval name etat-global etat-local))
-          (args (mapcar (lambda (x) (mini-meval x etat-global etat-local)) (cons p1 params))))
+    (let ((fun (mini-meval name etat))
+          (args (mapcar (lambda (x) (mini-meval x etat)) (cons p1 params))))
       (apply fun (append (butlast args) (car (last args))))))
    ((declaim _*)
     nil)
    ((error :format _ :args _*)
     (error "mini-meval : fonction error appellée par le code, le message est :~&~w" (apply #'format nil format args)))
+   ((warn :format _ :args _*)
+    (warn "mini-meval : fonction warn appellée par le code, le message est :~&~w" (apply #'format nil format args)))
    ((go :target $$)
     (when (null target)
-      (mini-meval-error expr etat-global etat-local "mini-meval : nil ne peut pas être une étiquette pour un return-from."))
-    (let ((association (assoc* `(,target . tagbody-tag) #'equal etat-local etat-global)))
+      (mini-meval-error expr etat "nil ne peut pas être une étiquette pour un go."))
+    (let ((association (assoc `(,target . tagbody-tag) (etat-local etat) :test #'equal)))
       (if association
           (funcall (cdr association))
-        (mini-meval-error expr etat-global etat-local "mini-meval : tentative de faire un go sur une étiquette qui n'existe pas ou plus : ~w.~&~w" target))))
+          (mini-meval-error expr etat "tentative de faire un go sur une étiquette qui n'existe pas ou plus : ~w.~&~w" target))))
    ((tagbody :body _*)
     (let ((spliced-body (splice-up-tagbody body))
           (next-tag nil)
-          (new-etat-local nil))
+          (new-etat nil))
       (tagbody
        init
-       (setq new-etat-local
-             (reduce* etat-local
-                      (lambda (new-etat-local tag)
-                        (acons `(,(car tag) . tagbody-tag)
-                               (lambda () (setq next-tag (car tag)) (go go-to-tag))
-                               new-etat-local))
-                      spliced-body))
+         (setq new-etat
+               (reduce-on-local
+                etat
+                (lambda (ignore tag) ignore
+                  (list (car tag) 'tagbody-tag
+                        (lambda () (setq next-tag (car tag)) (go go-to-tag))))
+                spliced-body))
        go-to-tag
-       (mini-meval `(progn ,@(cdr (assoc next-tag spliced-body)))
-                   etat-global
-                   new-etat-local))))
+         (mini-meval `(progn ,@(cdr (assoc next-tag spliced-body)))
+                     new-etat))))
    ((return-from :block-name $$ :value _)
-    (let ((association (assoc* `(,block-name . block-name) #'equal etat-local etat-global)))
+    (let ((association (assoc `(,block-name . block-name) (etat-local etat) :test #'equal)))
       (if association
           (funcall (cdr association) value)
-        (mini-meval-error expr etat-global etat-local "mini-meval : tentative de faire un return-from pour un bloc qui n'existe pas ou plus : ~w." block-name))))
+          (mini-meval-error expr etat "tentative de faire un return-from pour un bloc qui n'existe pas ou plus : ~w." block-name))))
    ((block :block-name $$ :body _*)
     (block block-catcher
-      (mini-meval `(progn ,@body) etat-global (acons `(,block-name . block-name)
-                                                     (lambda (x) (return-from block-catcher x))
-                                                     etat-local))))
+      (mini-meval `(progn ,@body)
+                  (push-local etat block-name 'block-name (lambda (x) (return-from block-catcher x))))))
    ((quote :val _)
     val)
+   ((function :fun (lambda _ . _))
+    (mini-meval fun etat))
    #| Traitement des appels de fonction |#
    ((:lambda (lambda @ _*) :params _*)
     #| - Si c'est une fonction anonyme, on l'exécute. |#
-    (apply (mini-meval lambda etat-global etat-local) params))
-   ((:name $ :params _*)
-    (let ((definition (assoc* `(,name . function) #'equal etat-local (cdr etat-global))))
+    (apply (mini-meval lambda etat) params))
+   (((function :fun (lambda _ . _)) :params . _)
+    (mini-meval `(,fun ,@params) etat))
+   ((:name (function $$) :params _*)
+    (apply (mini-meval name etat) params))
+   ((:name $$ :params _*)
+    (let ((definition (assoc-etat name 'function etat)))
       (if definition
           #| - Si on a une fonction de ce nom dans l'état-local ou dans l'etat-global, on l'exécute. |#
-          (apply (cdr definition) (mapcar (lambda (x) (mini-meval x etat-global etat-local)) params))
-          (mini-meval-error expr etat-global etat-local "mini-meval : undefined function : ~w." name))))
+          (apply (cdr definition) (mapcar (lambda (x) (mini-meval x etat)) params))
+          (mini-meval-error expr etat "Undefined function : ~w." name))))
    ((:num . (? numberp))
     num)
    ((:str . (? stringp))
     str)
-   (()
+   (nil
     nil)
    ((:name . $$)
-    (let ((definition (assoc* `(,name . variable) #'equal etat-local (cdr etat-global))))
+    (let ((definition (assoc-etat name 'variable etat)))
       (if definition
           (cdr definition)
-          (mini-meval-error expr etat-global etat-local "mini-meval : undefined variable : ~w." name))))))
+          (mini-meval-error expr etat "Undefined variable : ~w." name))))))
 
-(defun push-functions (etat-global functions)
-  (cons nil (mapcar-append (cdr etat-global) (lambda (x) `((,x .  function) . ,(fdefinition x))) functions)))
+(defun push-functions (etat functions)
+  (dolist (f functions)
+    (push-global! etat f 'function (fdefinition f)))
+  etat)
 
-(defmacro etat-global-fn (&rest functions)
-  `(push-functions '(nil) ',functions))
+(defmacro make-etat (&rest functions)
+  `(push-functions (list nil nil nil) ',functions))
 
-(load "test-unitaire")
+(require 'test-unitaire "test-unitaire")
 (erase-tests mini-meval)
 
-(deftestvar mini-meval e-global (etat-global-fn list + - cons car cdr < > <= >= =))
+(deftestvar mini-meval etat (make-etat list + - cons car cdr < > <= >= =))
 
 (deftest (mini-meval constante)
-    (mini-meval 42 e-global nil)
+    (mini-meval 42 etat)
   42)
 
 (deftest (mini-meval appel-fonction)
-    (mini-meval '(+ 2 3) e-global nil)
+    (mini-meval '(+ 2 3) etat)
   5)
 
 (deftest (mini-meval appel-fonction)
-    (mini-meval '(+ 2 (+ 3 4)) e-global nil)
+    (mini-meval '(+ 2 (+ 3 4)) etat)
   9)
 
 (deftest (mini-meval variable)
-    (mini-meval 'x e-global (acons '(x . variable) 42 nil))
+    (mini-meval 'x (push-local etat 'x 'variable 42))
   42)
 
 (deftest (mini-meval appel-fonction-et-variable)
-    (mini-meval '(+ x x 3) e-global (acons '(x . variable) 42 nil))
+    (mini-meval '(+ x x 3) (push-local etat 'x 'variable 42))
   87)
 
 (deftest (mini-meval appel-fonction-et-variable)
-    (mini-meval '(+ x (+ 3 x)) e-global (acons '(x . variable) 42 nil))
+    (mini-meval '(+ x (+ 3 x)) (push-local etat 'x 'variable 42))
   87)
 
 (deftest (mini-meval lambda extérieur)
-    (funcall (mini-meval '(lambda (x) x) e-global nil) 3)
+    (funcall (mini-meval '(lambda (x) x) etat) 3)
   3)
 
 (deftest (mini-meval lambda extérieur)
-    (funcall (mini-meval '(lambda (x) (+ x 3)) e-global nil) 4)
+    (funcall (mini-meval '(lambda (x) (+ x 3)) etat) 4)
   7)
 
 (deftest (mini-meval lambda immédiat)
-    (mini-meval '((lambda (x) (+ x 3)) 4) e-global nil)
+    (mini-meval '((lambda (x) (+ x 3)) 4) etat)
   7)
 
 (deftest (mini-meval let)
-    (mini-meval '(let ((x 3) (y 4)) (+ x y)) e-global nil)
+    (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))) e-global nil)
+    (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))) e-global nil)
+    (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))
 
 (deftest (mini-meval progn)
-    (mini-meval '(progn 1 2 3 4) e-global nil)
+    (mini-meval '(progn 1 2 3 4) etat)
   4)
 
 (deftest (mini-meval defvar)
-    (mini-meval '(progn (defvar x 42) x) e-global nil)
+    (mini-meval '(progn (defvar x 42) x) etat)
   42)
 
+(deftest (mini-meval defvar special)
+  (mini-meval '(progn
+                (defun foo1 () var)
+                (defun foo2 () (let ((var 4)) (list var (foo1))))
+                (defvar var 123)
+                (list (foo1) (foo2)))
+              etat)
+  '(123 (4 4)))
+
 (deftest (mini-meval defun)
-    (mini-meval '(progn (defun double (x) (+ x x)) (double 3)) e-global nil)
+    (mini-meval '(progn (defun double (x) (+ x x)) (double 3)) etat)
   6)
 
 (deftest (mini-meval quote)
-    (mini-meval ''x e-global nil)
+    (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)) e-global nil)
+    (mini-meval '(progn (defmacro qlist (x y) (list 'list (list 'quote x) (list 'quote y))) (qlist a b)) etat)
   '(a b))
 
 (deftest (mini-meval macrolet)
@@ -429,49 +661,61 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
                    (macrolet ((qlist (x y) (list 'list (list 'quote x) (list 'quote y))))
                      (qlist 'a 'b))
                    (qlist 'a 'b)))
-                e-global nil)
+                etat)
   '((a b) ('a 'b) (a b)))
 
 (deftest (mini-meval setf setq)
-    (mini-meval '(list (defvar x 42) x (setq x 123) x) e-global nil)
+    (mini-meval '(list (defvar x 42) x (setq x 123) x) etat)
   '(x 42 123 123))
 
 (deftest (mini-meval funcall)
-    (mini-meval '(funcall #'+ 1 2 3) e-global nil)
+    (mini-meval '(funcall #'+ 1 2 3) etat)
   '6)
 
 (deftest (mini-meval apply)
-    (mini-meval '(apply #'+ 1 2 (list (+ 1 2) 4)) e-global nil)
+    (mini-meval '(apply #'+ 1 2 (list (+ 1 2) 4)) etat)
   '10)
 
 (deftest (mini-meval function external)
-    (mini-meval '#'+ e-global nil)
+    (mini-meval '#'+ etat)
   #'+)
 
 (deftest (mini-meval function external)
-    (mini-meval '(funcall #'+ 1 2 3) e-global nil)
+    (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) e-global nil) 2)
+    (funcall (mini-meval '(progn (defun foo (x) (+ x 40)) #'foo) etat) 2)
   '42)
 
 (deftest (mini-meval function internal)
-    (mini-meval '(progn (defun foo (x) (+ x 40)) (funcall #'foo 2)) e-global nil)
+    (mini-meval '(progn (defun foo (x) (+ x 40)) (funcall #'foo 2)) etat)
   '42)
 
 (deftest (mini-meval function internal)
-    (mini-meval '(progn (defvar bar (list (lambda (x) (+ x 40)) 1 2 3)) (funcall (car bar) 2)) e-global nil)
+    (mini-meval '(progn (defvar bar (list (lambda (x) (+ x 40)) 1 2 3)) (funcall (car bar) 2)) etat)
   '42)
 
+(deftest (mini-meval call-function internal)
+    (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) e-global nil)
+    (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))))
-                  (list (funcall (car foo) 4) (funcall (cdr foo) 5) (funcall (car foo) 4))) e-global 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)
@@ -492,7 +736,7 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
                    (funcall (cdr foo0) 5)  ;; add 0  (+ 5)
                    (funcall (car foo42))   ;; show 42
                    (funcall (car foo0))))  ;; show 0
-                e-global nil)
+                etat)
   '(0 42 nil 1 nil 43 1 43 nil nil 49 6))
 
 (deftest (mini-meval labels)
@@ -501,7 +745,7 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
                   (foo 3)
                   (labels ((foo (x) (+ x 3)))
                     (foo 3)))
-                e-global nil)
+                etat)
   '(foo 4 6))
 
 (deftest (mini-meval flet)
@@ -510,11 +754,11 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
                   (foo 3)
                   (flet ((foo (x) (+ x 3)))
                     (foo 3)))
-                e-global nil)
+                etat)
   '(foo 4 6))
 
 (deftest (mini-meval labels)
-    (mini-meval '(< 2 3) e-global nil)
+    (mini-meval '(< 2 3) etat)
   t)
  
 (deftest (mini-meval labels)
@@ -523,7 +767,7 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
                   (fibo 5)
                   (labels ((fibo (n) (if (< n 3) 1 (+ (fibo (- n 1)) (fibo (- n 2)))))) ;; fibo 1 -> 1; 2 -> 1; 3 -> 2 ...
                     (fibo 5)))
-                e-global nil)
+                etat)
   '(fibo 8 5))
 
 (deftest (mini-meval flet)
@@ -532,13 +776,13 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
                   (fibo 5)
                   (flet ((fibo (n) (if (< n 3) 1 (+ (fibo (- n 1)) (fibo (- n 2)))))) ;; fibo 1 -> 1; 2 -> 1; 3 -> 2 ...
                     (fibo 5)))
-                e-global nil)
+                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-error (mini-meval error)
-    (mini-meval '(error "Some user error message.") (cons nil nil) nil))
+    (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))
diff --git a/util.lisp b/util.lisp
index b164a6c..5684ea8 100644
--- a/util.lisp
+++ b/util.lisp
@@ -175,4 +175,28 @@
 (defun find-what-is-used (expr)
   (remove-duplicates (find-what-is-used-1 expr)))
 
+(defmacro dolist* (spec &rest body)
+  (let* ((vars (mapcar #'car spec))
+         (listforms (mapcar #'cadr spec))
+         (loopsym (make-symbol "loop"))
+         (endsym (make-symbol "end"))
+         (listsyms (mapcar (lambda (x) (cons x (make-symbol "list"))) vars)))
+    `(let (,@(mapcar (lambda (var) `(,var nil)) vars)
+           ,@(mapcar (lambda (ls val) `(,(cdr ls) ,val)) listsyms listforms))
+       (tagbody
+        ,loopsym
+          ,@(mapcar (lambda (ls)
+                      `(setq ,(car ls) (car ,(cdr ls))))
+                    listsyms)
+          ,@(mapcar (lambda (ls)
+                      `(when (endp ,(cdr ls))
+                         (go ,endsym)))
+                    listsyms)
+          (progn ,@body)
+          ,@(mapcar (lambda (ls)
+                      `(setq ,(cdr ls) (cdr ,(cdr ls))))
+                    listsyms)
+          (go ,loopsym)
+        ,endsym))))
+
 (provide 'util)
\ No newline at end of file