From 0ab6bc0d559b376f69c3f12f6a7ce5500960f967 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Mon, 10 Jan 2011 03:08:46 +0100 Subject: [PATCH] squash-lisp-2 > 66.7% --- lisp/equiv-tests.lisp | 8 ++ lisp/main.lisp | 2 + lisp/mini-meval.lisp | 1 + lisp/squash-lisp-2.lisp | 172 ++++++++++++++++++++++++++++++++++------ 4 files changed, 160 insertions(+), 23 deletions(-) diff --git a/lisp/equiv-tests.lisp b/lisp/equiv-tests.lisp index 340bada..ba6dc4c 100644 --- a/lisp/equiv-tests.lisp +++ b/lisp/equiv-tests.lisp @@ -45,6 +45,14 @@ '((lambda (x) (+ x 3)) 4) 7) +(deftest-equiv (lambda sans-params) + '((lambda () 42)) + 42) + +(deftest-equiv (lambda sans-body) + '((lambda ())) + nil) + (deftest-equiv (let) '(let ((x 3) (y 4)) (+ x y)) 7) diff --git a/lisp/main.lisp b/lisp/main.lisp index c9a7b40..6c826e8 100644 --- a/lisp/main.lisp +++ b/lisp/main.lisp @@ -3,6 +3,8 @@ ;; Chargement de tous les fichiers, dans l'ordre du tri topologique ;; pour tous les re-charger, sans les charger deux fois. +;; TODO : mettre de ** autour des variables en defvar. + (load "util") (load "test-unitaire") (load "vm") diff --git a/lisp/mini-meval.lisp b/lisp/mini-meval.lisp index fa70550..342aee4 100644 --- a/lisp/mini-meval.lisp +++ b/lisp/mini-meval.lisp @@ -131,6 +131,7 @@ ;; avec trois fonctions spéciales pour le get / set / tester le type), ;; sera utilisé pour les closures et les variables spéciales. +;; TODO : bug : pourquoi les keyword-to-symbol ??? on devrait garder le keyword tel quel. (defun slice-up-lambda-list (lambda-list) (match-automaton lambda-list fixed (fixed accept) diff --git a/lisp/squash-lisp-2.lisp b/lisp/squash-lisp-2.lisp index 01dde44..01e58aa 100644 --- a/lisp/squash-lisp-2.lisp +++ b/lisp/squash-lisp-2.lisp @@ -1,8 +1,10 @@ +(require 'mini-meval "mini-meval") ;; slice-up-lambda-list (require 'match "match") (require 'util "match") ;; derived-symbol, assoc-or, assoc-or-push (defun squash-lisp-2 (expr &optional env-var env-fun (globals (cons nil nil))) - "Transforme les let, let*, flet, labels, lambda en simple-let et simple-lambda, + "Transforme les let, let*, flet, labels, lambda en let simplifié + (uniquement les noms de variables, pas de valeur) 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 @@ -29,39 +31,86 @@ expr) ((jump :dest $$) expr) + ((super-let :name ($$*) :stuff _*) + (setq name (mapcar (lambda (x) (cons x (derived-symbol x))) name)) + (let ((new-env-var env-var) + (new-env-fun env-fun)) + `(let ,(mapcar #'cdr name) + (progn + ,@(loop + for (type . clause) in stuff + when (eq type 'set) + collect `(setq ,(cdr (assoc (car clause) name)) (squash-lisp-2 (cadr clause) new-env-var new-env-fun globals)) + when (eq type 'use-var) + do (cons (assoc (car clause) name) env-var) + when (eq type 'use-fun) + do (cons (assoc (car clause) name) env-fun) + when (eq type 'progn) + collect `(progn ,(mapcar (lambda (x) (squash-lisp-2 x new-env-var new-env-fun globals)) clause))))))) + ((let ((:name $$ :value _)*) :body _) + (squash-lisp-2 + `(super-let ,name + ,@(mapcar (lambda (n v) `(set ,n ,v)) name value) + ,@(mapcar (lambda (n) `(use-var ,n)) name) + (progn ,body)) + env-var env-fun globals)) + (((? (eq x 'let*)) ((:name $$ :value _)*) :body _) + (squash-lisp-2 + `(super-let ,name + ,@(loop + for n in name + for v in value + collect `(set ,n ,v) + collect `(use-var ,n)) + (progn ,body)) + env-var env-fun globals)) + ((simple-flet ((:name $$ :value _)*) :body _) + (squash-lisp-2 + `(super-let ,name + ,@(mapcar (lambda (n v) `(set ,n ,v)) name value) + ,@(mapcar (lambda (n) `(use-fun ,n)) name) + (progn ,body)) + env-var env-fun globals)) + ((simple-labels ((:name $$ :value _)*) :body _) + (squash-lisp-2 + `(super-let ,name + ,@(mapcar (lambda (n) `(use-fun ,n)) name) + ,@(mapcar (lambda (n v) `(set ,n ,v)) name value) + (progn ,body)) + env-var env-fun globals)) ((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))))) + `(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))))) (((? (eq x 'let*)) ((:name $$ :value _)*) :body _) (setq name (mapcar (lambda (x) (cons x (derived-symbol x))) name)) (let ((new-env-var env-var)) ;; old = ((new-env-var (append name env-var))) - `(simple-let ,(mapcar #'cdr name) - (progn ,@(mapcar (lambda (n v) - (push (cons n v) new-env-var) ;; Ajouté - `(setq ,(cdr n) ,(squash-lisp-2 v new-env-var env-fun globals))) ;; env-var -> new-env-var !!! - name value) - ,(squash-lisp-2 body new-env-var env-fun globals))))) + `(let ,(mapcar #'cdr name) + (progn ,@(mapcar (lambda (n v) + (push (cons n v) new-env-var) ;; Ajouté + `(setq ,(cdr n) ,(squash-lisp-2 v new-env-var env-fun globals))) ;; env-var -> new-env-var !!! + name value) + ,(squash-lisp-2 body new-env-var env-fun globals))))) ((simple-flet ((:name $$ :value _)*) :body _) (setq name (mapcar (lambda (x) (cons x (derived-symbol x))) name)) (let ((new-env-fun (append name env-fun))) ;; new-env-var -> new-env-fun + env-var -> env-fun - `(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 env-var new-env-fun globals))))) ;; env-var -> env-fun + `(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 env-var new-env-fun globals))))) ;; env-var -> env-fun ((simple-labels ((:name $$ :value _)*) :body _) (setq name (mapcar (lambda (x) (cons x (derived-symbol x))) name)) (let ((new-env-fun (append name env-fun))) ;; new-env-var -> new-env-fun + env-var -> env-fun - `(simple-let ,(mapcar #'cdr name) - (progn ,@(mapcar (lambda (n v) - `(setq ,(cdr n) ,(squash-lisp-2 v env-var new-env-fun globals))) ;; env-fun -> new-env-fun - name value) - ,(squash-lisp-2 body env-var new-env-fun globals))))) ;; env-var -> env-fun + `(let ,(mapcar #'cdr name) + (progn ,@(mapcar (lambda (n v) + `(setq ,(cdr n) ,(squash-lisp-2 v env-var new-env-fun globals))) ;; env-fun -> new-env-fun + name value) + ,(squash-lisp-2 body env-var new-env-fun globals))))) ;; env-var -> env-fun ;; TODO ((lambda :params @ :body _) ;; TODO : simplifier la lambda-list @@ -85,6 +134,83 @@ (_ (error "squash-lisp-2: Assertion failed ! This should not be here : ~a" expr)))) -(squash-lisp-2 '(let ((x (quote 123))) (let* ((x (quote 1)) (y (get-var x))) (funcall (function +) (get-var x) (get-var y) (quote 1))))) +;; TODO : test uniraire +;; (squash-lisp-2 '(let ((x (quote 123))) (let* ((x (quote 1)) (y (get-var x))) (funcall (function +) (get-var x) (get-var y) (quote 1))))) + + +(defvar *ll* '(a b &optional u &rest c &key ((:foo bar)) :quux (:baz 'glop) &aux (x 1) (y (+ x 2)))) + +;; TODO : faire cette transformation dans squash-lisp-1 +;; TODO : faire la transformation des let/let*/flet/labels en super-let dans squash-lisp-1 +(let* ((sliced-lambda-list (sliced-lambda-list *ll*)) + (whole-sym (make-symbol "LAMBDA-PARAMETERS")) + (seen-keys-sym (make-symbol "SEEN-KEYS")) + (fixed (cdr (assoc 'fixed lambda-list))) + (optional (cdr (assoc 'optional lambda-list))) + (rest (cdr (assoc 'rest lambda-list))) + (key (cdr (assoc 'key lambda-list))) + (other (cdr (assoc 'other lambda-list))) + (aux (cdr (assoc 'aux lambda-list)))) + `(lambda (&rest ,whole-sym) + 'lambda-name ;; nil si fonction anonyme + (super-let (,@fixed + ,@(mapcar #'car optional) + ,@(remove nil (mapcar #'third optional)) + ,@rest + ,@(mapcar #'car key) + ,@(remove nil (mapcar #'fourth key)) + ,@(mapcar #'car aux) + ,@(if (and key (not other)) `(,seen-keys-sym) nil)) + ,@(loop + for param in fixed + collect `(set ,param (car ,whole-sym)) + collect `(use ,param) + collect `(progn (setq ,whole-sym (cdr ,whole-sym)))) + ,@(loop + for (param default predicate) in optional + collect `(set ,param (if ,whole-sym (car whole-sym) ,default)) + collect `(progn (setq ,whole-sym (cdr ,whole-sym))) ;; TODO : devrait être dans le même if que ci-dessus, mais c'est assez difficile à loger… + when predicate + collect `(setq ,predicate (not (endp (,whole-sym)))) + and collect `(use ,predicate) + collect `(use ,param)) + ,@(if rest + `((set ,(car rest) ,whole-sym) + (use ,(car rest))) + nil) + ,@(if key + (progn (if (evenp (length ,whole-sym)) nil (error "Odd number of arguments, but function has &key."))) + nil) + ,@(loop + for (keyword param default predicate) in keyword + ;; TODO : &key not implemented yet + do (list keyword param default predicate)) + ,@(loop + for (param val) in aux + collect `(set ,param ,val) + collect `(use ,param)) + (progn ,body)))) + + +nil à la fin + +(slice-up-lambda-list '(a b &optional (u 3 v) &rest c &key ((:foo bar)) :quux (:baz 'glop) &allow-other-keys &aux (x 1) (y (+ x 2)))) + +(let (a b u v c foo quux baz x y) + (set a (car ,whole-sym)) + (use a) + (progn (setq ,whole-sym (cdr ,whole-sym))) + (set b (car ,whole-sym)) + (use b) + (progn (setq ,whole-sym (cdr ,whole-sym))) + (set u (if ,whole-sym (car whole-sym)) ...) + (set v (if ,whole-sym t nil)) + (use u) + (use v) + (progn (setq ,whole-sym (cdr ,whole-sym)))) + +((FIXED A B) (OPTIONAL (U NIL NIL)) (REST C) (REST2) + (KEY (FOO BAR NIL NIL) (QUUX QUUX NIL NIL) (BAZ BAZ 'GLOP NIL)) (OTHER) + (AUX (X 1) (Y (+ X 2))) (REJECT)) (provide 'squash-lisp-2) \ No newline at end of file