diff --git a/lisp/squash-lisp-1.lisp b/lisp/squash-lisp-1.lisp index a913e9d..5c37eef 100644 --- 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 index b303ced..ea80169 100644 --- 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 index b02c0dd..094c6f0 100644 --- 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 index 87a7000..75518b6 100644 --- 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