From 78b4ccfd0b5aa468700b74c73a391f7c5c199c7d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <jahvascriptmaniac+github@free.fr>
Date: Wed, 12 Jan 2011 12:53:53 +0100
Subject: [PATCH] squash-lisp-2 est mort, vive squash-lisp-3 !

Sous clisp et sbcl : tous les tests passent, aucun warning.
---
 lisp/equiv-tests.lisp   |  17 ++-
 lisp/main.lisp          |   3 +-
 lisp/squash-lisp-1.lisp |   7 +-
 lisp/squash-lisp-3.lisp | 276 +++++++++++++++++++++++++++---------
 lisp/squash-lisp.lisp   | 304 +---------------------------------------
 5 files changed, 235 insertions(+), 372 deletions(-)

diff --git a/lisp/equiv-tests.lisp b/lisp/equiv-tests.lisp
index 92bc018..496c22c 100644
--- a/lisp/equiv-tests.lisp
+++ b/lisp/equiv-tests.lisp
@@ -8,10 +8,15 @@
      (deftest ,(append '(equiv expected/mini-meval)    module) (mini-meval ,test etat) ,expected)
      (deftest ,(append '(equiv squash-lisp-1-check)    module) (squash-lisp-1-check (squash-lisp-1 ,test t etat)) t) ;; etat -> pour les macros
      (deftest ,(append '(equiv expected/squash-lisp-1) module) (eval (squash-lisp-1-wrap (squash-lisp-1 ,test t etat))) ,expected) ;; etat -> pour les macros
-     ;; (deftest ,(append '(equiv squash-lisp-2-check)    module) (squash-lisp-2-check (squash-lisp-2 ,test)) t)
-     ;; (deftest ,(append '(equiv expected/squash-lisp-2) module) (eval (squash-lisp-2-wrap (squash-lisp-2 ,test))) ,expected)
-     ))
-
+     (deftest ,(append '(equiv squash-lisp-3-check)    module)
+         (let ((globals (cons nil nil)))
+           (squash-lisp-3-check (squash-lisp-3 (squash-lisp-1 ,test t etat nil nil globals) globals)))
+       t)
+     ;; (deftest ,(append '(equiv expected/squash-lisp-3) module)
+     ;;     (let ((globals (cons nil nil)))
+     ;;       (eval (squash-lisp-3-wrap (squash-lisp-3 (squash-lisp-1 ,test t etat nil nil globals) globals))))
+     ;;   ,expected)))
+))
 (erase-tests equiv)
      
 (deftestvar (equiv) etat (push-local (make-etat list + - cons car cdr < > <= >= =) '*test-equiv-var-x* 'variable 42))
@@ -218,4 +223,8 @@
     '#'+
   #'+)
 
+(deftest-equiv (lambda captures)
+    '(funcall ((lambda (x y) x (lambda (x) (+ x y))) 1 2) 3)
+  5)
+
 (provide 'equiv-tests)
diff --git a/lisp/main.lisp b/lisp/main.lisp
index 28102c0..6ee600b 100644
--- a/lisp/main.lisp
+++ b/lisp/main.lisp
@@ -10,8 +10,9 @@
 (load "vm")
 (load "match")
 (load "mini-meval")
-(load "squash-lisp")
 (load "squash-lisp-1")
+(load "squash-lisp-3")
+(load "squash-lisp")
 (load "equiv-tests")
 
 (provide 'main)
diff --git a/lisp/squash-lisp-1.lisp b/lisp/squash-lisp-1.lisp
index 504264f..b472e1c 100644
--- a/lisp/squash-lisp-1.lisp
+++ b/lisp/squash-lisp-1.lisp
@@ -285,7 +285,7 @@
              (other        (cdr (assoc 'other    sliced-lambda-list)))
              (aux          (cdr (assoc 'aux      sliced-lambda-list))))
         (push (cons whole-sym whole-sym) env-var)
-        `(lambda (&rest ,whole-sym)
+        `(named-lambda ,(make-symbol "LAMBDA") (&rest ,whole-sym)
            ,(transform whole-sym) ;; pour pas qu'il soit unused si aucun paramètre.
            ,(transform
              `(super-let (,@fixed
@@ -436,6 +436,9 @@
               (unwind-for-tagbody (object post-unwind-code)
                 object ;; unused variable
                 post-unwind-code)
+              (named-lambda (name params &rest body)
+                  name ;; unused variable
+                  `(lambda ,params ,@body))
               ;;Les macros ne sont pas expansées à la racine d'un tagbody, donc on expanse à la main
               ;;  les jump-label lorsqu'on rencontre un tagbody-unwind-catch.
               ;;(jump-label (name)
@@ -478,7 +481,7 @@ Attention : il y a quelques invariants qui ne sont pas présents dans cette vér
     t)
    ((let ($$*) :body _)
     (squash-lisp-1-check body))
-   ((lambda (&rest $$) :unused _ :body (let ($$*) _*))
+   ((named-lambda :name $$ (&rest $$) :unused _ :body (let ($$*) _*))
     (squash-lisp-1-check body))
    ((funcall :fun _ :params _*)
     (every #'squash-lisp-1-check (cons fun params)))
diff --git a/lisp/squash-lisp-3.lisp b/lisp/squash-lisp-3.lisp
index de5d4fc..56a97e8 100644
--- a/lisp/squash-lisp-3.lisp
+++ b/lisp/squash-lisp-3.lisp
@@ -1,103 +1,253 @@
 (require 'match "match")
 
-(defun squash-lisp-3 (expr local-env globals)
-  "Lorsqu'une variable à l'intérieur d'une `lambda` référence une déclaration à l'extérieur de la `lambda`, on la marque comme étant *capturée*.
+(defun squash-lisp-3-internal (expr globals &optional (local-env (cons nil nil)) (getset (cons nil nil)) (top-level (cons nil nil)))
+  "Lorsqu'une variable à l'intérieur d'une `lambda' référence une déclaration à l'extérieur de la `lambda', on la marque comme étant *capturée*.
    
-   On fusionne tous les `let` d'une `lambda` en les remontant dans un `let` unique à la racine de la `lamdba`.
+   On fusionne tous les `let' d'une `lambda' en les remontant dans un `let' unique à la racine de la `lamdba'.
+
+   [Abandonné, fait dans la compilation] On fusionne tous les `tagbody' d'une `lambda' en les remontant dans un `tagbody' unique à la
+   racine de la `lambda' ? + transformation des if en tagbody.
    
-   On sort toutes les lambdas (fonctions anonymes), on les nomme avec un symbole unique, et on les met au top-level."
-  (macrolet ((transform (expr &optional (local-env 'local-env)) `(squash-lisp-3 ,expr ,local-env globals)))
+   On sort toutes les lambdas (fonctions anonymes), on les nomme avec un symbole unique, et on les met au top-level.
+   
+   local-env : car = variables locales, cdr = variables capturées."
+  (macrolet ((transform (expr &optional (local-env 'local-env) (getset 'getset)) `(squash-lisp-3-internal ,expr globals ,local-env ,getset top-level)))
     (cond-match
      expr
      ;; simple-tagbody est équivalent à un progn, mais nécessaire pour les macrolet.
-     (((? (member x '(progn simple-tagbody))) :body _*)
-      (let ((res (list 'progn)))
+     ((:type (? (member x '(progn simple-tagbody))) :body _*)
+      (let ((res (list 'progn))
+            (is-tagbody (eq type 'simple-tagbody)))
         (labels ((squash-progn (body)
                    (dolist (e body)
                      (if (and (consp e) (eq 'progn (car e)))
                          (squash-progn (cdr e))
-                         (push (squash-lisp-3 e local-env globals) res)))))
-          (squash-progn body))
+                         (if (and (consp e) (eq 'simple-tagbody (car e)))
+                             (progn (setq is-tagbody t)
+                                    (squash-progn (cdr e)))
+                             (push e res))))))
+          (squash-progn (mapcar (lambda (x) (transform x)) body)))
         ;; TODO : ici : filtrer les expressions de `res' qui sont sans effet de bord, sauf la dernière.
-        (print res)
-        (if (cdr res) ;; res != '(progn)
-            (if (cddr res) ;; res != '(single-expr progn)
-                (reverse res)
-                (car res))
-            '(quote nil))))
+        (setq res (reverse res))
+        (setq res (append (remove ''nil (butlast res) :test #'equal) (last res)))
+        (setq res (if (cdr res) ;; res != '(progn)
+                      (if (cddr res) ;; res != '(progn single-expr)
+                          res
+                          (cadr res))
+                      '(quote nil)))
+        (when is-tagbody (setf (car res) 'simple-tagbody))
+        res))
      ((if :condition _ :si-vrai _ :si-faux _)
-      (and (squash-lisp-3 condition)
-           (squash-lisp-3 si-vrai)
-           (squash-lisp-3 si-faux)))
+      `(if ,(transform condition)
+           ,(transform si-vrai)
+           ,(transform si-faux)))
      ((unwind-protect :body _ :cleanup _)
-      (and (squash-lisp-3 body)
-           (squash-lisp-3 cleanup)))
+      `(unwind-protect ,(transform body)
+         ,(transform cleanup)))
      ;; tagbody-unwind-catch est équivalent à unwind-catch, mais nécessaire pour les macrolet.
-     (((? (member x '(unwind-catch tagbody-unwind-catch))) :object _ :body (progn _*) :catch-code _)
-      (and (squash-lisp-3 object)
-           (squash-lisp-3 body)
-           (squash-lisp-3 catch-code)))
+     ((:type (? (member x '(unwind-catch tagbody-unwind-catch))) :object _ :body (progn _*) :catch-code _)
+      `(,type ,(transform object)
+              ,(transform body)
+              ,(transform catch-code)))
      ((unwind :object _)
-      (squash-lisp-3 object))
+      `(unwind ,(transform object)))
      ((unwind-for-tagbody :object _ :post-unwind-code _)
-      (and (squash-lisp-3 object)
-           (squash-lisp-3 post-unwind-code)))
+      `(unwind-for-tagbody ,(transform object)
+                           ,(transform post-unwind-code)))
      ((jump-label :name $$)
-      t)
+      expr)
      ((jump :dest $$)
-      t)
-     ((let ($$*) :body _)
-      (squash-lisp-3 body))
-     ((lambda :params (&rest $$) :unused _ :body (let ($$*) _*))
-      (push let-vars stack)
-      (push `(lambda ,params
-               ,unused
-               (let (,let-vars)
-                 ,(squash-lisp-3 body)))
-            top-level)
-      (setq let-vars (pop stack)))
+      expr)
+     ((let :vars ($$*) :body _)
+      (setf (car local-env) (append vars (car local-env)))
+      (transform body))
+     ((named-lambda :name $$ :params (&rest :params-name $$) :unused _ :body (let ($$*) _*))
+      (let* ((new-local-env (cons (list params-name) nil))
+             (tbody (transform body new-local-env))
+             (new-getset nil)
+             (our-captures nil)
+             (not-our-captures nil))
+        ;; on "nomme" la lambda, et ce nom est global
+        (push name (car globals))
+        ;; on transforme les get-var de variables capturées en get-captured-var
+        (dolist (getter (car getset))
+          (if (member (cadr getter) (cdr local-env))
+              (setf (car getter) 'get-captured-var)
+              (push getter new-getset)))
+        ;; on remplace le (car getset) par ceux qui ont été ignorés
+        (setf (car getset) new-getset)
+        ;; on nettoie pour faire les sets
+        (setf new-getset nil)
+        ;; on transforme les get-var de variables capturées en get-captured-var
+        (dolist (setter (cdr getset))
+          (if (member (cadr setter) (cdr local-env))
+              (setf (car setter) 'set-captured-var)
+              (push setter new-getset)))
+        ;; on remplace le (cdr getset) par ceux qui ont été ignorés
+        (setf (cdr getset) new-getset)
+        ;; on récupère les noms variables qu'on a déclaré (c'est nous qui les capturons).
+        (setf our-captures (intersection (car new-local-env) (cdr new-local-env)))
+        (setf not-our-captures (set-difference (cdr new-local-env) our-captures))
+        ;; on ajoute celles qu'on n'a pas capturé aux captures d'au-dessus
+        (setf (cdr local-env) (append not-our-captures (cdr local-env)))
+        ;; on construit la lambda au top-level
+        (push `(set ,name (lambda ,params ,unused
+                                  (let ,(car new-local-env)
+                                    ,@(mapcar (lambda (x) `(make-captured-var ,x)) our-captures)
+                                    ,tbody)))
+              (car top-level))
+        ;; on remplace toute la lambda par un accès à sa définition au top-level
+        `(symbol-value ',name)))
      ((funcall :fun _ :params _*)
-      (every #'squash-lisp-3 (cons fun params)))
+      `(funcall ,@(mapcar (lambda (x) (transform x)) (cons fun params))))
      ((quote _)
-      t)
+      expr)
      ((get-var :var $$)
-      ;; chercher si var est dans local-env ou bien dans global
+      ;; chercher si var est dans (car local-env) ou bien dans global
       ;; si oui -> get-var
       ;; sinon, -> get-captured-var
-      t)
+      (if (or (member var (car local-env)) (member var (car globals)))
+          (progn
+            (push expr (car getset))
+            expr)
+          (progn
+            (pushnew var (cdr local-env))
+            `(get-captured-var ,var))))
      ((setq :name $$ :value _)
       ;; comme ci-dessus
-      (squash-lisp-3 value))
+      (if (or (member name (car local-env)) (member name (car globals)))
+          (progn
+            (push expr (car getset))
+            `(setq ,name ,(transform value)))
+          (progn
+            (pushnew name (cdr local-env))
+            `(set-captured-var ,name ,(transform value)))))
+     ;; + (transform value)
      ((fdefinition (quote $$))
-      t)
+      expr)
      ((symbol-value (quote $$))
-      t)
-     ((set (quote $$) :value _)
-      (squash-lisp-3 value)))))
+      expr)
+     ((set :var (quote $$) :value _)
+      `(set ,var ,(transform value)))
+     (_
+      (error "squash-lisp-3-internal : Assertion failed ! this should not be here : ~a" expr)))))
+
+(defun squash-lisp-3 (expr globals)
+  (let* ((tl (cons nil nil))
+         (lsym (make-symbol "MAIN"))
+         (psym (make-symbol "NO-PARAMETERS")))
+    (squash-lisp-3-internal `(named-lambda ,lsym (&rest ,psym) (get-var ,psym) (let () ,expr)) globals (cons nil nil) (cons nil nil) tl)
+    `(top-level ,lsym (progn ,@(car tl)))))
+
+
+(defun squash-lisp-3-check-internal (expr)
+  "Vérifie si expr est bien un résultat valable de squash-lisp-1.
+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
+   ;; simple-tagbody est équivalent à un progn, mais nécessaire pour les macrolet.
+   (((? (member x '(progn simple-tagbody))) :body _*)
+    (every #'squash-lisp-3-check-internal body))
+   ((if :condition _ :si-vrai _ :si-faux _)
+    (and (squash-lisp-3-check-internal condition)
+         (squash-lisp-3-check-internal si-vrai)
+         (squash-lisp-3-check-internal si-faux)))
+   ((unwind-protect :body _ :cleanup _)
+    (and (squash-lisp-3-check-internal body)
+         (squash-lisp-3-check-internal cleanup)))
+   ;; tagbody-unwind-catch est équivalent à unwind-catch, mais nécessaire pour les macrolet.
+   (((? (member x '(unwind-catch tagbody-unwind-catch))) :object _ :body (progn _*) :catch-code _)
+    (and (squash-lisp-3-check-internal object)
+         (squash-lisp-3-check-internal body)
+         (squash-lisp-3-check-internal catch-code)))
+   ((unwind :object _)
+    (squash-lisp-3-check-internal object))
+   ((unwind-for-tagbody :object _ :post-unwind-code _)
+    (and (squash-lisp-3-check-internal object)
+         (squash-lisp-3-check-internal post-unwind-code)))
+   ((jump-label :name $$)
+    t)
+   ((jump :dest $$)
+    t)
+   ;; ((let ($$*) :body _)
+   ;;  (squash-lisp-3-check-internal body))
+   ;; ((lambda (&rest $$) :unused _ :body (let ($$*) _*))
+   ;;  (squash-lisp-3-check-internal body))
+   ((funcall :fun _ :params _*)
+    (every #'squash-lisp-3-check-internal (cons fun params)))
+   ((quote _)
+    t)
+   ((get-var $$)
+    t)
+   ((setq :name $$ :value _)
+    (squash-lisp-3-check-internal value))
+   ((fdefinition (quote $$))
+    t)
+   ((symbol-value (quote $$))
+    t)
+   ((set (quote $$) :value _)
+    (squash-lisp-3-check-internal value))
+   ((make-captured-var $$)
+    t)
+   ((get-captured-var $$)
+    t)
+   ((set-captured-var $$ :value _)
+    (squash-lisp-3-check-internal value))
+   (_
+    (warn "squash-lisp-3-check-internal: Assertion failed ! This should not be here : ~w" expr)
+    nil)))
+
+(defun squash-lisp-3-check (expr)
+  (cond-match expr
+              ((top-level $$ (progn :body _*))
+               (every (lambda (x)
+                        (cond-match x
+                                    ((set $$ (lambda (&rest $$) (get-var $$)
+                                                     (let ($$*) :bodys _*)))
+                                     (every #'squash-lisp-3-check-internal bodys))
+                                    (_
+                                     (warn "~&squash-lisp-3-check : this should not be here :~&~a" x)
+                                     nil)))
+                      body))
+              (_ (warn "~&squash-lisp-3-check : this should not be here :~&~a" expr)
+                 nil)))
+
+(defun nice-squash-lisp-3-check (expr)
+  (match (top-level $$ (progn
+                         (set $$ (lambda (&rest $$) (get-var $$)
+                                         (let ($$*) (? squash-lisp-3-check-internal)*)))*))
+         expr))
+  
+(defun squash-lisp-1+3 (expr &optional (etat (list nil nil nil)))
+  (let ((globals (cons nil nil)))
+    (squash-lisp-3 (squash-lisp-1 expr t etat nil nil globals) globals)))
 
 (require 'test-unitaire "test-unitaire")
 (erase-tests squash-lisp-3)
 
-(deftest (squash-lisp-3 progn)
-    (squash-lisp-3 '(progn
-                     (progn (progn) (progn))
-                     (progn)
-                     (progn (progn) (progn) (progn))))
+(deftest (squash-lisp-3 internal progn)
+    (squash-lisp-3-internal '(progn
+                              (progn (progn) (progn))
+                              (progn)
+                              (progn (progn) (progn) (progn)))
+                            '(nil . nil))
   ''nil)
 
-(deftest (squash-lisp-3 progn)
-    (squash-lisp-3 '(progn))
+(deftest (squash-lisp-3 internal progn)
+    (squash-lisp-3-internal '(progn) '(nil . nil))
   ''nil)
 
-(deftest (squash-lisp-3 progn)
-    (squash-lisp-3 '(progn (symbol-value 'a)))
+(deftest (squash-lisp-3 internal progn)
+    (squash-lisp-3-internal '(progn (symbol-value 'a)) '((a) . nil))
   '(symbol-value 'a))
 
-(deftest (squash-lisp-3 progn)
-    (squash-lisp-3 '(progn
-                     (progn (progn (symbol-value 'a)) (progn))
-                     (progn)
-                     (progn (progn) (progn) (progn))))
-  '(symbol-value 'a))
+(deftest (squash-lisp-3 internal progn)
+    (squash-lisp-3-internal '(progn
+                              (progn (progn (symbol-value 'a)) (progn))
+                              (progn)
+                              (progn (progn) (progn) (progn)))
+                            '((a) . nil))
+  '(progn (symbol-value 'a) 'nil))
 
 ;(run-tests squash-lisp-3)
\ No newline at end of file
diff --git a/lisp/squash-lisp.lisp b/lisp/squash-lisp.lisp
index d1a3e11..e7b066f 100644
--- a/lisp/squash-lisp.lisp
+++ b/lisp/squash-lisp.lisp
@@ -1,311 +1,11 @@
 (require 'mini-meval "mini-meval")
 (require 'match "match")
 
-;; À la fin du fichier se trouvent des notes sur le fonctionnement (théorique) de squash-lisp.
-
-;; TODO : emballer le résultat de squash-lisp dans un (macrolet ...) pour les "special-operator" qu'on rajoute.
-
-;; TODO : faire une fonction permettant de tester si la valeur de retour d'un squash-lisp est sémantiquement équivalente au code passé en paramètre.
-;; TODO : tests unitaires.
-
 (require 'squash-lisp-1 "squash-lisp-1")
-;;(require 'squash-lisp-2 "squash-lisp-2")
+(require 'squash-lisp-1 "squash-lisp-3")
 
-;; captures = ((capture*)*)
-;; env-var = (((nom-variable symbole-unique état (référence-lecture*) (référence-écriture*))*)*)
-;; état = [nil == variable normale] || ['captured == variable capturée] || ['special == variable spéciale]
-;; env-fun = ((nom-fonction . symbole-unique)*)
+;; Notes sur le fonctionnement (théorique) de squash-lisp
 
-(defun squash-lisp-3 (expr &optional (captures (list nil)) (env-var (list nil)) env-fun special-vars)
-  "Détecte les variables capturées, supprime les let, let*, flet, labels, lambda en les transformant en simple-let et simple-lambda."
-  (cond-match
-   expr
-   
-   ;; let et let*
-   ((:type (? or (eq x 'let) (eq x 'let*)) ((:names $$ :values _)*) :body _)
-    ;; => new-env-var := env-var
-    (let ((new-env-var env-var)
-          (simple-let-vars nil)
-          (simple-let-backups nil)
-          (simple-let-pre-body nil)
-          (simple-let-body nil)
-          (simple-let-restore nil)
-          (set-expression)
-          (unique-sym nil)
-          (let* (eq type 'let*)))
-      ;; => Pour chaque binding
-      (dolist* ((n names) (v values))
-               ;; => On crée un symbole unique pour représenter cette liaison
-               (setq unique-sym (make-symbol (string n)))
-               ;; => ajouter unique-sym dans le simple-let qu'on crée
-               (push unique-sym simple-let-vars)
-               
-               (if (member n special-vars)
-                   ;; => Si c'est une variable spéciale,
-                   (progn
-                     ;; => On garde le nom d'origine comme nom de variable, et on utilise le nom unique comme symbole de sauvegarde.
-                     ;; => au tout début du body, avant les autres set, sauvegarder la variable
-                     (push `(setq ,unique-sym ,n) simple-let-backups)
-                     ;; => au début du body, set la variable avec (transform valeur (new- si let*)env-var env-fun)
-                     (push `(setq ,n ,(squash-lisp-3 v captures (if let* new-env-var env-var) env-fun)) simple-let-pre-body)
-                     ;; => à la fin du body (dans un unwind-protect), restaurer la variable
-                     (push `(setq ,n ,unique-sym) simple-let-restore))
-                   ;; => Sinon (variable "normale" ou futurement capturée),
-                   (progn
-                     ;; => au début du body, set la variable unique-sym avec (transform valeur (new- si let*)env-var env-fun)
-                     (setq set-expression `(setq ,unique-sym ,(squash-lisp-3 v captures (if let* new-env-var env-var) env-fun)))
-                     (push set-expression simple-let-pre-body)
-                     ;; => push (nom unique-sym nil <pas-de-get> <set-expression>) sur new-env-var
-                     (push `(,n ,unique-sym nil nil (,set-expression)) (car new-env-var)))))
-      ;; => transforme le body dans new-env-var env-fun
-      (setq simple-let-body (squash-lisp-3 body captures new-env-var env-fun))
-      ;; => construit et renvoie le simple-let
-      (if simple-let-restore
-          `(simple-let ,(reverse simple-let-vars)
-                       (unwind-protect
-                            (progn ,@(reverse simple-let-backups)  ;; Ne peut / doit pas déclenger d'unwind
-                                   ,@(reverse simple-let-pre-body) ;; À partir d'ici on peut
-                                   ,simple-let-body)
-                         (progn ,@(reverse simple-let-restore))))
-          `(simple-let ,(reverse simple-let-vars)
-                       (progn ,@(reverse simple-let-pre-body)
-                              ,simple-let-body)))))
-   
-   ;; flet et labels
-   ((:type (? or (eq x 'flet) (eq x 'labels)) ((:names $ :values _)*) :body _)
-    ;; => new-env-var := env-var
-    ;; => new-env-fun := env-fun
-    (let ((new-env-var env-var)
-          (new-env-fun env-fun)
-          (simple-let-vars nil)
-          (simple-let-pre-body nil)
-          (simple-let-body nil)
-          (set-expression)
-          (unique-sym nil)
-          (labels (eq type 'labels)))
-      ;; => Pour chaque binding
-      (dolist* ((n names) (v values))
-               ;; => On crée un symbole unique pour représenter cette liaison dans l'environnement des variables
-               (setq unique-sym (make-symbol (string n)))
-               ;; => ajouter unique-sym dans le simple-let qu'on crée
-               (push unique-sym simple-let-vars)
-               ;; => On push le unique-sym dans les variables : (unique-sym unique-sym nil <pas-de-get> <set-expression qui sera déterminé plus tard>)
-               (setq set-expression (list 'setq unique-sym 'not-yet-defined))
-               (push `(,unique-sym ,unique-sym nil nil (,set-expression)) (car new-env-var))
-               ;; => push (nom . unique-sym) sur new-env-fun
-               (push `(,n . ,unique-sym) new-env-fun)
-               ;; => au début du body, set la variable unique-sym avec (transform <lambda> (new- si labels)env-var (new- si labels)env-fun)
-               ;; + set sur le champ "valeur" du set-expression
-               ;; Note : on marche sur de l'ether…
-               (setf (third set-expression) (squash-lisp-3 v captures (if labels new-env-var env-var) (if labels new-env-fun env-fun)))
-               (push set-expression simple-let-pre-body))
-      ;; => On transforme le body dans new-env-var new-env-fun
-      (setq simple-let-body (squash-lisp-3 body captures new-env-var new-env-fun))
-      ;; => construit et renvoie le simple-let
-      `(simple-let ,(reverse simple-let-vars)
-                   (progn ,@(reverse simple-let-pre-body)
-                          ,simple-let-body))))
-   
-   ;; lambda
-   ;; Beaucoup de code dupliqué entre les let[*] / lambda / flet / labels
-   ;; TODO : gérer le &rest
-   ((lambda :params ($$*) :body _)
-    (let ((simple-lambda-captures (list nil))
-          (simple-lambda-body))
-      ;; Shift l'environnement courant en le remplaçant par un tout nouveau tout bô.
-      (setq env-var (cons nil env-var))
-      (push simple-lambda-captures captures)
-      ;; Quand on capture, on ne sait pas si la variable sera déclarée spéciale plus tard.
-      ;; Mais on a décidé (cf. les notes plus bas) de ne pas supporter la re-déclaration d'une variable comme spéciale.
-      ;; Création du simple-lambda
-      ;; TODO : insérer du code pour avoir les captures.
-      ;; TODO : closure ? make-closure ? ???
-      (setq simple-lambda-body
-            (squash-lisp-3
-             `(let ,(loop
-                       for i upfrom 1
-                       for var in params
-                       collect `(,var (get-param ,i)))
-                ,body)))
-      (print simple-lambda-captures)
-      (print captures)
-      `(simple-lambda
-        ,(length params)
-        ,simple-lambda-body)))
-   
-   ;; Appel de fonction
-   ((funcall :fun _ :args _*)
-    (cons 'funcall (mapcar (lambda (x) (squash-lisp-3 x captures env-var env-fun)) (cons fun args))))
-
-   ;; TODO : apply ?
-   
-   ;; Référence à une fonction
-   ((function :fun $$)
-    (let ((association (assoc fun env-fun)))
-      (unless association
-        (setq association `(,fun . ,(make-symbol (string fun))))
-        (push association env-fun))
-      (squash-lisp-3 `(get-var ,(cdr association)) captures env-var env-fun)))
-
-   ;; Progn
-   ((progn :exprs _*)
-    (cons 'progn (mapcar (lambda (x) (squash-lisp-3 x captures env-var env-fun)) exprs)))
-   
-   ;; Récupération d'un paramètre
-   ((get-param (? numberp))
-    expr)
-   
-   ;; Référence à une variable
-   ;; (get-var var)
-   ((:type (? or (eq x 'get-var) (eq x 'setq)) :var $$ :val _?)
-    (format t "~&var:~a~&env:~a~&~%" var env-var)
-    (let ((resultat nil)
-          (search-env-var env-var)
-          (envs nil)
-          (through-captures captures)
-          (is-global nil)
-          (variable nil)
-          (setq (eq type 'setq)))
-      ;; => chercher la définition de la variable.
-      (tagbody
-       search-loop
-         (push (car search-env-var) envs)
-       start
-         (when (endp (cdr search-env-var))
-           (setq is-global t))
-         (setq variable (assoc expr (car search-env-var)))
-         (unless variable
-           (when (endp (cdr search-env-var))
-             (go end))
-           (setq search-env-var (cdr search-env-var))
-           (go search-loop))
-       end)
-      ;; => resultat := (get-var var) ou (setq var (transform val …))
-      (setq resultat (if setq
-                         (list 'setq (or (second variable) var)
-                               (squash-lisp-3 (car val) captures env-var env-fun))
-                         (list 'get-var (or (second variable) var))))
-      ;; => Si la variable n'existe pas (globale donc)
-      (when (not variable)
-        (when (not is-global) (error "Assertion failed !!! La variable devrait être marquée comme globale apr le tagbody qu'on vient de passer.")) ;; DEBUG
-        ;; => la pusher dans l'env-var le plus haut (last …) == search-env-var
-        (if setq 
-            (push (setq variable `(,var ,var nil nil ,resultat)) (car search-env-var))
-            (push (setq variable `(,var ,var nil ,resultat nil)) (car search-env-var))))
-      ;; => Si elle ne se trouve ni dans l'env-var local (car) ni dans l'env-var global (last), alors c'est une capture
-      ;; => Autre possibilité : la variable est spéciale, on la traite alors comme si elle était non capturée.
-      (if (not (or (length=1 envs) is-global (eq 'special (third variable))))
-          (progn
-            (if setq
-                (setf (car resultat) 'setq-indirection)
-                (setf (car resultat) 'get-var-indirection))
-            ;; => si c'est une nouvelle capture
-            (unless (eq (third variable) 'captured)
-              ;; => Pour chaque environnement intermédiaire + l'env-var local,
-              (dotimes (i (length envs))
-                ;; => On marque la variable comme capturée sur tous les niveaux entre sa déclaration et son utilisation
-                (pushnew var (car through-captures))
-                (setq through-captures (cdr through-captures)))
-              ;; => On transforme tous les (get-var var) en (get-var-indirection var)
-              (dolist (reference-get (fourth variable))
-                (setf (car reference-get) 'get-var-indirection))
-              (setf (fourth variable) nil)
-              ;; => On transforme tous les (setq var val) en (setq-indirection var val)
-              (dolist (reference-set (fifth variable))
-                (setf (car reference-set) 'setq-indirection))
-              (setf (fifth variable) nil)))
-          ;; => Sinon, ce n'est pas (encore) une capture
-          ;; => push resultat sur l'entrée de la variable dans env-var.
-          (if setq
-              (push resultat (fifth variable))
-              (push resultat (fourth variable))))
-      ;; renvoyer resultat
-      resultat))
-   ((quote _)
-    expr)
-   (_
-    (error "squash-lisp-3: not implemented yet: ~a" expr)))) ;; end squash-lisp-3
-
-(defun squash-lisp-3-check (expr)
-  "Vérifie si expr est bien un résultat valable de squash-lisp-3.
-Permet aussi d'avoir une «grammaire» du simple-lisp niveau 3.
-Attention : il y a quelques invariants qui ne sont pas présents dans cette vérification."
-  (cond-match
-   expr
-   ((simple-let :vars ($$*) :body _)
-    (every #'squash-lisp-3-check body))
-   ((simple-lambda :nb-params (? numberp) :body _)
-    ;; nb-params = sans compter le paramètre de closure.
-    (every #' squash-lisp-3-check body))
-   ((funcall :function _ :args _*)
-    (every #'squash-lisp-3-check (cons function args)))
-   ((progn :body _*)
-    (every #'squash-lisp-3-check body))
-   ((get-param (? numberp))
-    t)
-   ((setq :var $$ :val _)
-    (squash-lisp-3-check val))
-   ((get-var :var $$)
-    t)
-   ((setq-indirection :var $$ :val _)
-    (squash-lisp-3-check val))
-   ((get-var-indirection $$)
-    t)
-   ((quote :val _)
-    t)
-   (_
-    (error "squash-lisp-3-check: Assertion failed ! This should not be here : ~a" expr))))
-
-;; TODO : pouquoi les let de squash-lisp-3 sont à l'envers ?
-
-(defun make-sql4-lambda (name nbargs slet-vars slet-body)
-  ;; TODO reverse et append les slet-body et slet-vars
-  `(named-lambda ,name ,nbargs (simple-let ,slet-vars (progn ,@slet-body))))
-
-;; TODO : où mettre les globales ?
-(defun squash-lisp-4 (expr)
-  (let ((stack nil)
-        (slet-vars nil)
-        (flat nil))
-    (labels ((rec (expr)
-               (cond-match
-                expr
-                ((simple-let :vars ($$*) :body _*)
-                 (push vars slet-vars)
-                 (rec body))
-                ((simple-lambda :nb-params (? numberp) :body _*)
-                 (let ((fun-name (make-symbol "a-function")))
-                   ;; nb-params = sans compter le paramètre de closure.
-                   ;; On push tout le monde
-                   (push slet-vars stack)
-                   ;; On raz pour un nouveau lambda
-                   (setq slet-vars nil)
-                   ;; On transforme le body : (rec body) ci-dessous,
-                   ;; et on crée la lambda et on l'ajoute au grand flat.
-                   ;; TODO : ajouter la liste de captures si nécessaire (?)
-                   (push (make-sql4-lambda fun-name nb-params slet-vars (rec body)) flat)
-                   ;; On réstaure tout le monde
-                   (setq slet-vars (pop stack))))
-                ((funcall :function _ :args _*)
-                 `(funcall ,(rec function) ,@(mapcar #'rec args)))
-                ((progn :body _*)
-                 (every #'squash-lisp-3-check body))
-                ((get-param (? numberp))
-                 expr)
-                ((setq :var $$ :val _)
-                 `(setq ,var ,(rec val)))
-                ((get-var $$)
-                 expr)
-                ((setq-indirection :var $$ :val _)
-                 `(setq-indirection ,var ,(rec val)))
-                ((get-var-indirection $$)
-                 expr)
-                ((quote _)
-                 expr)
-                (_
-                 (error "squash-lisp-4: Not implemented yet : ~a" expr)))))
-      (rec expr)
-      flat)))
 
 #|