From 9a64e1266009ea775c961a67e2d2b25fb4d066c3 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <jahvascriptmaniac+github@free.fr>
Date: Tue, 11 Jan 2011 14:18:57 +0100
Subject: [PATCH] Fuuuuusion !

---
 lisp/equiv-tests.lisp          |   2 +-
 lisp/notes/soutenance.markdown |   7 +-
 lisp/squash-lisp-1.lisp        | 623 ++++++++++++++++++++-------------
 lisp/squash-lisp-2.lisp        | 151 +++-----
 lisp/squash-lisp.lisp          |   2 +-
 5 files changed, 433 insertions(+), 352 deletions(-)

diff --git a/lisp/equiv-tests.lisp b/lisp/equiv-tests.lisp
index ba6dc4c..69f8bc6 100644
--- a/lisp/equiv-tests.lisp
+++ b/lisp/equiv-tests.lisp
@@ -1,4 +1,4 @@
-(require 'squash-lisp "squash-lisp")
+;(require 'squash-lisp "squash-lisp")
 (require 'mini-meval "mini-meval")
 (require 'test-unitaire "test-unitaire")
 
diff --git a/lisp/notes/soutenance.markdown b/lisp/notes/soutenance.markdown
index 43678e5..ea86780 100644
--- a/lisp/notes/soutenance.markdown
+++ b/lisp/notes/soutenance.markdown
@@ -7,7 +7,7 @@ Tests unitaires
 
 mini-meval
 ==========
-`mini-meval` est un méta-évaluateur «naïf» mais qui supporte pratiquement tout LISP sauf CLOS (Common Lisp Object System).
+`mini-meval` est un méta-évaluateur «naïf» mais qui supporte pratiquement tout LISP sauf CLOS (Common Lisp Object System), les packages, les hash, ….
 
 Syntaxe supportée par mini-meval et le simplificateur
 =====================================================
@@ -31,6 +31,10 @@ lisp2li
 
 squash-lisp
 ===========
+* Pour transformer les let/let*/flet/labels/lambda en let simplifiés : décorrelation de l'étape de déclaration d'une variable, son
+  affectation, et son utilisation.
+* La transformation est hygénique (les special-form intermédiaires qu'on ajoute sont des symboles uniques. On aurait pu utiliser le système
+  de package, mais on aurait dû supporter les packages à ce moment-là).
 * En 3 passes :
   * Passe 1 :
     * macro-expansion (on utilise `mini-meval`) et `eval-when`.
@@ -100,3 +104,4 @@ Ramasse-miettes
 Implémentation de fonctions LISP
 ================================
 * On a notre propre fonction `read` et notre propre fonction `format` pour être autonomes.
+* Implémentation de loop avec toutes les extensions sauf celles de typage (analysées mais ignorées silencieusement)
diff --git a/lisp/squash-lisp-1.lisp b/lisp/squash-lisp-1.lisp
index aa26ed3..1cba371 100644
--- a/lisp/squash-lisp-1.lisp
+++ b/lisp/squash-lisp-1.lisp
@@ -1,5 +1,6 @@
-(require 'mini-meval "mini-meval")
+(require 'mini-meval "mini-meval") ;; slice-up-lambda-list, macro-expansion, eval-when
 (require 'match "match")
+(require 'util "match") ;; derived-symbol, assoc-or, assoc-or-push
 
 ;; À la fin du fichier se trouvent des notes sur la compilation d'unwind & co.
 
@@ -7,6 +8,12 @@
 ;; TODO !!! donc adapter les calculs pour unwind,
 ;; TODO !!! sinon on n'aura pas la compatibilité x86
 
+
+
+;; TODO : transformer les if (cond?) en simple-tagbody
+;; TODO : mini-meval + squash-lisp-1 : les defmacro doivent définir une macro-fonction, pour qu'on puisse utiliser macroexpand dans le
+;;        source passé en paramètre. donc (defmacro foo (params) body*) -> (setf (fdefinition 'foo) (lambda (params) (block foo body*)))
+
 (defun simple-splice-up-tagbody (body)
   "Découpe le body d'un tagbody en une liste associative ordonnée toute simple :
    (tagbody a b (foo bar) c (baz) (quux) d) => '((a) (b (foo bar)) (c (baz) (quux)) (d))"
@@ -27,249 +34,366 @@
      end)
     (reverse all-res)))
 
-(defun squash-lisp-1 (expr &optional (at-toplevel t) (etat (list nil nil nil)))
-  "Supprime les macros, eval-when, tagbody/go, throw/catch, block/return-from,
+(defun squash-lisp-1 (expr &optional (at-toplevel t) (etat (list nil nil nil)) env-var env-fun (globals (cons nil nil)))
+  "Transformation 1 :
+   
+   Supprime les macros, eval-when, tagbody/go, throw/catch, block/return-from,
    transforme les appels de fonction en funcall, les constantes en quote
-   et simplifie pas mal d'autres choses."
-  (cond-match
-   expr
-   ;; - Si on rencontre une macro définie dans l'environnement de compiler-meval,
-   ;;   1) On demande à compiler-meval d'expanser la macro sur un niveau.
-   ;;   2) On re-lance la transformation (eval-when / defmacro / appel de macro / ...) sur le résultat s'il y a a eu expansion.
-   ((:name $$ :params _*)
-    (let ((definition (assoc-etat name 'macro etat)))
-      (if definition
-          (squash-lisp-1 (apply (cdr definition) params) at-toplevel etat)
-          (else))))
-   
-   ;; - Si on rencontre EVAL-WHEN,
-   ;;   - Au top-level,
-   ;;     - Pour chaque form du body,
-   ;;       - Si la situation contient :compile-toplevel, le form est évalué dans compiler-meval.
-   ;;       - Si la situation contient :load-toplevel, le form est compilé (après évaluation dans compiler-meval s'il y a lieu).
-   ;;       - Lorsqu'un eval-when au top-level contient des eval-when directement sous lui, ils sont traités comme s'ils étaient directement au top-level.
-   ;;   - Ailleurs
-   ;;     - Si la situation contient :load-toplevel, le form est compilé
-   ((eval-when :situations ($*) :body _*)
-    (when (and at-toplevel (member :compile-toplevel situations))
-      (mini-meval `(progn ,@body) etat))
-    (if (member :load-toplevel situations)
-        (squash-lisp-1 body at-toplevel etat)
-        (squash-lisp-1 nil at-toplevel etat))) ;; on renvoie nil
-   
-   ;; - Si on rencontre un defmacro (au toplevel ou ailleurs).
-   ;;   - On demande à compiler-meval de l'exécuter.
-   ((defmacro :name $ :lambda-list @ :body _*)
-    (mini-meval expr etat)
-    (squash-lisp-1 nil at-toplevel etat)) ;; on renvoie nil
-   
-   ;; - Si on rencontre un macrolet
-   ;;   - On fait une copie de l'état de compiler-meval
-   ;;   - On lui demande d'exécuter les définitions
-   ;;   - On évalue le body avec ce nouvel état
-   ;;   - On continue avec l'ancien état
-   ((macrolet :definitions ((:name $ :lambda-list @ :mbody _*)*) :body _*)
-    (let ((get-etat (make-symbol "GET-ETAT")))
-      (squash-lisp-1
-       `(progn ,@body)
-       at-toplevel
-       (mini-meval `(macrolet ,definitions ,get-etat) (push-local etat 'trapdoor 'squash-trapdoor get-etat)))))
-   
-   ;; - Si on gère le symbol-macrolet
-   ;;   - Le fonctionnement est le même que pour le macrolet
-   ;;   - Lorsqu'on rencontre un symbole, on regarde s'il a une définition de type symbol-macrolet
-   ((symbol-macrolet . _)
-    (error "squash-lisp-1 : Symbol-macrolet n'est pas implémenté."))
-   
-   ((progn :body _*)
-    (cons 'progn (mapcar (lambda (form) (squash-lisp-1 form at-toplevel etat)) body)))
-   
-   ((if :condition _ :si-vrai _ :si-faux _?)
-    `(if ,(squash-lisp-1 condition nil etat)
-         ,(squash-lisp-1 si-vrai nil etat)
-         ,(squash-lisp-1 (car si-faux) nil etat)))
-   
-   ;; Lorsqu'on rentre dans un block, on met sur la pile un marqueur spécial avec un pointeur vers un objet créé à l'exécution.
-   ((block :block-name $$ :body _*)
-    (let ((retval-sym (make-symbol "RETVAL"))
-          (block-id-sym (make-symbol "BLOCK-ID")))
-      (squash-lisp-1
-       `(let ((,retval-sym nil)
-              ;; Il y a un peu de redondance, car block-id-sym
-              ;; stocké dans le let et dans le unwind-catch
-              (,block-id-sym (cons nil nil)))
-          (unwind-catch ,block-id-sym
-                        (progn ,@body)
-                        ,retval-sym))
-       nil
-       (push-local etat block-name 'squash-block-catch (cons block-id-sym retval-sym)))))
-   
-   ;; Les return-from <nom> qui sont accessibles lexicalement sont remplacés par un (unwind <l'objet>)
-   ;; Unwind remonte la pile jusqu'à trouver le marqueur spécial, tout en exécutant les unwind-protect éventuels.
-   ;; Si unwind ne trouve pas le marqueur et arrive en haut de la pile, il signale une erreur et termine le programme.
-   ;; Sinon, l'exécution reprend après le block.
-   ((return-from :block-name $$ :value _)
-    (let ((association (assoc-etat block-name 'squash-block-catch etat)))
-      (unless association (error "Squash-Lisp-1 : Can't return from block ~w, it is inexistant or not lexically apparent." block-name))
-      (squash-lisp-1 `(progn (setq ,(cddr association) ,value)
-                           (unwind ,(cadr association)))
-                   nil etat)))
-   
-   
-   ;; Le traitement de tagbody/go est similaire pour sortir d'un tag, puis on jmp directement sur le tag de destination (vu qu'il est au même niveau).
-   ((tagbody :body _*)
-    (let ((spliced-body (simple-splice-up-tagbody body))
-          (res nil)
-          (unwind-catch-marker-sym (make-symbol "UNWIND-CATCH-MARKER-SYM"))
-          (new-etat etat)
-          (unique-label-sym nil)
-          (tagbody-id-sym (make-symbol "TAGBODY-ID")))
-      (dolist (zone spliced-body)
-        (setq unique-label-sym (make-symbol (format nil "~a" (car zone))))
-        (setq new-etat (push-local new-etat (car zone) 'squash-tagbody-catch (cons unwind-catch-marker-sym unique-label-sym)))
-        (setf (car zone) unique-label-sym))
-      (squash-lisp-1
-       `(let ((,tagbody-id-sym (cons nil nil)))
-           (tagbody-unwind-catch ,tagbody-id-sym
-                         (progn
-                           ,@(progn (dolist (zone spliced-body)
-                                      (push `(jump-label ,(car zone)) res) 
-                                      (push `(progn ,@(cdr zone)) res))
-                                    ;; (cdr (reverse …)) pour zapper le tout premier (jump-label …)
-                                    (cdr (reverse res))))
-                         nil)
-          nil)
-       nil
-       new-etat)))
-   
-   ((go :target (? or symbolp numberp))
-    (let ((association (assoc-etat target 'squash-tagbody-catch etat)))
-      (unless association (error "Squash-Lisp-1 : Can't go to label ~w, it is inexistant or not lexically apparent." target))
-      (squash-lisp-1 `(progn (unwind-for-tagbody ,(cadr association)
-                                        (jump ,(cddr association))))
-                   nil etat)))
-   
-   ;; Le traitement de catch/throw est similaire, sauf que le pointeur est simplement un pointeur vers l'objet utilisé pour le catch / throw.
-   ((catch :tag _ :body _*)
-    (squash-lisp-1
-     `(unwind-catch ,tag (progn ,@body) singleton-catch-retval)
-     nil etat))
+   et simplifie pas mal d'autres choses.
 
-   ((throw :tag _ :result _)
-    (squash-lisp-1
-     `(progn (setq singleton-catch-retval ,result)
-             (unwind ,tag))
-     nil etat))
+   Transformation 2 :
    
-   ;; Simplification du unwind-protect
-   ((unwind-protect :body _ :a-cleanup _ :other-cleanups _+)
-    `(unwind-protect ,(squash-lisp-1 body nil etat)
-       ,(squash-lisp-1 `(progn ,a-cleanup ,@other-cleanups) nil etat)))
-   
-   ((unwind-protect :body _ :a-cleanup _)
-    `(unwind-protect ,(squash-lisp-1 body nil etat)
-       ,(squash-lisp-1 a-cleanup nil etat)))
-    
-   ((:type (? (member x '(unwind-catch tagbody-unwind-catch))) :object _ :body _ :catch-code _)
-    `(,type ,(squash-lisp-1 object nil etat)
-            ,(squash-lisp-1 body nil etat)
-            ,(squash-lisp-1 catch-code nil etat)))
-   
-   ((unwind :object _)
-    `(unwind ,(squash-lisp-1 object nil etat)))
-   
-   ((unwind-for-tagbody :object _ :post-unwind-code _)
-    `(unwind-for-tagbody ,(squash-lisp-1 object nil etat) ,(squash-lisp-1 post-unwind-code nil etat)))
-   
-   ((jump-label :name $$)
-    expr)
-   
-   ((jump :dest $$)
-    expr)
+   Transforme les let, let*, flet, labels, lambda en super-let et simple-lambda,
+   détecte les variables et fonctions globales et stocke leurs noms dans le
+   paramètre globals, qui est une paire (noms-variables . noms-fonctions), et
+   rend tous les noms locaux de fonction (flet/labels) et de
+   variables (let/let*/lambda) uniques, mais pas les globaux.
 
-   ;; Transformation des (let[*] (var1 var2 var3) …) en (let[*] ((var1 nil) (var2 nil) (var3 nil)) …)
-   ((:type (? or (eq x 'let) (eq x 'let*)) :bindings (? and consp (find-if #'symbolp x)) :body . _)
-    (squash-lisp-1 `(,type ,(mapcar (lambda (b) (if (consp b) b `(b nil))) bindings) ,@body) nil etat))
-   
-   ((let ((:name $$ :value _)*) :body _*)
-    `(let ,(mapcar (lambda (n v) `(,n ,(squash-lisp-1 v nil etat))) name value)
-       ,(squash-lisp-1 `(progn ,@body) nil etat)))
-   
-   (((? (eq x 'let*)) ((:name $$ :value _)*) :body _*)
-    `(let* ,(mapcar (lambda (n v) `(,n ,(squash-lisp-1 v nil etat))) name value)
-       ,(squash-lisp-1 `(progn ,@body) nil etat)))
-   
-   ((flet ((:name $$ :params @ :fbody _*)*) :body _*)
-    `(simple-flet ,(mapcar (lambda (name params fbody)
-                             (list name (squash-lisp-1 `(lambda ,params (progn ,@fbody)) nil etat)))
-                           name params fbody)
-                  ,(squash-lisp-1 `(progn ,@body) nil etat)))
-   
-   ((labels ((:name $$ :params @ :fbody _*)*) :body _*)
-    `(simple-labels ,(mapcar (lambda (name params fbody)
-                               (list name (squash-lisp-1 `(lambda ,params (progn ,@fbody)) nil etat)))
-                             name params fbody)
-                    ,(squash-lisp-1 `(progn ,@body) nil etat)))
-   
-   ;; TODO : defun
-   ;; TODO : defvar
-   ;; => TODO : global-setq
-   ;; => TODO : global-setfun
-   ;; => TODO : proclaim
-   
-   ;; TODO: simplifier la lambda-list.
-   ((lambda :params _ :body _)
-    `(lambda ,params ,(squash-lisp-1 body nil etat)))
-   
-   ((lambda :params _ :body _*)
-    (squash-lisp-1 `(lambda ,params (progn ,@body)) nil etat))
-   
-   ((function :fun (lambda . _))
-    (squash-lisp-1 fun nil etat))
-   
-   ((function :fun $$)
-    expr)
+   `super-let' est lui-même transformé dans la foulée en simple-let qui ne fait
+   que déclarer les noms de variables, mais n'affecte pas de valeur
+   lui-même (les affectations sont faites avec des setq)
 
-   ((funcall :fun _ :params _*)
-    `(funcall ,@(mapcar (lambda (x) (squash-lisp-1 x nil etat)) (cons fun params))))
-   
-   ;; TODO : apply
-   ;; => TODO : définir la fonction funcall : (funcall #'funcall #'cons 1 2)
-   ;; => TODO : définir la fonction apply   : (funcall #'apply #'cons '(1 2))
-   
-   ((setq :name $$ :value _)
-    `(setq ,name ,(squash-lisp-1 value nil etat)))
-   
-   ((quote _)
-    expr)
-   
-   ((? or numberp stringp)
-    `(quote ,expr))
-   
-   ;; TODO : nil et t devraient être des defconst
-   ;; Doit être avant les symboles
-   (nil
-    ''nil)
-   
-   ($$
-    `(get-var ,expr))
-   
-   ;; Appels de fonction
-   ;; Doivent être après tout le monde.
-   ((:fun $$ :params _*)
-    (squash-lisp-1 `(funcall (function ,fun) ,@params) nil etat))
-   
-   ((:lambda (lambda . _) :params _*)
-    (squash-lisp-1 `(funcall ,lambda ,@params) nil etat))
-   
-   (((function :lambda (lambda . _)) :params . _)
-    (squash-lisp-1 `(funcall ,lambda ,@params) nil etat))
-   
-   (((function :name $$) :params _*)
-    (squash-lisp-1 `(funcall (function ,name) ,@params) nil etat))
-   
-   (_
-    (error "squash-lisp-1: Not implemented yet : ~a" expr))))
+   `at-toplevel' permet de déterminer si une expression est considérée comme
+   étant au top-level (pour les defmacro, eval-when, etc).
+
+   `etat' est l'état du compilateur (macro-expansion, eval-when avec
+   compile-time) env-var et env-fun et globals sont les environnements du code
+   compilé, utilisés pour rendre uniques tous les symboles."
+  (macrolet ((transform (expr &optional at-toplevel (etat 'etat)) `(squash-lisp-1 ,expr ,at-toplevel ,etat env-var env-fun globals)))
+    (cond-match
+     expr
+     ;; - Si on rencontre une macro définie dans l'environnement de compiler-meval,
+     ;;   1) On demande à compiler-meval d'expanser la macro sur un niveau.
+     ;;   2) On re-lance la transformation (eval-when / defmacro / appel de macro / ...) sur le résultat s'il y a a eu expansion.
+     ((:name $$ :params _*)
+      (let ((definition (assoc-etat name 'macro etat)))
+        (if definition
+            (transform (apply (cdr definition) params) at-toplevel)
+            (else))))
+     
+     ;; - Si on rencontre EVAL-WHEN,
+     ;;   - Au top-level,
+     ;;     - Pour chaque form du body,
+     ;;       - Si la situation contient :compile-toplevel, le form est évalué dans compiler-meval.
+     ;;       - Si la situation contient :load-toplevel, le form est compilé (après évaluation dans compiler-meval s'il y a lieu).
+     ;;       - Lorsqu'un eval-when au top-level contient des eval-when directement sous lui, ils sont traités comme s'ils étaient directement au top-level.
+     ;;   - Ailleurs
+     ;;     - Si la situation contient :load-toplevel, le form est compilé
+     ((eval-when :situations ($*) :body _*)
+      (when (and at-toplevel (member :compile-toplevel situations))
+        (mini-meval `(progn ,@body) etat))
+      (if (member :load-toplevel situations)
+          (transform body at-toplevel)
+          (transform 'nil))) ;; on renvoie nil
+     
+     ;; - Si on rencontre un defmacro (au toplevel ou ailleurs).
+     ;;   - On demande à compiler-meval de l'exécuter.
+     ((defmacro :name $ :lambda-list @ :body _*)
+      (mini-meval expr etat)
+      (transform `',name)) ;; on renvoie le nom
+     
+     ;; - Si on rencontre un macrolet
+     ;;   - On fait une copie de l'état de compiler-meval
+     ;;   - On lui demande d'exécuter les définitions
+     ;;   - On évalue le body avec ce nouvel état
+     ;;   - On continue avec l'ancien état
+     ((macrolet :definitions ((:name $ :lambda-list @ :mbody _*)*) :body _*)
+      (let ((get-etat (make-symbol "GET-ETAT")))
+        (transform
+         `(progn ,@body)
+         at-toplevel
+         (mini-meval `(macrolet ,definitions ,get-etat) (push-local etat 'trapdoor 'squash-trapdoor get-etat)))))
+     
+     ;; - Si on gère le symbol-macrolet
+     ;;   - Le fonctionnement est le même que pour le macrolet
+     ;;   - Lorsqu'on rencontre un symbole, on regarde s'il a une définition de type symbol-macrolet
+     ((symbol-macrolet . _)
+      (error "squash-lisp-1 : Symbol-macrolet n'est pas implémenté."))
+     
+     ((progn :body _*)
+      (cons 'progn (mapcar (lambda (form) (transform form at-toplevel)) body)))
+     
+     ((if :condition _ :si-vrai _ :si-faux _?)
+      `(if ,(transform condition)
+           ,(transform si-vrai)
+           ,(transform (car si-faux))))
+     
+     ;; Lorsqu'on rentre dans un block, on met sur la pile un marqueur spécial avec un pointeur vers un objet créé à l'exécution.
+     ((block :block-name $$ :body _*)
+      (let ((retval-sym (make-symbol "RETVAL"))
+            (block-id-sym (make-symbol "BLOCK-ID")))
+        (transform
+         `(let ((,retval-sym nil)
+                ;; Il y a un peu de redondance, car block-id-sym
+                ;; stocké dans le let et dans le unwind-catch
+                (,block-id-sym (cons nil nil)))
+            (unwind-catch ,block-id-sym
+                          (progn ,@body)
+                          ,retval-sym))
+         nil
+         (push-local etat block-name 'squash-block-catch (cons block-id-sym retval-sym)))))
+     
+     ;; Les return-from <nom> qui sont accessibles lexicalement sont remplacés par un (unwind <l'objet>)
+     ;; Unwind remonte la pile jusqu'à trouver le marqueur spécial, tout en exécutant les unwind-protect éventuels.
+     ;; Si unwind ne trouve pas le marqueur et arrive en haut de la pile, il signale une erreur et termine le programme.
+     ;; Sinon, l'exécution reprend après le block.
+     ((return-from :block-name $$ :value _)
+      (let ((association (assoc-etat block-name 'squash-block-catch etat)))
+        (unless association (error "Squash-Lisp-1 : Can't return from block ~w, it is inexistant or not lexically apparent." block-name))
+        (transform `(progn (setq ,(cddr association) ,value)
+                           (unwind ,(cadr association))))))
+     
+     ;; Le traitement de tagbody/go est similaire pour sortir d'un tag, puis on jmp directement sur le tag de destination (vu qu'il est au même niveau).
+     ((tagbody :body _*)
+      (let ((spliced-body (simple-splice-up-tagbody body))
+            (res nil)
+            (unwind-catch-marker-sym (make-symbol "UNWIND-CATCH-MARKER-SYM"))
+            (new-etat etat)
+            (unique-label-sym nil)
+            (tagbody-id-sym (make-symbol "TAGBODY-ID")))
+        (dolist (zone spliced-body)
+          (setq unique-label-sym (make-symbol (format nil "~a" (car zone))))
+          (setq new-etat (push-local new-etat (car zone) 'squash-tagbody-catch (cons unwind-catch-marker-sym unique-label-sym)))
+          (setf (car zone) unique-label-sym))
+        (transform
+         `(let ((,tagbody-id-sym (cons nil nil)))
+            (tagbody-unwind-catch ,tagbody-id-sym
+                                  (progn
+                                    ,@(progn (dolist (zone spliced-body)
+                                               (push `(jump-label ,(car zone)) res) 
+                                               (push `(progn ,@(cdr zone)) res))
+                                             ;; (cdr (reverse …)) pour zapper le tout premier (jump-label …)
+                                             (cdr (reverse res))))
+                                  nil)
+            nil)
+         nil
+         new-etat)))
+     
+     ((go :target (? or symbolp numberp))
+      (let ((association (assoc-etat target 'squash-tagbody-catch etat)))
+        (unless association (error "Squash-Lisp-1 : Can't go to label ~w, it is inexistant or not lexically apparent." target))
+        (transform `(progn (unwind-for-tagbody ,(cadr association)
+                                               (jump ,(cddr association)))))))
+     
+     ;; Le traitement de catch/throw est similaire, sauf que le pointeur est simplement un pointeur vers l'objet utilisé pour le catch / throw.
+     ((catch :tag _ :body _*)
+      (transform `(unwind-catch ,tag (progn ,@body) singleton-catch-retval)))
+
+     ((throw :tag _ :result _)
+      (transform `(progn (setq singleton-catch-retval ,result)
+               (unwind ,tag))))
+     
+     ;; Simplification du unwind-protect
+     ((unwind-protect :body _ :a-cleanup _ :other-cleanups _+)
+      `(unwind-protect ,(transform body)
+         ,(transform `(progn ,a-cleanup ,@other-cleanups))))
+     
+     ((unwind-protect :body _ :a-cleanup _)
+      `(unwind-protect ,(transform body)
+         ,(transform a-cleanup)))
+     
+     ((:type (? (member x '(unwind-catch tagbody-unwind-catch))) :object _ :body _ :catch-code _)
+      `(,type ,(transform object)
+              ,(transform body)
+              ,(transform catch-code)))
+     
+     ((unwind :object _)
+      `(unwind ,(transform object)))
+     
+     ((unwind-for-tagbody :object _ :post-unwind-code _)
+      `(unwind-for-tagbody ,(transform object) ,(transform post-unwind-code)))
+     
+     ((jump-label :name $$)
+      expr)
+     
+     ((jump :dest $$)
+      expr)
+
+     ;; Transformation des (let[*] (var1 var2 var3) …) en (let[*] ((var1 nil) (var2 nil) (var3 nil)) …)
+     ((:type (? or (eq x 'let) (eq x 'let*)) :bindings (? and consp (find-if #'symbolp x)) :body . _)
+      (transform `(,type ,(mapcar (lambda (b) (if (consp b) b `(b nil))) bindings) ,@body)))
+     
+     ((super-let :name ($$*) :stuff _*)
+      (setq name (mapcar (lambda (x) (cons x (derived-symbol x))) name))
+      (labels ((transform-super-let (expr)
+                 `(progn
+                    ,@(loop
+                         for (type . clause) in expr
+                         when (eq type 'set)
+                         collect `(setq ,(cdr (assoc (car clause) name)) (transform (cadr clause)))
+                         when (eq type 'use-var)
+                         do (push (assoc (car clause) name) env-var)
+                         when (eq type 'use-fun)
+                         do (push (assoc (car clause) name) env-fun)
+                         when (eq type 'if)
+                         do `(if ,(transform (car clause))
+                                 (progn ,(mapcar #'transform-super-let (cadr clause)))
+                                 (progn ,(mapcar #'transform-super-let (caddr clause))))
+                         when (eq type 'progn)
+                         collect `(progn ,(mapcar (lambda (x) (transform x)) clause))))))
+        ;; Note : ce <let> ne sera pas re-transformé (sinon boucle infinie).
+        `(let ,(mapcar #'cdr name)
+           ,(transform-super-let expr))))
+     
+     ((let ((:name $$ :value _)*) :body _*)
+      (transform
+       `(super-let ,name
+                   ,@(mapcar (lambda (n v) `(set ,n ,v)) name value)
+                   ,@(mapcar (lambda (n) `(use-var ,n)) name)
+                   (progn ,@body))))
+     
+     (((? (eq x 'let*)) ((:name $$ :value _)*) :body _*)
+      (transform
+       `(super-let ,name
+                   ,@(loop
+                        for n in name
+                        for v in value
+                        collect `(set ,n ,v)
+                        collect `(use-var ,n))
+                   (progn ,@body))))
+     
+     ((simple-flet ((:name $$ :params @ :fbody _*)*) :body _*)
+      (transform
+       `(super-let ,name
+                   ,@(mapcar (lambda (n params fbody) `(set ,n (lambda ,params (progn ,@fbody)))) name params fbody)
+                   ,@(mapcar (lambda (n) `(use-fun ,n)) name)
+                   (progn ,@body))))
+     
+     ((simple-labels ((:name $$ :params @ :fbody _*)*) :body _*)
+      (transform
+       `(super-let ,name
+                   ,@(mapcar (lambda (n) `(use-fun ,n)) name)
+                   ,@(mapcar (lambda (n params fbody) `(set ,n (lambda ,params (progn ,@fbody)))) name params fbody)
+                   (progn ,@body))))
+     
+     ;; TODO : defun
+     ;; TODO : defvar
+     ;; => TODO : global-setq
+     ;; => TODO : global-setfun
+     ;; => TODO : proclaim
+     
+     ;; TODO: simplifier la lambda-list.
+     ((lambda :params _ :body _*)
+      (let* ((sliced-lambda-list (slice-up-lambda-list params))
+             (whole-sym    (make-symbol "LAMBDA-PARAMETERS"))
+             (temp-key-sym (make-symbol "TEMP-KEY-SYM"))
+             (fixed        (cdr (assoc 'fixed    sliced-lambda-list)))
+             (optional     (cdr (assoc 'optional sliced-lambda-list)))
+             (rest         (cdr (assoc 'rest     sliced-lambda-list)))
+             (key          (cdr (assoc 'key      sliced-lambda-list)))
+             (other        (cdr (assoc 'other    sliced-lambda-list)))
+             (aux          (cdr (assoc 'aux      sliced-lambda-list))))
+        `(lambda (&rest ,whole-sym)
+           ,(transform
+             `(super-let (,@fixed
+                          ,@(mapcar #'car optional)
+                          ,@(remove nil (mapcar #'third optional))
+                          ,@rest
+                          ,@(mapcar #'car key)
+                          ,@(remove nil (mapcar #'fourth key))
+                          ,@(mapcar #'car aux)
+                          ,@(if (and key (not other)) `(,temp-key-sym) nil))
+                         ,@(loop
+                              for param in fixed
+                              collect `(set ,param (car ,whole-sym))
+                              collect `(use ,param)
+                              collect `(progn (setq ,whole-sym (cdr ,whole-sym))))
+                         ,@(loop
+                              for (param default predicate) in optional
+                              collect `(if ,whole-sym
+                                           ((set ,param (car whole-sym))
+                                            (progn (setq ,whole-sym (cdr ,whole-sym)))
+                                            (use ,param)
+                                            ,@(if predicate `((set ,predicate t)   (use predicate)) nil))
+                                           ((set ,param ,default)
+                                            (use ,param)
+                                            ,@(if predicate `((set ,predicate nil) (use predicate)) nil))))
+                         ,@(if rest
+                               `((set ,(car rest) ,whole-sym)
+                                 (use ,(car rest)))
+                               nil)
+                         ,@(if key
+                               `(progn (if (evenp (length ,whole-sym)) nil (error "Odd number of arguments, but function has &key.")))
+                               nil)
+                         ,@(if key
+                               (loop
+                                  for (keyword param default predicate) in key
+                                  ;; TODO : quand on a trouvé, pouvoir faire set et use (support de simple-tagbody & jump-label super-let)
+                                  collect (let ((search-key (make-symbol "SEARCH-KEY")))
+                                            `((progn (simple-tagbody
+                                                      (jump-label ,search-key)
+                                                      (if ,temp-key-sym
+                                                          (if (eq (car ,search-key) ,keyword)
+                                                              ;; trouvé
+                                                              nil
+                                                              ;; chercher encore
+                                                              (progn
+                                                                (setq ,temp-key-sym (cddr ,search-key))
+                                                                (jump ,search-key)))
+                                                          ;; pas trouvé
+                                                          nil)))
+                                              (if ,temp-key-sym
+                                                  ((set ,param (car ,temp-key-sym))
+                                                   (use ,param)
+                                                   ,@(if predicate `((set predicate t) (use predicate)) nil))
+                                                  ((set ,param ,default)
+                                                   (use ,param)
+                                                   ,@(if predicate `((set predicate nil) (use predicate)) nil))))))
+                               nil)
+                         ;; TODO : not implemented yet : vérifier s'il y a des key non autorisées.
+                         ,@(loop
+                              for (param val) in aux
+                              collect `(set ,param ,val)
+                              collect `(use ,param))
+                         (progn ,@body))))))
+     
+     ((function :fun (lambda . _))
+      (transform fun))
+     
+     ((function :fun $$)
+      `(get-var ,(assoc-or fun env-fun (assoc-or-push fun (derived-symbol (string fun)) (cdr globals)))))
+
+     ((funcall :fun _ :params _*)
+      `(funcall ,(transform fun) ,@(mapcar (lambda (x) (transform x)) params)))
+
+     ;; TODO : apply
+     ;; => TODO : définir la fonction funcall : (funcall #'funcall #'cons 1 2)
+     ;; => TODO : définir la fonction apply   : (funcall #'apply #'cons '(1 2))
+     
+     ((setq :name $$ :value _)
+      `(setq ,(assoc-or name env-var (assoc-or-push name (derived-symbol name) (car globals)))
+             ,(transform value)))
+     
+     ((quote _)
+      expr)
+     
+     ((? or numberp stringp)
+      `(quote ,expr))
+     
+     ;; TODO : nil et t devraient être des defconst
+     ;; Doit être avant les symboles
+     (nil
+      ''nil)
+     
+     ($$
+      (print `(get-var ,(assoc-or expr env-var (assoc-or-push expr (derived-symbol expr) (car globals))))))
+     
+     ;; Appels de fonction
+     ;; Doivent être après tout le monde.
+     ((:fun $$ :params _*)
+      (transform `(funcall (function ,fun) ,@params)))
+     
+     ((:lambda (lambda . _) :params _*)
+      (transform `(funcall ,lambda ,@params)))
+     
+     (((function :lambda (lambda . _)) :params . _)
+      (transform `(funcall ,lambda ,@params)))
+     
+     (((function :name $$) :params _*)
+      (transform `(funcall (function ,name) ,@params)))
+     
+     (_
+      (error "squash-lisp-1: Not implemented yet : ~a" expr)))))
 
 (defun squash-lisp-1-wrap (expr)
   `(macrolet ((unwind-catch (object body catch-code)
@@ -282,6 +406,8 @@
                 ;; les (progn object) et (progn x) sert à permettre l'expansion des macros sur x
                 ;; (il est possible qu'elles ne soient pas expansées à la racine du tagbody)
                 `(tagbody (progn ,object) ,@(mapcar (lambda (x) (if (eq (car x) 'jump-label) (cadr x) (progn x))) (cdr body))))
+              (simple-tagbody (&rest body)
+                `(tagbody ,@(mapcar (lambda (x) (if (eq (car x) 'jump-label) (cadr x) (progn x))) body)))
               (unwind (object)
                 `(throw ,object nil))
               (unwind-for-tagbody (object post-unwind-code)
@@ -293,12 +419,8 @@
               ;;  name)
               (jump (dest)
                 `(go ,dest))
-              (simple-flet (spec &rest body)
-                `(flet ,(mapcar (lambda (x) (list (car x) (second (second x)) (third (second x)))) spec) ;; nom, lambda-list, fbody
-                   ,@body))
-              (simple-labels (spec &rest body)
-                `(labels ,(mapcar (lambda (x) (list (car x) (second (second x)) (third (second x)))) spec) ;; nom, lambda-list, fbody
-                   ,@body))
+              (simple-let (spec body)
+                `(let spec body))
               (get-var (x)
                 x))
      ,expr))
@@ -309,7 +431,8 @@ Permet aussi d'avoir une «grammaire» du simple-lisp niveau 1.
 Attention : il y a quelques invariants qui ne sont pas présents dans cette vérification."
   (cond-match
    expr
-   ((progn :body _*)
+   ;; simple-tagbody est équivalent à un progn, mais nécessaire pour les macrolet.
+   (((? (member x '(progn simple-tagbody))) :body _*)
     (every #'squash-lisp-1-check body))
    ((if :condition _ :si-vrai _ :si-faux _)
     (and (squash-lisp-1-check condition)
@@ -319,7 +442,7 @@ Attention : il y a quelques invariants qui ne sont pas présents dans cette vér
     (and (squash-lisp-1-check body)
          (squash-lisp-1-check cleanup)))
    ;; tagbody-unwind-catch est équivalent à unwind-catch, mais nécessaire pour les macrolet.
-   (((? (member x '(unwind-catch tagbody-unwind-catch))) :object _ :body _ :catch-code _)
+   (((? (member x '(unwind-catch tagbody-unwind-catch))) :object _ :body (progn _*) :catch-code _)
     (and (squash-lisp-1-check object)
          (squash-lisp-1-check body)
          (squash-lisp-1-check catch-code)))
@@ -332,9 +455,9 @@ Attention : il y a quelques invariants qui ne sont pas présents dans cette vér
     t)
    ((jump :dest $$)
     t)
-   (((? (member x '(let let* simple-flet simple-labels))) ((:name $$ :value _)*) :body _)
-    (every #'squash-lisp-1-check (cons body value)))
-   ((lambda :params @ :body _)
+   ((let ($$*) :body _)
+    (squash-lisp-1-check body))
+   ((lambda (&rest $$) :body _)
     (squash-lisp-1-check body))
    ((function :fun $$)
     t)
diff --git a/lisp/squash-lisp-2.lisp b/lisp/squash-lisp-2.lisp
index 01e58aa..4ebc9f5 100644
--- a/lisp/squash-lisp-2.lisp
+++ b/lisp/squash-lisp-2.lisp
@@ -3,10 +3,6 @@
 (require 'util "match") ;; derived-symbol, assoc-or, assoc-or-push
 
 (defun squash-lisp-2 (expr &optional env-var env-fun (globals (cons nil nil)))
-  "Transforme les let, let*, flet, labels, lambda en let simplifié
-   (uniquement les noms de variables, pas de valeur) et simple-lambda,
-   détecte les variables globales et stocke leurs noms dans une liste,
-   et rend tous les noms de fonction et de variables _locales_ uniques."
   (cond-match
    expr
    ((progn :body _*)
@@ -33,20 +29,24 @@
     expr)
    ((super-let :name ($$*) :stuff _*)
     (setq name (mapcar (lambda (x) (cons x (derived-symbol x))) name))
-    (let ((new-env-var env-var)
-          (new-env-fun env-fun))
+    (labels ((transform-super-let (expr)
+               `(progn
+                  ,@(loop
+                       for (type . clause) in stuff
+                       when (eq type 'set)
+                       collect `(setq ,(cdr (assoc (car clause) name)) (squash-lisp-2 (cadr clause) env-var env-fun globals))
+                       when (eq type 'use-var)
+                       do (push (assoc (car clause) name) env-var)
+                       when (eq type 'use-fun)
+                       do (push (assoc (car clause) name) env-fun)
+                       when (eq type 'if)
+                       do `(if ,(squash-lisp-2 (car clause) env-var env-fun globals)
+                               (progn ,(mapcar #'transform-super-let (cadr clause)))
+                               (progn ,(mapcar #'transform-super-let (caddr clause))))
+                       when (eq type 'progn)
+                       collect `(progn ,(mapcar (lambda (x) (squash-lisp-2 x env-var env-fun globals)) clause))))))
       `(let ,(mapcar #'cdr name)
-         (progn
-           ,@(loop
-                for (type . clause) in stuff
-                when (eq type 'set)
-                collect `(setq ,(cdr (assoc (car clause) name)) (squash-lisp-2 (cadr clause) new-env-var new-env-fun globals))
-                when (eq type 'use-var)
-                do (cons (assoc (car clause) name) env-var)
-                when (eq type 'use-fun)
-                do (cons (assoc (car clause) name) env-fun)
-                when (eq type 'progn)
-                collect `(progn ,(mapcar (lambda (x) (squash-lisp-2 x new-env-var new-env-fun globals)) clause)))))))
+         ,(transform-super-let expr))))
    ((let ((:name $$ :value _)*) :body _)
     (squash-lisp-2
      `(super-let ,name
@@ -78,39 +78,39 @@
                  ,@(mapcar (lambda (n v) `(set ,n ,v)) name value)
                  (progn ,body))
      env-var env-fun globals))
-   ((let ((:name $$ :value _)*) :body _)
-    (setq name (mapcar (lambda (x) (cons x (derived-symbol x))) name))
-    (let ((new-env-var (append name env-var)))
-      `(let ,(mapcar #'cdr name)
-         (progn ,@(mapcar (lambda (n v)
-                            `(setq ,(cdr n) ,(squash-lisp-2 v env-var env-fun globals)))
-                          name value)
-                ,(squash-lisp-2 body new-env-var env-fun globals)))))
-   (((? (eq x 'let*)) ((:name $$ :value _)*) :body _)
-    (setq name (mapcar (lambda (x) (cons x (derived-symbol x))) name))
-    (let ((new-env-var env-var)) ;; old = ((new-env-var (append name env-var)))
-      `(let ,(mapcar #'cdr name)
-         (progn ,@(mapcar (lambda (n v)
-                            (push (cons n v) new-env-var) ;; Ajouté
-                            `(setq ,(cdr n) ,(squash-lisp-2 v new-env-var env-fun globals))) ;; env-var -> new-env-var !!!
-                          name value)
-                ,(squash-lisp-2 body new-env-var env-fun globals)))))
-   ((simple-flet ((:name $$ :value _)*) :body _)
-    (setq name (mapcar (lambda (x) (cons x (derived-symbol x))) name))
-    (let ((new-env-fun (append name env-fun))) ;; new-env-var -> new-env-fun   +   env-var -> env-fun
-      `(let ,(mapcar #'cdr name)
-         (progn ,@(mapcar (lambda (n v)
-                            `(setq ,(cdr n) ,(squash-lisp-2 v env-var env-fun globals)))
-                          name value)
-                ,(squash-lisp-2 body env-var new-env-fun globals))))) ;; env-var -> env-fun
-   ((simple-labels ((:name $$ :value _)*) :body _)
-    (setq name (mapcar (lambda (x) (cons x (derived-symbol x))) name))
-    (let ((new-env-fun (append name env-fun))) ;; new-env-var -> new-env-fun   +   env-var -> env-fun
-      `(let ,(mapcar #'cdr name)
-         (progn ,@(mapcar (lambda (n v)
-                            `(setq ,(cdr n) ,(squash-lisp-2 v env-var new-env-fun globals))) ;; env-fun -> new-env-fun
-                          name value)
-                ,(squash-lisp-2 body env-var new-env-fun globals))))) ;; env-var -> env-fun
+   ;; ((let ((:name $$ :value _)*) :body _)
+   ;;  (setq name (mapcar (lambda (x) (cons x (derived-symbol x))) name))
+   ;;  (let ((new-env-var (append name env-var)))
+   ;;    `(let ,(mapcar #'cdr name)
+   ;;       (progn ,@(mapcar (lambda (n v)
+   ;;                          `(setq ,(cdr n) ,(squash-lisp-2 v env-var env-fun globals)))
+   ;;                        name value)
+   ;;              ,(squash-lisp-2 body new-env-var env-fun globals)))))
+   ;; (((? (eq x 'let*)) ((:name $$ :value _)*) :body _)
+   ;;  (setq name (mapcar (lambda (x) (cons x (derived-symbol x))) name))
+   ;;  (let ((new-env-var env-var)) ;; old = ((new-env-var (append name env-var)))
+   ;;    `(let ,(mapcar #'cdr name)
+   ;;       (progn ,@(mapcar (lambda (n v)
+   ;;                          (push (cons n v) new-env-var) ;; Ajouté
+   ;;                          `(setq ,(cdr n) ,(squash-lisp-2 v new-env-var env-fun globals))) ;; env-var -> new-env-var !!!
+   ;;                        name value)
+   ;;              ,(squash-lisp-2 body new-env-var env-fun globals)))))
+   ;; ((simple-flet ((:name $$ :value _)*) :body _)
+   ;;  (setq name (mapcar (lambda (x) (cons x (derived-symbol x))) name))
+   ;;  (let ((new-env-fun (append name env-fun))) ;; new-env-var -> new-env-fun   +   env-var -> env-fun
+   ;;    `(let ,(mapcar #'cdr name)
+   ;;       (progn ,@(mapcar (lambda (n v)
+   ;;                          `(setq ,(cdr n) ,(squash-lisp-2 v env-var env-fun globals)))
+   ;;                        name value)
+   ;;              ,(squash-lisp-2 body env-var new-env-fun globals))))) ;; env-var -> env-fun
+   ;; ((simple-labels ((:name $$ :value _)*) :body _)
+   ;;  (setq name (mapcar (lambda (x) (cons x (derived-symbol x))) name))
+   ;;  (let ((new-env-fun (append name env-fun))) ;; new-env-var -> new-env-fun   +   env-var -> env-fun
+   ;;    `(let ,(mapcar #'cdr name)
+   ;;       (progn ,@(mapcar (lambda (n v)
+   ;;                          `(setq ,(cdr n) ,(squash-lisp-2 v env-var new-env-fun globals))) ;; env-fun -> new-env-fun
+   ;;                        name value)
+   ;;              ,(squash-lisp-2 body env-var new-env-fun globals))))) ;; env-var -> env-fun
    ;; TODO
    ((lambda :params @ :body _)
     ;; TODO : simplifier la lambda-list
@@ -142,57 +142,10 @@
 
 ;; TODO : faire cette transformation dans squash-lisp-1
 ;; TODO : faire la transformation des let/let*/flet/labels en super-let dans squash-lisp-1
-(let* ((sliced-lambda-list (sliced-lambda-list *ll*))
-       (whole-sym (make-symbol "LAMBDA-PARAMETERS"))
-       (seen-keys-sym (make-symbol "SEEN-KEYS"))
-       (fixed    (cdr (assoc 'fixed    lambda-list)))
-       (optional (cdr (assoc 'optional lambda-list)))
-       (rest     (cdr (assoc 'rest     lambda-list)))
-       (key      (cdr (assoc 'key      lambda-list)))
-       (other    (cdr (assoc 'other    lambda-list)))
-       (aux      (cdr (assoc 'aux      lambda-list))))
-  `(lambda (&rest ,whole-sym)
-     'lambda-name ;; nil si fonction anonyme
-     (super-let (,@fixed
-                 ,@(mapcar #'car optional)
-                 ,@(remove nil (mapcar #'third optional))
-                 ,@rest
-                 ,@(mapcar #'car key)
-                 ,@(remove nil (mapcar #'fourth key))
-                 ,@(mapcar #'car aux)
-                 ,@(if (and key (not other)) `(,seen-keys-sym) nil))
-       ,@(loop
-            for param in fixed
-            collect `(set ,param (car ,whole-sym))
-            collect `(use ,param)
-            collect `(progn (setq ,whole-sym (cdr ,whole-sym))))
-       ,@(loop
-            for (param default predicate) in optional
-            collect `(set ,param (if ,whole-sym (car whole-sym) ,default))
-            collect `(progn (setq ,whole-sym (cdr ,whole-sym))) ;; TODO : devrait être dans le même if que ci-dessus, mais c'est assez difficile à loger…
-            when predicate
-              collect `(setq ,predicate (not (endp (,whole-sym))))
-              and collect `(use ,predicate)
-            collect `(use ,param))
-       ,@(if rest
-             `((set ,(car rest) ,whole-sym)
-               (use ,(car rest)))
-             nil)
-       ,@(if key
-             (progn (if (evenp (length ,whole-sym)) nil (error "Odd number of arguments, but function has &key.")))
-             nil)
-       ,@(loop
-            for (keyword param default predicate) in keyword
-            ;; TODO : &key not implemented yet
-            do (list keyword param default predicate))
-       ,@(loop
-            for (param val) in aux
-            collect `(set ,param ,val)
-            collect `(use ,param))
-       (progn ,body))))
+;; TODO : raison : transformer les appels de fonction en funcall, etc.
 
 
-nil à la fin
+;; nil à la fin
                                 
 (slice-up-lambda-list '(a b &optional (u 3 v) &rest c &key ((:foo bar)) :quux (:baz 'glop) &allow-other-keys &aux (x 1) (y (+ x 2))))
 
diff --git a/lisp/squash-lisp.lisp b/lisp/squash-lisp.lisp
index 094c6f0..d1a3e11 100644
--- a/lisp/squash-lisp.lisp
+++ b/lisp/squash-lisp.lisp
@@ -9,7 +9,7 @@
 ;; TODO : tests unitaires.
 
 (require 'squash-lisp-1 "squash-lisp-1")
-(require 'squash-lisp-2 "squash-lisp-2")
+;;(require 'squash-lisp-2 "squash-lisp-2")
 
 ;; captures = ((capture*)*)
 ;; env-var = (((nom-variable symbole-unique état (référence-lecture*) (référence-écriture*))*)*)