squash-lisp-2 : 30%

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))))
 

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 env-var env-fun globals);&optional (globals (cons nil nil)))
-
-(defun squash-lisp-2 (expr)
   "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)
+    `(unwind-protect ,(squash-lisp-2 body env-var env-fun globals)
-         (squash-lisp-1-check cleanup)))
+       ,(squash-lisp-2 cleanup env-var env-fun globals)))
    ((unwind-catch :object _ :body _ :catch-code _)
-    (and (squash-lisp-1-check object)
+    `(unwind-catch ,(squash-lisp-2 object env-var env-fun globals)
-         (squash-lisp-1-check body)
+                   ,(squash-lisp-2 body env-var env-fun globals)
-         (squash-lisp-1-check catch-code)))
+                   ,(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)
+    `(half-unwind ,(squash-lisp-2 object env-var env-fun globals)
-         (squash-lisp-1-check post-unwind-code)))
+                  ,(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)
+    expr)
-   (((? (member x '(let let* flet labels))) ((:name $$ :value _)*) :body _)
+   ((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)
+    expr)
-   ((get-var $$)
+   ;; TODO
-    t)
+   ((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)

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 : emballer le résultat de squash-lisp dans un (macrolet ...) pour les "special-operator" qu'on rajoute.
-;; TODO : 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")

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)