commit 413ee0fc852167d67af0215c44cb4db46815ec50
parent bd0debb1b4b2b3cb3b0052a30aafef9aca7194cc
Author: Georges Dupéron <jahvascriptmaniac+github@free.fr>
Date: Thu, 6 Jan 2011 23:35:56 +0100
squash-lisp-2 : 30%
Diffstat:
4 files changed, 83 insertions(+), 23 deletions(-)
diff --git a/lisp/squash-lisp-1.lisp b/lisp/squash-lisp-1.lisp
@@ -296,7 +296,7 @@ Attention : il y a quelques invariants qui ne sont pas présents dans cette vér
t)
((jump :dest _) ;; TODO : être plus précis que "_"
t)
- (((? (member x '(let let* flet labels))) ((:name $$ :value _)*) :body _)
+ (((? (member x '(let let* simple-flet simple-labels))) ((:name $$ :value _)*) :body _)
(every #'squash-lisp-1-check (cons body value)))
((lambda :params ($$*) :body _)
(squash-lisp-1-check body))
@@ -308,6 +308,8 @@ Attention : il y a quelques invariants qui ne sont pas présents dans cette vér
t)
((get-var $$)
t)
+ ((setq :name $$ :value _)
+ (squash-lisp-1-check value))
(_
(error "squash-lisp-1-check: Assertion failed ! This should not be here : ~a" expr))))
diff --git a/lisp/squash-lisp-2.lisp b/lisp/squash-lisp-2.lisp
@@ -1,45 +1,69 @@
(require 'match "match")
+(require 'util "match") ;; derived-symbol, assoc-or, assoc-or-push
-;; TODO : util : mapnth
-
-(defun squash-lisp-2 (expr)
+(defun squash-lisp-2 (expr env-var env-fun globals);&optional (globals (cons nil nil)))
"Transforme les let, let*, flet, labels, lambda en simple-let 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 _*)
- `(progn ,@(mapcar squash-lisp-2 body)))
+ `(progn ,@(mapcar (lambda (x) (squash-lisp-2 x env-var env-fun globals)) body)))
((unwind-protect :body _ :cleanup _)
- (and (squash-lisp-1-check body)
- (squash-lisp-1-check cleanup)))
+ `(unwind-protect ,(squash-lisp-2 body env-var env-fun globals)
+ ,(squash-lisp-2 cleanup env-var env-fun globals)))
((unwind-catch :object _ :body _ :catch-code _)
- (and (squash-lisp-1-check object)
- (squash-lisp-1-check body)
- (squash-lisp-1-check catch-code)))
+ `(unwind-catch ,(squash-lisp-2 object env-var env-fun globals)
+ ,(squash-lisp-2 body env-var env-fun globals)
+ ,(squash-lisp-2 catch-code env-var env-fun globals)))
((unwind :object _)
- (squash-lisp-1-check object))
+ `(unwind ,(squash-lisp-2 object env-var env-fun globals)))
((half-unwind :object _ :post-unwind-code _)
- (and (squash-lisp-1-check object)
- (squash-lisp-1-check post-unwind-code)))
+ `(half-unwind ,(squash-lisp-2 object env-var env-fun globals)
+ ,(squash-lisp-2 post-unwind-code env-var env-fun globals)))
+ ;; TODO : symbole ?
((jump-label :name _) ;; TODO : être plus précis que "_"
- t)
+ expr)
+ ;; TODO : symbole ?
((jump :dest _) ;; TODO : être plus précis que "_"
- t)
- (((? (member x '(let let* flet labels))) ((:name $$ :value _)*) :body _)
+ expr)
+ ((let ((:name $$ :value _)*) :body _)
+ (setq name (mapcar (lambda (x) (cons x (derived-symbol x))) name))
+ (let ((new-env-var (append name env-var)))
+ `(simple-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)))))
+ (((? (member x '(let* flet labels))) ((:name $$ :value _)*) :body _)
(every #'squash-lisp-1-check (cons body value)))
+ ;; TODO
((lambda :params ($$*) :body _)
+ ;; TODO : simplifier la lambda-list
(squash-lisp-1-check body))
+ ;; TODO
((function :fun $$)
- t)
+ (assoc-or fun env-fun
+ (assoc-or-push fun (derived-symbol (string fun)) (cdr globals))))
((funcall :fun _ :params _*)
- (every #'squash-lisp-1-check (cons fun params)))
+ `(funcall ,(squash-lisp-2 fun env-var env-fun globals)
+ ,@(mapcar (lambda (x) (squash-lisp-2 x env-var env-fun globals)) params)))
((quote _)
- t)
- ((get-var $$)
- t)
+ expr)
+ ;; TODO
+ ((get-var :var $$)
+ (assoc-or var env-var
+ (assoc-or-push var (derived-symbol var) (car globals))))
+ ;; TODO
+ ((setq :name $$ :value _)
+ `(setq ,(assoc-or name env-var
+ (assoc-or-push name (derived-symbol name) (car globals)))
+ ,(squash-lisp-2 value env-var env-fun globals)))
(_
(error "squash-lisp-2: Assertion failed ! This should not be here : ~a" expr))))
+;; (let ((a (cons nil nil)))
+;; (squash-lisp-2 '(let ((x (quote 1)) (y (quote 2))) (funcall (function +) (get-var x) (get-var y) (quote 1))) nil nil a)
+;; a)
(provide 'squash-lisp-2)
\ No newline at end of file
diff --git a/lisp/squash-lisp.lisp b/lisp/squash-lisp.lisp
@@ -3,8 +3,10 @@
;; À 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 ...)
-;; TODO : pour les "special-operator" qu'on rajoute.
+;; 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")
diff --git a/lisp/util.lisp b/lisp/util.lisp
@@ -209,4 +209,36 @@
(consp (cdr l))
(not (cddr l))))
+(defun derived-symbol (symbol)
+ (make-symbol (format nil "~a-~a" (string symbol) (random 1000))))
+
+(defmacro with-symbol (var name &rest body)
+ `(let ((,var (make-symbol ,name)))
+ ,@body))
+
+(defmacro with-derived-symbol (var symbol &rest body)
+ ;; TODO : utiliser un vrai compteur.
+ `(with-symbol (,var (derived-symbol ,symbol))
+ ,@body))
+
+(defmacro assoc-or (key alist &rest body)
+ `(let ((assoc (assoc ,key ,alist)))
+ (if assoc
+ (cdr assoc)
+ (progn ,@body))))
+
+(defmacro assoc-or-push (key datum alist-place)
+ "Fait un assoc de key dans alist-place, et si l'association échoue,
+ push (cons key datum) sur alist-place.
+ Renvoie (cdr (assoc key alist-place)) ou bien datum."
+ ;; TODO : n'évaluer alist-place et key qu'une seule fois.
+ (let ((assoc-sym (make-symbol "assoc"))
+ (datum-sym (make-symbol "datum")))
+ `(let ((,assoc-sym (assoc ,key ,alist-place)))
+ (if ,assoc-sym
+ (cdr ,assoc-sym)
+ (let ((,datum-sym ,datum))
+ (push (cons ,key ,datum-sym) ,alist-place)
+ ,datum-sym)))))
+
(provide 'util)
\ No newline at end of file
