commit 709ef979c67725f02e158aa242141e0df76954ca
parent 57eb25bfd7e199e007edad68725d8b131143b2e7
Author: Georges Dupéron <jahvascriptmaniac+github@free.fr>
Date: Wed, 12 Jan 2011 00:06:42 +0100
Début de squash-lisp-3.
Diffstat:
5 files changed, 108 insertions(+), 4 deletions(-)
diff --git a/lisp/main.lisp b/lisp/main.lisp
@@ -12,7 +12,6 @@
(load "mini-meval")
(load "squash-lisp")
(load "squash-lisp-1")
-(load "squash-lisp-2")
(load "equiv-tests")
(provide 'main)
diff --git a/lisp/notes/soutenance.markdown b/lisp/notes/soutenance.markdown
@@ -61,7 +61,7 @@ squash-lisp
(lambda (x y) (+ x y))
→ (simple-lambda (simple-let (x y) (setq x (get-param 0)) (setq y (get-param 1)) (+ x y)))
* Passe 3
- * On 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*.
+ * 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 sort toutes les lambdas (fonctions anonymes), on les nomme avec un symbole unique, et on les met au top-level.
diff --git a/lisp/squash-lisp-1.lisp b/lisp/squash-lisp-1.lisp
@@ -286,6 +286,7 @@
(aux (cdr (assoc 'aux sliced-lambda-list))))
(push (cons whole-sym whole-sym) env-var)
`(lambda (&rest ,whole-sym)
+ ,(transform whole-sym) ;; pour pas qu'il soit unused si aucun paramètre.
,(transform
`(super-let (,@fixed
,@(mapcar #'car optional)
@@ -477,7 +478,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 $$) :body _)
+ ((lambda (&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
@@ -0,0 +1,103 @@
+(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*.
+
+ On fusionne tous les `let` d'une `lambda` en les remontant dans un `let` unique à la racine de la `lamdba`.
+
+ 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)))
+ (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)))
+ (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))
+ ;; 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))))
+ ((if :condition _ :si-vrai _ :si-faux _)
+ (and (squash-lisp-3 condition)
+ (squash-lisp-3 si-vrai)
+ (squash-lisp-3 si-faux)))
+ ((unwind-protect :body _ :cleanup _)
+ (and (squash-lisp-3 body)
+ (squash-lisp-3 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)))
+ ((unwind :object _)
+ (squash-lisp-3 object))
+ ((unwind-for-tagbody :object _ :post-unwind-code _)
+ (and (squash-lisp-3 object)
+ (squash-lisp-3 post-unwind-code)))
+ ((jump-label :name $$)
+ t)
+ ((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)))
+ ((funcall :fun _ :params _*)
+ (every #'squash-lisp-3 (cons fun params)))
+ ((quote _)
+ t)
+ ((get-var :var $$)
+ ;; chercher si var est dans local-env ou bien dans global
+ ;; si oui -> get-var
+ ;; sinon, -> get-captured-var
+ t)
+ ((setq :name $$ :value _)
+ ;; comme ci-dessus
+ (squash-lisp-3 value))
+ ((fdefinition (quote $$))
+ t)
+ ((symbol-value (quote $$))
+ t)
+ ((set (quote $$) :value _)
+ (squash-lisp-3 value)))))
+
+(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))))
+ ''nil)
+
+(deftest (squash-lisp-3 progn)
+ (squash-lisp-3 '(progn))
+ ''nil)
+
+(deftest (squash-lisp-3 progn)
+ (squash-lisp-3 '(progn (symbol-value 'a)))
+ '(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))
+
+;(run-tests squash-lisp-3)
+\ No newline at end of file
diff --git a/lisp/test-unitaire.lisp b/lisp/test-unitaire.lisp
@@ -152,7 +152,7 @@
(defmacro erase-tests (&optional module)
(unless (listp module) (setq module (list module)))
- `(test-remove-module ',module))
+ `(progn (test-remove-module ',module) t))
(erase-tests test-unitaire)
(deftest (test-unitaire copy-all)
