From 5aabdd03c890d1148a8bac90a5d0ba1a74dca494 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <jahvascriptmaniac+github@free.fr>
Date: Sat, 20 Nov 2010 01:09:43 +0100
Subject: [PATCH 1/3] Correction de quelques bugs.

---
 implementation/mini-meval.lisp |  2 +-
 lisp2li.lisp                   | 82 +++++++++++++++++++---------------
 meval.lisp                     | 47 +++++++++++--------
 test-unitaire.lisp             |  2 +-
 4 files changed, 76 insertions(+), 57 deletions(-)

diff --git a/implementation/mini-meval.lisp b/implementation/mini-meval.lisp
index c5622f3..7263bda 100644
--- a/implementation/mini-meval.lisp
+++ b/implementation/mini-meval.lisp
@@ -285,7 +285,7 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
     (error "mini-meval : fonction error appellée par le code, le message est :~&~w" (apply #'format nil format args)))
    ((go :target $$)
     (when (null target)
-      (min-meval-error expr etat-global etat-local "mini-meval : nil ne peut pas être une étiquette pour un return-from."))
+      (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)))
       (if association
           (funcall (cdr association))
diff --git a/lisp2li.lisp b/lisp2li.lisp
index 83c2f87..7dc4ebb 100644
--- a/lisp2li.lisp
+++ b/lisp2li.lisp
@@ -10,9 +10,11 @@
 ;; ,@
 (defvar my-unquote-unsplice nil);(caaadr '`(,@a)))
 
+(declaim (ftype function lisp2li)) ;; Double récursion map-lisp2li / lisp2li.
 (defun map-lisp2li (expr env)
   (mapcar (lambda (x) (lisp2li x env)) expr))
 
+(declaim (ftype function make-stat-env1)) ;; Double récursion make-stat-env1 / make-stat-env-optional
 (defun make-stat-env-optional (params env position num-env)
   (cond ((endp params)
          env)
@@ -36,17 +38,18 @@
          `((,(caar env) ,(+ 1 (cadar env)) ,(caddar env))
            . ,(recalculation (cdr env))))))
 
+(defun make-stat-env1 (params &optional env (position 1) num-env)
+  (cond ((endp params)
+         env)
+        ((eq '&optional (car params))
+         (make-stat-env-optional (cdr params) env position num-env))
+        ((eq '&rest (car params))
+         (make-stat-env1 (cdr params) env position num-env))
+        (T
+         `((,(car params) 0 ,position)
+           . ,(make-stat-env1 (cdr params) env (+ 1 position) num-env)))))
+
 (defun make-stat-env (params &optional env (position 1))
-  (defun make-stat-env1 (params &optional env (position 1) num-env)
-    (cond ((endp params)
-           env)
-          ((eq '&optional (car params))
-           (make-stat-env-optional (cdr params) env position num-env))
-          ((eq '&rest (car params))
-           (make-stat-env1 (cdr params) env position num-env))
-          (T
-           `((,(car params) 0 ,position)
-             . ,(make-stat-env1 (cdr params) env (+ 1 position) num-env)))))
   (make-stat-env1 params (recalculation env) position 0))
 
 (defun transform-quasiquote (expr)
@@ -73,16 +76,17 @@
     `(cons ,(transform-quasiquote (car expr))
 	   ,(transform-quasiquote (cdr expr))))))
 
+(defun get-nb-params-t (params r)
+  (cond ((endp params)
+         r)
+        ((or (eq '&optional (car params))
+             (eq '&rest (car params)))
+         (get-nb-params-t (cdr params) r))
+        (T
+         (get-nb-params-t (cdr params) (+ 1 r)))))
+
 (defun get-nb-params (params)
   "Renvoie le nombre exact de paramètres sans les &optional et &rest"
-  (defun get-nb-params-t (params r)
-    (cond ((endp params)
-           r)
-          ((or (eq '&optional (car params))
-               (eq '&rest (car params)))
-           (get-nb-params-t (cdr params) r))
-          (T
-           (get-nb-params-t (cdr params) (+ 1 r)))))
   (get-nb-params-t params 0))
 
 (defun implicit-progn (expr)
@@ -246,6 +250,9 @@ par le compilateur et par l’interpréteur"
    ;; declaim
    ((eq 'declaim (car expr))
     (cons :const nil))
+   ;; the
+   ((eq 'the (car expr))
+    (lisp2li (third expr)))
    ;; macros
    ((macro-function (car expr))
     (lisp2li (macroexpand-1 expr) env))
@@ -502,25 +509,28 @@ par le compilateur et par l’interpréteur"
                   (:const . 3)
                   (:const . 4))))
 
-(deftest (lisp2li macro)
-  (lisp2li '(cond ((eq (car '(1 2 3)) 1) T)
-                  ((eq (car '(1 2 3)) 2) 2)
-                  (T nil))
-           ())
-  '(:if (:call eq (:call car (:const 1 2 3)) (:const . 1))
-        (:const . T)
-        (:if (:call eq (:call car (:const 1 2 3)) (:const . 2))
-             (:const . 2)
-             (:const . nil))))
+;; TODO : on ne peut pas faire de tests sur des macros qu'on n'a pas implémentées nous-mêmes,
+;; car sinon le résultat dépend de l'implémentation.
 
-(deftest (lisp2li macro)
-  (lisp2li '(and (eq (car '(1 2)) 1)
-                 T)
-           ())
-  '(:if (:call not
-               (:call eq (:call car (:const 1 2)) (:const . 1)))
-        (:const . nil)
-        (:const . T)))
+;; (deftest (lisp2li macro)
+;;   (lisp2li '(cond ((eq (car '(1 2 3)) 1) T)
+;;                   ((eq (car '(1 2 3)) 2) 2)
+;;                   (T nil))
+;;            ())
+;;   '(:if (:call eq (:call car (:const 1 2 3)) (:const . 1))
+;;         (:const . T)
+;;         (:if (:call eq (:call car (:const 1 2 3)) (:const . 2))
+;;              (:const . 2)
+;;              (:const . nil))))
+
+;; (deftest (lisp2li macro)
+;;   (lisp2li '(and (eq (car '(1 2)) 1)
+;;                  T)
+;;            ())
+;;   '(:if (:call not
+;;                (:call eq (:call car (:const 1 2)) (:const . 1)))
+;;         (:const . nil)
+;;         (:const . T)))
 
 (deftest (lisp2li let)
   (lisp2li '(let ((x 1) (y 2))
diff --git a/meval.lisp b/meval.lisp
index 5993287..3b45fb8 100644
--- a/meval.lisp
+++ b/meval.lisp
@@ -5,15 +5,16 @@
       0
     (+ 1 (env-size (aref env 0)))))
 
+(defun get-env-num-r (num env counter)
+  (cond ((or (equalp env #()) (eq env nil))
+         env)
+        ((= num counter)
+         env)
+        (T
+         (get-env-num-r num (aref env 0) (- counter 1)))))
+
 (defun get-env-num (num env)
   "Récupère l’environnement correspondant à celui souhaité."
-  (defun get-env-num-r (num env counter)
-    (cond ((or (equalp env #()) (eq env nil))
-           env)
-          ((= num counter)
-           env)
-          (T
-           (get-env-num-t num (aref env 0) (- counter 1)))))
   (get-env-num-r num env (- (env-size env) 1)))
 
 (defun current-env (env)
@@ -31,19 +32,21 @@
       env
      (get-lower-env (aref env 0))))
 
+(defun make-rest-lower-env (lower-env pos values pos-rest)
+  (cond ((= pos pos-rest)
+         (setf (aref lower-env pos) values))
+        (T
+         (setf (aref lower-env pos) (car values))
+         (make-rest-lower-env lower-env
+                              (+ pos 1)
+                              (cdr values)
+                              pos-rest))))
+
 (defun make-rest (env values &optional (pos-rest 1))
   "Construit l'environnement en rajoutant tous les valeurs
 du &rest dans une cellule de l'env sous forme d'une liste"
   (let ((size (- (array-total-size env) 1)))
-    (defun make-rest-lower-env (lower-env pos values)
-      (cond ((= pos pos-rest)
-             (setf (aref lower-env pos) values))
-            (T
-             (setf (aref lower-env pos) (car values))
-             (make-rest-lower-env lower-env
-                                  (+ pos 1)
-                                  (cdr values)))))
-    (make-rest-lower-env env 1 values))
+    (make-rest-lower-env env 1 values pos-rest))
   env)
 
 (defun make-env (size list-values env &optional pos-rest)
@@ -59,8 +62,8 @@ du &rest dans une cellule de l'env sous forme d'une liste"
            (error "Too few arguments"))
           (T
            (if (= (array-total-size new-env) 0)
-               (setf new-env (make-array (+ 1 size)))
-             (setf (aref (get-lower-env new-env) 0) (make-array (+ 1 size))))
+               (setf new-env (make-array (+ 1 size) :initial-element nil))
+             (setf (aref (get-lower-env new-env) 0) (make-array (+ 1 size) :initial-element nil)))
            (let ((lower-env (get-lower-env new-env)))
              (if pos-rest
                  (make-rest lower-env
@@ -73,6 +76,8 @@ du &rest dans une cellule de l'env sous forme d'une liste"
                 )))
            new-env))))
 
+(declaim (ftype function meval)) ;; Récursion mutuelle meval / map-meval + meval-body + meval-args + meval-lambda + msetf
+
 (defun map-meval (list env)
   (mapcar (lambda (x) (meval x env)) list))
 
@@ -287,6 +292,10 @@ d’arguments dans un certain environnement."
     (meval (lisp2li '(setf x 42) '((x 0 1))) env)
     env)
   #(() 42)
-  #'equalp)
+  ;; Pour une raison totalement inexplicable, ce test fail avec #'equalp sous sbcl
+  ;; alors que les deux objets sont equalp en dehors du test (si on les met dans deux
+  ;; variable globale pour tester après). Pour l'instant, cette fonction suffira.
+  (lambda (x y)
+    (every #'identity (map 'list (lambda (x y) (or (eq x y) (and (numberp x) (numberp y) (= x y)))) x y))))
 
 (provide 'meval)
\ No newline at end of file
diff --git a/test-unitaire.lisp b/test-unitaire.lisp
index d2f43a9..8a65e4c 100644
--- a/test-unitaire.lisp
+++ b/test-unitaire.lisp
@@ -28,7 +28,7 @@
                                     (cdr (assoc (car module) (car from)))))))
 
 (defun test-get-variables-and-above (module &optional (from all-tests))
-  (apply #'append (mapcar #'reverse (test-collect-down-tree #'third module from))))
+  (remove-duplicates (apply #'append (mapcar #'reverse (test-collect-down-tree #'third module from))) :key #'car))
 
 (defun test-set-executed (from &optional (value t))
   (setf (second from) value))

From d17bbb8990764d8254c9ec0c6e24ce47844b52be Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <jahvascriptmaniac+github@free.fr>
Date: Sun, 21 Nov 2010 04:07:40 +0100
Subject: [PATCH 2/3] =?UTF-8?q?Impl=C3=A9mentation=20de=20loop=20(ne=20g?=
 =?UTF-8?q?=C3=A8re=20que=20les=20for,=20with(cass=C3=A9)=20et=20do).?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 implementation/loop.lisp       | 543 +++++++++++++++++++++++++++++++++
 implementation/mini-meval.lisp |   1 +
 2 files changed, 544 insertions(+)
 create mode 100644 implementation/loop.lisp

diff --git a/implementation/loop.lisp b/implementation/loop.lisp
new file mode 100644
index 0000000..12b6036
--- /dev/null
+++ b/implementation/loop.lisp
@@ -0,0 +1,543 @@
+(defmacro dbg (x) `(print ,x))
+(defmacro dbg (x) nil)
+
+(defun transform-loop (expr)
+  (let* ((name nil)
+         (acc (make-symbol "acc"))
+         (variables nil)
+         (all-variables nil)
+         (result nil)
+         (initialization nil)
+         (loopbody nil)
+         (finally nil)
+         (loop-keywords '(named
+                          with for as repeat
+                          initially finally
+                          collect append nconc sum count minimize maximize
+                          while until
+                          always never thereis
+                          do return
+                          doing
+                          if when unless else end
+                          and))
+         (stack nil)
+                                        ;        (group-with nil)
+         (for-clause-type nil)
+         (for-getter-fun nil)
+         (for-initial-value nil)
+         (for-step-fun nil)
+         (for-end-predicate nil)
+         (for-numeric-direction nil)
+         (for-numeric-limit nil)
+         (storage-sym nil)
+         (vars-names nil)
+         (get-vars-and-types-end-keywords nil)
+         (destr-psetq nil)
+         (left-destr nil)
+         (right-destr nil)
+         (destr-whole-sym (make-symbol "whole"))
+         (top-variables `((,acc nil)
+                          (,destr-whole-sym nil))))
+    (macrolet ((advance (x) `(setq ,x (cdr ,x))))
+      (tagbody
+       start
+         (dbg 'start)
+         (when (eq 'named (car expr))
+           (if (and (consp (cdr expr)) (symbolp (cadr expr)))
+               (setq name (cadr expr))
+               (error "bootstrap : loop : expected a loop name but got ~w" (cadr expr))))
+         ;;(go prologue)
+       prologue
+         (dbg 'prologue)
+         (dbg expr)
+         (when (endp expr) (go end-parse))
+         (case (car expr)
+           (with (go with))
+           (for (go for))
+           (as (go for))
+           (repeat (go repeat))
+           (initially (push 'prologue stack) (go initially))
+           (finally (push 'prologue stack) (go finally))
+           (otherwise (go main)))
+         (go prologue)
+       main
+         (dbg 'main)
+         (when (endp expr) (go end-parse))
+         (case (car expr)
+           (do (go do))
+           (initially (push 'prologue stack) (go initially))
+           (finally (push 'prologue stack) (go finally))
+           (otherwise
+            (when (member (car expr) loop-keywords) (error "bootstrap : loop : loop keyword ~w can't appear here." (car expr)))
+            (error "bootstrap : invalid syntax in loop form : ~w." expr)))
+         (go main)
+         
+       with
+         (dbg 'with)
+         (error "broken for now")
+       ;;   (advance expr)
+       ;; with-loop
+       ;;   (dbg 'with-loop)
+       ;;   (setq group-with nil)
+       ;;   (push 'with stack)
+       ;;   (setq affect-destr-keywords '(=)) ;; '(= in) pour le for.
+       ;;   (go destructuring)
+       ;;   (when (eq 'and (car expr))
+       ;;     (go with-loop))
+       ;;   (push variables all-variables)
+       ;;   (setq variables nil)
+       ;;   (go prologue)
+         
+       for
+         (dbg 'for)
+         (advance expr)
+         ;; (for vars in values)
+         ;; (for vars on values)
+         ;; (for vars = values [then expr])
+         ;; (for vars across vector) ;; non implémenté
+         ;; being : hash et package non supportés.
+         ;; (for var [from/downfrom/upfrom expr1] [to/downto/upto/below/above expr2] [by expr3])
+         (setq storage-sym (make-symbol "storage-for"))
+         (setq get-vars-and-types-end-keywords '(in on = across being from downfrom upfrom to downto upto below above by))
+         (push 'for-got-vars stack)
+         (go get-vars-and-types)
+       for-got-vars
+         (unless (member (car expr) '(in on = across being)) (go numeric-for))
+         (setq for-clause-type (car expr))
+       for-get-initial
+         (advance expr)
+         (when (endp expr) (error "bootstrap : loop : expected expression but found the end of the loop form."))
+         (setq for-initial-value (car expr))
+         (advance expr)
+       for-select-clause-handler
+         (case for-clause-type
+           (in (go in-for))
+           (on (go on-for))
+           (= (go affect-then-for))
+           (across (go vector-for))
+           (being (go hash-package-for)))
+         (error "bootstrap : loop : serious failure while parsing the for clause handler.")
+         
+       in-for
+         (setq for-getter-fun `(car ,storage-sym))
+         (go in-on-for)
+         
+       on-for
+         (setq for-getter-fun storage-sym)
+         (go in-on-for)
+         
+       in-on-for
+         (setq for-step-fun `(cdr ,storage-sym))
+         (setq for-end-predicate `(endp ,storage-sym))
+         (when (eq 'by (car expr))
+           (advance expr)
+           (when (endp expr) (error "bootstrap : loop : expected expression after BY but found the end of the loop form."))
+           (setq for-step-fun `(funcall ,(car expr) ,storage-sym))
+           (advance expr))
+         (go for-make-let)
+         
+       affect-then-for
+         (setq for-getter-fun storage-sym)
+         (setq for-step-fun storage-sym)
+         (setq for-end-predicate t)
+         (when (eq 'then (car expr))
+           (advance expr)
+           (when (endp expr) (error "bootstrap : loop : expected expression after BY but found the end of the loop form."))
+           (setq for-step-fun (car expr))
+           (advance expr))
+         (go for-make-let)
+         
+       numeric-for
+         (setq for-initial-value 0)
+         (setq for-getter-fun storage-sym)
+         (setq for-step-fun `(+ ,storage-sym 1))
+         (setq for-numeric-direction 0)
+         (setq for-end-predicate t)
+         (when (member (car expr) '(from upfrom downfrom))
+           (when (eq 'downfrom (car expr)) (setq for-numeric-direction -1))
+           (when (eq 'upfrom (car expr)) (setq for-numeric-direction 1))
+           (advance expr)
+           (when (endp expr) (error "bootstrap : loop : expected expression after from but found the end of the loop form."))
+           (setq for-initial-value (car expr))
+           (advance expr))
+         (when (member (car expr) '(to downto upto below above))
+           (setq for-numeric-limit (car expr))
+           (when (member (car expr) '(downto above))
+             (unless (= for-numeric-direction 0)
+               (error "bootstrap : loop : do you want to go up or down ? This is not a caroussel."))
+             (setq for-numeric-direction -1))
+           (when (member (car expr) '(upto below))
+             (unless (= for-numeric-direction 0)
+               (error "bootstrap : loop : do you want to go up or down ? This is not a caroussel."))
+             (setq for-numeric-direction 1))
+           (advance expr)
+           (when (endp expr) (error "bootstrap : loop : expected expression after ~w but found the end of the loop form." for-numeric-limit))
+           (case for-numeric-limit
+             (to (if (= for-numeric-direction -1)
+                     (setq for-end-predicate `(<  ,storage-sym ,(car expr)))
+                     (setq for-end-predicate `(>  ,storage-sym ,(car expr)))))
+             (downto (setq for-end-predicate `(<  ,storage-sym ,(car expr))))
+             (upto   (setq for-end-predicate `(>  ,storage-sym ,(car expr))))
+             (below  (setq for-end-predicate `(>= ,storage-sym ,(car expr))))
+             (above  (setq for-end-predicate `(<= ,storage-sym ,(car expr)))))
+           (advance expr))
+         (when (eq 'by (car expr))
+           (advance expr)
+           (when (endp expr) (error "bootstrap : loop : expected expression after by but found the end of the loop form."))
+           (setq for-step-fun `(+ ,storage-sym ,(* (if (= for-numeric-direction -1) -1 1)
+                                                   (car expr))))
+           (advance expr))
+         (go for-make-let)
+         
+       vector-for
+         (error "bootstrap : loop : syntax (loop for var across vector) not implemented yet !")
+         (go end-for)
+         
+       hash-package-for
+         (error "bootstrap : loop : looping across hashes and packages is not implemented yet !")
+         (go end-for)
+         
+       for-make-let
+         (push `(,storage-sym ,for-initial-value) variables)
+         (setq left-destr vars-names)
+         (push 'for-make-psetq stack)
+         (go destructuring-empty-let)
+         ;; (setq left-destr vars-names)
+         ;; (setq right-destr `(funcall ,for-getter-fun (setq ,storage-sym ,for-initial-value)))
+         ;; (push 'for-make-psetq stack)
+         ;; (go destructuring-let)
+       for-make-psetq
+         (unless (eq t for-end-predicate)
+           (push `(when ,for-end-predicate (go finally)) loopbody))
+         (setq left-destr vars-names)
+         (setq right-destr for-getter-fun)
+         (push 'for-push-psetq stack)
+         (go destructuring-psetq)
+       for-push-psetq
+         (push destr-psetq loopbody)
+         (push `(setq ,storage-sym ,for-step-fun) loopbody)
+         ;; (go end-for)
+       end-for
+         (push variables all-variables)
+         (setq variables nil)
+         (go prologue)
+                  
+       repeat
+         (dbg 'repeat)
+         (advance expr)
+         (let ((repeat-sym (make-symbol "repeat-counter")))
+           (push `((,repeat-sym ,(car expr))) all-variables)
+           (push `(setq ,repeat-sym (- ,repeat-sym 1)) loopbody)
+           (push `(when (< ,repeat-sym 0) (go finally)) loopbody))
+         (advance expr)
+         (go prologue)
+
+       do
+         (dbg 'do)
+         (advance expr)
+         (when (endp expr) (error "bootstrap : loop : expected an expression for DO, but encountered the end of the loop form."))
+         (when (member (car expr) loop-keywords) (error "bootstrap : loop : keyword ~w can't appear here, expected expression for DO." (car expr)))
+         (push (car expr) loopbody)
+         (advance expr)
+       do-loop
+         (dbg 'do-loop)
+         (when (endp expr) (go do-end))
+         (when (member (car expr) loop-keywords) (go do-end))
+         (push (car expr) loopbody)
+         (advance expr)
+         (go do-loop)
+       do-end
+         (go main)
+         
+         
+       get-vars-and-types
+         ;; params : get-vars-and-types-end-keywords
+         ;; returns : vars-names, real-vars-names
+         (dbg 'get-vars-and-types)
+         ;; a [= 1] [and ...]
+         ;; a type [= 1] [and ...]
+         ;; a of-type type [= 1] [and ...]
+         ;; (a b c) [= <list>] [and ...]
+         ;; (a b c) (t1 t2 t3) [= <list>] [and ...]
+         ;; (a b c) of-type (t1 t2 t3) [= <list>] [and ...]
+         ;; (a b c) type [= <list>] [and ...]
+         ;; (a b c) of-type type [= <list>] [and ...]
+         (setq vars-names (car expr))
+         (advance expr)
+         (when (eq 'of-type (car expr))
+           (advance expr)
+           (when (endp expr) (error "Expected type after OF-TYPE, but found the end of the loop form."))
+           (advance expr)
+           (go get-vars-and-types-end))
+         (unless (or (member (car expr) get-vars-and-types-end-keywords)
+                     (member (car expr) loop-keywords))
+           (advance expr))
+       get-vars-and-types-end
+         (go return)
+         
+       destructuring-let
+         ;; params : left-destr right-destr
+         ;; return : nothing
+         ;; mutate : variables
+         ;; modify : left-destr
+         (dbg 'destructuring-let)
+         
+         ;; Cas sans destructuring
+         (unless (consp left-destr)
+           (push `(,left-destr ,right-destr) variables)
+           (go destr-let-end))
+
+         (push `(,(car left-destr) (car (setq ,destr-whole-sym ,right-destr))) variables)
+         (advance left-destr)
+       destr-let-loop
+         (dbg 'destr-let-loop)
+         (when (endp left-destr)
+           (go destr-let-end))
+         (when (atom left-destr)
+           (push `(,left-destr ,destr-whole-sym) variables)
+           (go destr-let-end))
+         (push `(,(car left-destr) (car (setq ,destr-whole-sym (cdr ,destr-whole-sym)))) variables)
+         (advance left-destr)
+         (go destr-let-loop)
+       destr-let-end
+         (dbg 'destr-let-end)
+         (go return)
+         
+       destructuring-psetq
+         ;; params : left-destr right-destr
+         ;; return : nothing
+         ;; mutate : destr-psetq
+         ;; modify : left-destr
+         (dbg 'destructuring-psetq)
+         
+         ;; Cas sans destructuring
+         (unless (consp left-destr)
+           (setq destr-psetq `(setq ,left-destr ,right-destr))
+           (go destr-psetq-end))
+         
+         (setq destr-psetq `((car (setq ,destr-whole-sym ,right-destr)) ,(car left-destr) psetq)) ;; in reverse order
+         (advance left-destr)
+       destr-psetq-loop
+         (dbg 'destr-psetq-loop)
+         (when (endp left-destr)
+           (go destr-psetq-reverse-end))
+         (when (atom left-destr)
+           (push left-destr destr-psetq)
+           (push destr-whole-sym destr-psetq)
+           (go destr-psetq-reverse-end))
+         (push (car left-destr) destr-psetq)
+         (push `(car (setq ,destr-whole-sym (cdr ,destr-whole-sym))) destr-psetq)
+         (advance left-destr)
+         (go destr-psetq-loop)
+       destr-psetq-reverse-end
+         (dbg 'destr-psetq-reverse-end)
+         (setq destr-psetq (reverse destr-psetq))
+       destr-psetq-end
+         (dbg 'destr-psetq-end)
+         (go return)
+         
+       destructuring-empty-let
+         ;; params : left-destr
+         ;; return : nothing
+         ;; mutate : variables
+         ;; modify : left-destr
+         (dbg 'destructuring-empty-let)
+         
+         ;; Cas sans destructuring
+         (unless (consp left-destr)
+           (push `(,left-destr nil) variables)
+           (go destr-empty-let-end))
+
+         (push `(,(car left-destr) nil) variables)
+         (advance left-destr)
+       destr-empty-let-loop
+         (when (endp left-destr)
+           (go destr-empty-let-end))
+         (when (atom left-destr)
+           (push `(,left-destr nil) variables)
+           (go destr-empty-let-end))
+         (push `(,(car left-destr) nil) variables)
+         (advance left-destr)
+         (go destr-empty-let-loop)
+       destr-empty-let-end
+         (dbg 'destr-empty-let-end)
+         (go return)
+         
+       initially
+         (dbg 'initially)
+         (advance expr)
+         (when (endp expr) (error "bootstrap : loop : expected an expression for INITIALLY, but encountered the end of the loop form."))
+         (when (member (car expr) loop-keywords) (error "bootstrap : loop : keyword ~w can't appear here, expected expression for INITIALLY." (car expr)))
+         (push (car expr) initialization)
+         (advance expr)
+       initially-step
+         (dbg 'initially-step)
+         (when (endp expr) (go initially-end))
+         (when (member (car expr) loop-keywords) (go initially-end))
+         (push (car expr) initialization)
+         (advance expr)
+         (go initially-step)
+       initially-end
+         (dbg 'initially-end)
+         (go return)
+         
+       finally
+         (dbg 'finally)
+         (advance expr)
+         (when (eq 'return (car expr))
+           (push `(return-from ,name ,(cadr expr)) finally)
+           (advance expr)
+           (advance expr)
+           (go finally-end))
+         (when (member (car expr) '(do doing))
+           (advance expr))
+         (when (endp expr) (error "bootstrap : loop : expected an expression for FINALLY, but encountered the end of the loop form."))
+         (when (member (car expr) loop-keywords) (error "bootstrap : loop : keyword ~w can't appear here, expected expression for FINALLY." (car expr)))
+         (push (car expr) finally)
+         (advance expr)
+         ;; (go finally-step)
+       finally-step
+         (dbg 'finally-step)
+         (when (endp expr) (go finally-end))
+         (when (member (car expr) loop-keywords) (go finally-end))
+         (push (car expr) finally)
+         (advance expr)
+         (go finally-step)
+       finally-end
+         (dbg 'finally-end)
+         (go return)
+
+       return
+         (dbg 'return)
+         (when (endp stack) (error "bootstrap : loop : internal error : call stack is empty !"))
+         (let ((destination (car stack)))
+           (setq stack (cdr stack))
+           (case destination
+             (prologue (go prologue))
+             (with (go with))
+             (main (go main))
+             (for-got-vars (go for-got-vars))
+             (for-make-psetq (go for-make-psetq))
+             (for-push-psetq (go for-push-psetq))
+             (otherwise (error "bootstrap : loop : internal error : invalid return point on call stack : ~w" destination))))
+         
+       end-parse
+         (dbg 'end-parse)
+       make-body
+         (dbg 'make-body)
+         (setq result
+               `(tagbody
+                 initialization
+                   (progn ,@(reverse initialization))
+                 loopbody
+                   (progn ,@(reverse loopbody))
+                   (go loopbody)
+                 finally
+                   (progn ,@(reverse finally))
+                 implicit-return
+                   (return-from ,name ,acc)))
+       build-lets-loop
+         (dbg 'build-lets-loop)
+         (when (endp all-variables)
+           (go build-block-and-let))
+         (setq result `(let ,(reverse (car all-variables)) ,result))
+         (advance all-variables)
+         (go build-lets-loop)
+       build-block-and-let
+         (dbg 'build-block-and-lets)
+         (setq result
+               `(block ,name (let ,top-variables
+                               ,acc
+                               ,destr-whole-sym
+                               ,result)))
+       the-end
+         (dbg 'the-end)
+         ))
+    result))
+
+;; (eval (transform-loop '(for (i j) in '((1 1) (2 4) (3 9)) do (print i))))
+;; (eval (transform-loop '(for (i j) in '((1 1) (2 4) (3 9)) for k from 0 to 5 do (format t "~&~a ~a ~a" i j k) initially (print 'i) finally (print 'f) (print i))))
+
+#|
+(loop (print 5))
+=> boucle infinie
+
+expansion : let, block et tagbody
+
+(loop …)
+expands into :
+  <prologue>
+  <body>
+  <epilogue>
+
+expands into :
+(block nil …)
+pour qu'on puisse faire (return …) et (return-from nil …)
+(loop named X …)
+=> (block X …)
+
+do _*
+initially _*
+finally _*
+Les autres ont une taille "fixe".
+
+Attention, do peut être suivi de plusieurs tags et expressions. les tags sont comme ceux d'un tagbody, mais ne peuvent pas être des mots-clés de loop.
+
+toutes les variables sont initialisées au début, même si elles sont déclarées au milieu
+=> (block nil (let (vars) ...))
+
+tous les initially sont rassemblés au début dans un progn, et tous les finally à la fin, avant le return implicite
+=> (block nil
+     (let (vars)
+       (tagbody
+        initialisation
+          (progn initially1 i2 i3 ...)
+        loopbody
+          (...)
+          (go loopbody)
+        finally
+          (progn finally1 f2 f3 ...)
+        implicit-return
+          (<implicit-return>))))
+
+les "with …" créent des bindings chacun dans un let, leurs valeurs sont calculées dans l'ordre d'aparition des with.
+(loop with a = b and c = d with e = f ...)
+=> (let ((a b)
+         (c d))
+     (let ((e f))
+       ...))
+ou
+=> (let* ((#:|a| b)
+          (#:|c| d)
+          (a #:|a|)
+          (c #:|c|)
+          (#:|e| f)
+          (e #:|e|))
+     ...)
+
+"for …" ou "as …"
+=> initialisation : set des valeurs initiales
+=> loopbody : si on est à la fin de ce for, si oui, (go finally)
+=>            si non, on exécute l'itération de ce for, et on stocke la valeur.
+
+for x
+=> for x = 0 then (+ x 1)
+
+for x [up|down]from 5
+=> for x = 0 then (+- x 1)
+
+for x [up|down]from 5 [up|down]to/below/above 15 [by <step>]
+=> itération + test
+
+"repeat <n>"
+=> initialisation d'une variable interne
+=> test si on est à la fin de ce repeat, si oui, (go finally)
+=> sinon, on incrémente cette variable interne.
+
+"collect <expr> [into acc]"
+(setf last-acc (setf (cdr last-acc) <expr>))
+si acc est absent, on accumule sur l'accumulateur par défaut.
+
+nconc, sum, count, minimize, maximize : voir la doc
+
+|#
\ No newline at end of file
diff --git a/implementation/mini-meval.lisp b/implementation/mini-meval.lisp
index 3f90ab9..054e8bf 100644
--- a/implementation/mini-meval.lisp
+++ b/implementation/mini-meval.lisp
@@ -272,6 +272,7 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
       (if definition
           (cdr definition)
           (mini-meval-error expr etat-global etat-local "mini-meval : 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)))

From bea5dc47652ad684c422b0ebd3d9ade3a6d5e9c7 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <jahvascriptmaniac+github@free.fr>
Date: Sun, 21 Nov 2010 08:11:35 +0100
Subject: [PATCH 3/3] =?UTF-8?q?Correction=20de=20bugs=20sur=20l'initialisa?=
 =?UTF-8?q?tion=20parall=C3=A8le=20du=20for,=20remise=20en=20route=20du=20?=
 =?UTF-8?q?with,=20ajour=20du=20collect=20et=20du=20append.?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 implementation/loop.lisp | 273 ++++++++++++++++++++++++++-------------
 1 file changed, 185 insertions(+), 88 deletions(-)

diff --git a/implementation/loop.lisp b/implementation/loop.lisp
index 12b6036..d77673d 100644
--- a/implementation/loop.lisp
+++ b/implementation/loop.lisp
@@ -1,15 +1,18 @@
-(defmacro dbg (x) `(print ,x))
-(defmacro dbg (x) nil)
+;; TODO : remplacer les deux my-loop-finish par loop-finish à la fin.
 
 (defun transform-loop (expr)
   (let* ((name nil)
-         (acc (make-symbol "acc"))
+         (acc (make-symbol "ACC"))
+         (acc-tail (make-symbol "ACC-TAIL"))
+         (first-sym (make-symbol "FIRST"))
          (variables nil)
          (all-variables nil)
          (result nil)
          (initialization nil)
          (loopbody nil)
+         (loopbody-sym (make-symbol "LOOPBODY"))
          (finally nil)
+         (finally-sym (make-symbol "FINALLY"))
          (loop-keywords '(named
                           with for as repeat
                           initially finally
@@ -21,23 +24,28 @@
                           if when unless else end
                           and))
          (stack nil)
-                                        ;        (group-with nil)
+         (repeat-sym nil)
+         (destination nil)
+         (with-initial-values nil)
          (for-clause-type nil)
          (for-getter-fun nil)
          (for-initial-value nil)
          (for-step-fun nil)
          (for-end-predicate nil)
          (for-numeric-direction nil)
+         (for-numeric-start nil)
+         (for-numeric-end nil)
+         (for-numeric-step nil)
          (for-numeric-limit nil)
+         (for-initially-psetq nil)
+         (for-initially-affect nil)
          (storage-sym nil)
          (vars-names nil)
          (get-vars-and-types-end-keywords nil)
          (destr-psetq nil)
          (left-destr nil)
          (right-destr nil)
-         (destr-whole-sym (make-symbol "whole"))
-         (top-variables `((,acc nil)
-                          (,destr-whole-sym nil))))
+         (destr-whole-sym (make-symbol "WHOLE")))
     (macrolet ((advance (x) `(setq ,x (cdr ,x))))
       (tagbody
        start
@@ -65,6 +73,13 @@
          (when (endp expr) (go end-parse))
          (case (car expr)
            (do (go do))
+           (collect (go collect))
+           (append (go append))
+           (nconc (go nconc))
+           (sum (go sum))
+           (count (go count))
+           (minimize (go minimize))
+           (maximize (go maximize))
            (initially (push 'prologue stack) (go initially))
            (finally (push 'prologue stack) (go finally))
            (otherwise
@@ -72,32 +87,78 @@
             (error "bootstrap : invalid syntax in loop form : ~w." expr)))
          (go main)
          
+       collect
+         (advance expr)
+         (if (endp expr) (error "bootstrap : loop : expected expression after collect but found the end of the loop form."))
+         (if (member expr loop-keywords) (error "bootstrap : loop : loop keyword ~w can't appear here." (car expr)))
+         (push `(if ,acc
+                    (setq ,acc-tail (cdr (rplacd ,acc-tail (cons ,(car expr) nil))))
+                    (setq ,acc-tail (setq ,acc (cons ,(car expr) nil))))
+               loopbody)
+         (advance expr)
+         (go main)
+       append
+         (advance expr)
+         (if (endp expr) (error "bootstrap : loop : expected expression after append but found the end of the loop form."))
+         (if (member expr loop-keywords) (error "bootstrap : loop : loop keyword ~w can't appear here." (car expr)))
+         (push `(if ,acc
+                    (setq ,acc-tail (last (rplacd ,acc-tail (copy-list ,(car expr)))))
+                    (setq ,acc-tail (last (setq ,acc (copy-list ,(car expr))))))
+               loopbody)
+         (advance expr)
+         (go main)
+       nconc
+         (error "niy")
+         (go main)
+       sum
+         (error "niy")
+         (go main)
+       count
+         (error "niy")
+         (go main)
+       minimize
+         (error "niy")
+         (go main)
+       maximize
+         (error "niy")
+         (go main)
+         
        with
          (dbg 'with)
-         (error "broken for now")
-       ;;   (advance expr)
-       ;; with-loop
-       ;;   (dbg 'with-loop)
-       ;;   (setq group-with nil)
-       ;;   (push 'with stack)
-       ;;   (setq affect-destr-keywords '(=)) ;; '(= in) pour le for.
-       ;;   (go destructuring)
-       ;;   (when (eq 'and (car expr))
-       ;;     (go with-loop))
-       ;;   (push variables all-variables)
-       ;;   (setq variables nil)
-       ;;   (go prologue)
+         (advance expr)
+         (setq get-vars-and-types-end-keywords '(=))
+         (push 'with-got-vars stack)
+         (go get-vars-and-types)
+       with-got-vars
+         (setq with-initial-values nil)
+         (when (eq '= (car expr))
+           (advance expr)
+           (setq with-initial-values (car expr))
+           (advance expr))
+       with-make-let
+         (dbg 'with-make-let)
+         (setq left-destr vars-names)
+         (setq right-destr with-initial-values)
+         (push 'end-with stack)
+         (go destructuring-let)
+       end-with
+         (push variables all-variables)
+         (push nil all-variables)
+         (setq variables nil)
+         (when (eq 'and (car expr))
+           (go with))
+         (go prologue)
          
        for
          (dbg 'for)
-         (advance expr)
+         (advance expr) ;; gobble for / and
          ;; (for vars in values)
          ;; (for vars on values)
          ;; (for vars = values [then expr])
          ;; (for vars across vector) ;; non implémenté
          ;; being : hash et package non supportés.
          ;; (for var [from/downfrom/upfrom expr1] [to/downto/upto/below/above expr2] [by expr3])
-         (setq storage-sym (make-symbol "storage-for"))
+         (setq storage-sym (make-symbol "STORAGE-FOR"))
          (setq get-vars-and-types-end-keywords '(in on = across being from downfrom upfrom to downto upto below above by))
          (push 'for-got-vars stack)
          (go get-vars-and-types)
@@ -148,11 +209,11 @@
          (go for-make-let)
          
        numeric-for
-         (setq for-initial-value 0)
-         (setq for-getter-fun storage-sym)
-         (setq for-step-fun `(+ ,storage-sym 1))
-         (setq for-numeric-direction 0)
          (setq for-end-predicate t)
+         (setq for-numeric-start 0)
+         (setq for-numeric-step 1)
+         (setq for-numeric-direction 0)
+         (setq for-numeric-end 0)
          (when (member (car expr) '(from upfrom downfrom))
            (when (eq 'downfrom (car expr)) (setq for-numeric-direction -1))
            (when (eq 'upfrom (car expr)) (setq for-numeric-direction 1))
@@ -172,66 +233,87 @@
              (setq for-numeric-direction 1))
            (advance expr)
            (when (endp expr) (error "bootstrap : loop : expected expression after ~w but found the end of the loop form." for-numeric-limit))
+           (setq for-numeric-end (car expr))
            (case for-numeric-limit
              (to (if (= for-numeric-direction -1)
-                     (setq for-end-predicate `(<  ,storage-sym ,(car expr)))
-                     (setq for-end-predicate `(>  ,storage-sym ,(car expr)))))
-             (downto (setq for-end-predicate `(<  ,storage-sym ,(car expr))))
-             (upto   (setq for-end-predicate `(>  ,storage-sym ,(car expr))))
-             (below  (setq for-end-predicate `(>= ,storage-sym ,(car expr))))
-             (above  (setq for-end-predicate `(<= ,storage-sym ,(car expr)))))
+                     (setq for-end-predicate `(<  (car ,storage-sym) (third ,storage-sym)))
+                     (setq for-end-predicate `(>  (car ,storage-sym) (third ,storage-sym)))))
+             (downto (setq for-end-predicate `(<  (car ,storage-sym) (third ,storage-sym))))
+             (upto   (setq for-end-predicate `(>  (car ,storage-sym) (third ,storage-sym))))
+             (below  (setq for-end-predicate `(>= (car ,storage-sym) (third ,storage-sym))))
+             (above  (setq for-end-predicate `(<= (car ,storage-sym) (third ,storage-sym)))))
            (advance expr))
          (when (eq 'by (car expr))
            (advance expr)
            (when (endp expr) (error "bootstrap : loop : expected expression after by but found the end of the loop form."))
-           (setq for-step-fun `(+ ,storage-sym ,(* (if (= for-numeric-direction -1) -1 1)
-                                                   (car expr))))
+           (setq for-numeric-step (car expr))
            (advance expr))
+         (setq for-initial-value `(list ,for-numeric-start ,for-numeric-step ,for-numeric-end))
+         (if (= -1 for-numeric-direction)
+             (setq for-step-fun `(cons (- (car ,storage-sym) (second ,storage-sym)) (cdr ,storage-sym)))
+             (setq for-step-fun `(cons (+ (car ,storage-sym) (second ,storage-sym)) (cdr ,storage-sym))))
+         (setq for-getter-fun `(car ,storage-sym))
          (go for-make-let)
          
        vector-for
          (error "bootstrap : loop : syntax (loop for var across vector) not implemented yet !")
-         (go end-for)
+         (go for-end)
          
        hash-package-for
          (error "bootstrap : loop : looping across hashes and packages is not implemented yet !")
-         (go end-for)
+         (go for-end)
          
        for-make-let
-         (push `(,storage-sym ,for-initial-value) variables)
+         (push `(,storage-sym nil) variables)
          (setq left-destr vars-names)
-         (push 'for-make-psetq stack)
+         (push 'for-make-initially-psetq stack)
          (go destructuring-empty-let)
          ;; (setq left-destr vars-names)
          ;; (setq right-destr `(funcall ,for-getter-fun (setq ,storage-sym ,for-initial-value)))
          ;; (push 'for-make-psetq stack)
          ;; (go destructuring-let)
-       for-make-psetq
-         (unless (eq t for-end-predicate)
-           (push `(when ,for-end-predicate (go finally)) loopbody))
+       for-make-initially-psetq
+         (push storage-sym for-initially-psetq)
+         (push for-initial-value for-initially-psetq)
          (setq left-destr vars-names)
          (setq right-destr for-getter-fun)
-         (push 'for-push-psetq stack)
+         (psetq for-initially-affect destr-psetq destr-psetq for-initially-affect) ;; exchange
+         (push 'for-make-body-psetq stack)
          (go destructuring-psetq)
-       for-push-psetq
-         (push destr-psetq loopbody)
-         (push `(setq ,storage-sym ,for-step-fun) loopbody)
-         ;; (go end-for)
-       end-for
+       for-make-body-psetq
+         (psetq destr-psetq for-initially-affect for-initially-affect destr-psetq) ;; re-exchange
+         (unless (eq storage-sym for-step-fun)
+           (push `(unless ,first-sym (setq ,storage-sym ,for-step-fun)) loopbody))
+         (unless (eq t for-end-predicate)
+           (push `(when ,for-end-predicate (go ,finally-sym)) loopbody))
+         (setq left-destr vars-names)
+         (setq right-destr for-getter-fun)
+         (push 'for-end stack)
+         (go destructuring-psetq)
+       for-end
+         (when (eq 'and (car expr)) (go for))
          (push variables all-variables)
+         (push `((setq ,@(reverse for-initially-psetq))
+                 (setq ,@(reverse for-initially-affect)))
+               all-variables)
          (setq variables nil)
+         (setq for-initially-psetq nil)
+         (setq for-initially-affect nil)
+         (push `(setq ,@(reverse destr-psetq)) loopbody)
+         (setq destr-psetq nil)
          (go prologue)
-                  
+         
        repeat
          (dbg 'repeat)
          (advance expr)
-         (let ((repeat-sym (make-symbol "repeat-counter")))
-           (push `((,repeat-sym ,(car expr))) all-variables)
-           (push `(setq ,repeat-sym (- ,repeat-sym 1)) loopbody)
-           (push `(when (< ,repeat-sym 0) (go finally)) loopbody))
+         (setq repeat-sym (make-symbol "REPEAT-COUNTER"))
+         (push `((,repeat-sym ,(car expr))) all-variables)
+         (push nil all-variables)
+         (push `(setq ,repeat-sym (- ,repeat-sym 1)) loopbody)
+         (push `(when (< ,repeat-sym 0) (go ,finally-sym)) loopbody)
          (advance expr)
          (go prologue)
-
+         
        do
          (dbg 'do)
          (advance expr)
@@ -312,26 +394,25 @@
          
          ;; Cas sans destructuring
          (unless (consp left-destr)
-           (setq destr-psetq `(setq ,left-destr ,right-destr))
+           (push left-destr destr-psetq)
+           (push right-destr destr-psetq)
            (go destr-psetq-end))
          
-         (setq destr-psetq `((car (setq ,destr-whole-sym ,right-destr)) ,(car left-destr) psetq)) ;; in reverse order
+         (push (car left-destr) destr-psetq)
+         (push `(car (setq ,destr-whole-sym ,right-destr)) destr-psetq)
          (advance left-destr)
        destr-psetq-loop
          (dbg 'destr-psetq-loop)
          (when (endp left-destr)
-           (go destr-psetq-reverse-end))
+           (go destr-psetq-end))
          (when (atom left-destr)
            (push left-destr destr-psetq)
            (push destr-whole-sym destr-psetq)
-           (go destr-psetq-reverse-end))
+           (go destr-psetq-end))
          (push (car left-destr) destr-psetq)
          (push `(car (setq ,destr-whole-sym (cdr ,destr-whole-sym))) destr-psetq)
          (advance left-destr)
          (go destr-psetq-loop)
-       destr-psetq-reverse-end
-         (dbg 'destr-psetq-reverse-end)
-         (setq destr-psetq (reverse destr-psetq))
        destr-psetq-end
          (dbg 'destr-psetq-end)
          (go return)
@@ -406,57 +487,73 @@
        finally-end
          (dbg 'finally-end)
          (go return)
-
+         
        return
          (dbg 'return)
          (when (endp stack) (error "bootstrap : loop : internal error : call stack is empty !"))
-         (let ((destination (car stack)))
-           (setq stack (cdr stack))
-           (case destination
-             (prologue (go prologue))
-             (with (go with))
-             (main (go main))
-             (for-got-vars (go for-got-vars))
-             (for-make-psetq (go for-make-psetq))
-             (for-push-psetq (go for-push-psetq))
-             (otherwise (error "bootstrap : loop : internal error : invalid return point on call stack : ~w" destination))))
+         (setq destination (car stack))
+         (setq stack (cdr stack))
+         (case destination
+           (prologue (go prologue))
+           (main (go main))
+           (with-got-vars (go with-got-vars))
+           (end-with (go end-with))
+           (for-got-vars (go for-got-vars))
+           (for-make-initially-psetq (go for-make-initially-psetq))
+           (for-make-body-psetq (go for-make-body-psetq))
+           (for-end (go for-end))
+           (otherwise (error "bootstrap : loop : internal error : invalid return point on call stack : ~w" destination)))
          
        end-parse
          (dbg 'end-parse)
        make-body
          (dbg 'make-body)
+         (setq finally `(progn ,@(reverse (cons `(return-from ,name ,acc) finally))))
+         (setq initialization (reverse initialization))
+         (setq loopbody (reverse loopbody))
          (setq result
-               `(tagbody
-                 initialization
-                   (progn ,@(reverse initialization))
-                 loopbody
-                   (progn ,@(reverse loopbody))
-                   (go loopbody)
-                 finally
-                   (progn ,@(reverse finally))
-                 implicit-return
-                   (return-from ,name ,acc)))
+               `(macrolet ((my-loop-finish () '(go ,finally-sym)))
+                  (tagbody
+                     (progn ,@initialization)
+                   ,loopbody-sym
+                     (progn ,@loopbody)
+                     (setq ,first-sym nil)
+                     (go ,loopbody-sym)
+                   ,finally-sym
+                     ,finally)))
        build-lets-loop
          (dbg 'build-lets-loop)
          (when (endp all-variables)
            (go build-block-and-let))
-         (setq result `(let ,(reverse (car all-variables)) ,result))
+         (setq result `(let ,(reverse (cadr all-variables)) ,@(car all-variables) ,result))
+         (advance all-variables)
          (advance all-variables)
          (go build-lets-loop)
        build-block-and-let
          (dbg 'build-block-and-lets)
          (setq result
-               `(block ,name (let ,top-variables
-                               ,acc
-                               ,destr-whole-sym
-                               ,result)))
+               `(block ,name
+                  (let ((,acc nil)
+                        (,acc-tail nil)
+                        (,destr-whole-sym nil)
+                        (,first-sym t))
+                    ,acc
+                    ,acc-tail
+                    ,destr-whole-sym
+                    ,first-sym
+                    ;; If you call loop-finish during variable declarations, and you use variables that haven't been initialized,
+                    ;; then it will fail / use variables from the surrounding environment. But it's you freakin' problem if you do
+                    ;; such bizarre things.
+                    (macrolet ((my-loop-finish () ',finally))
+                      ,result))))
        the-end
-         (dbg 'the-end)
-         ))
+         ;; music
+       rideau))
     result))
 
 ;; (eval (transform-loop '(for (i j) in '((1 1) (2 4) (3 9)) do (print i))))
 ;; (eval (transform-loop '(for (i j) in '((1 1) (2 4) (3 9)) for k from 0 to 5 do (format t "~&~a ~a ~a" i j k) initially (print 'i) finally (print 'f) (print i))))
+;; (eval (transform-loop '(for i = 42 and j in (list 1 i 3) for k = i then (cons i j) collect (list i j k))))
 
 #|
 (loop (print 5))