From 57eb25bfd7e199e007edad68725d8b131143b2e7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Tue, 11 Jan 2011 23:24:32 +0100 Subject: [PATCH] =?UTF-8?q?squash-lisp-1=20&=202=20:=20fusionn=C3=A9s,=20p?= =?UTF-8?q?assent=20les=20tests=20d'=C3=A9quivalence=20\o/?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- lisp/equiv-tests.lisp | 2 +- lisp/notes/symbols.txt | 12 +++++ lisp/squash-lisp-1.lisp | 106 ++++++++++++++++++++++++---------------- lisp/util.lisp | 6 +-- 4 files changed, 81 insertions(+), 45 deletions(-) create mode 100644 lisp/notes/symbols.txt diff --git a/lisp/equiv-tests.lisp b/lisp/equiv-tests.lisp index 69f8bc6..92bc018 100644 --- a/lisp/equiv-tests.lisp +++ b/lisp/equiv-tests.lisp @@ -62,7 +62,7 @@ '(3 4 7 5)) (deftest-equiv (let*) - '(let ((x 3) (y 4) (z 5)) (let* ((z (+ x y)) (w z)) (list x y z w))) + '(let ((x 3) (y 4) (z 5)) z (let* ((z (+ x y)) (w z)) (list x y z w))) '(3 4 7 7)) ;; TODO diff --git a/lisp/notes/symbols.txt b/lisp/notes/symbols.txt new file mode 100644 index 0000000..8406e7c --- /dev/null +++ b/lisp/notes/symbols.txt @@ -0,0 +1,12 @@ +Variables : + +boundp/makeunbound +symbol-value/set + +Functions +fboundp/? +symbol-function (ou mieux : fdefinition)/(setf fdefinition) + +Macros (?) +macro-function teste +macro-function/(setf macro-function) diff --git a/lisp/squash-lisp-1.lisp b/lisp/squash-lisp-1.lisp index 1cba371..1d18d45 100644 --- a/lisp/squash-lisp-1.lisp +++ b/lisp/squash-lisp-1.lisp @@ -49,8 +49,8 @@ rend tous les noms locaux de fonction (flet/labels) et de variables (let/let*/lambda) uniques, mais pas les globaux. - `super-let' est lui-même transformé dans la foulée en simple-let qui ne fait - que déclarer les noms de variables, mais n'affecte pas de valeur + `super-let' est lui-même transformé dans la foulée en let simplifié qui ne + fait que déclarer les noms de variables, mais n'affecte pas de valeur lui-même (les affectations sont faites avec des setq) `at-toplevel' permet de déterminer si une expression est considérée comme @@ -220,20 +220,21 @@ ,@(loop for (type . clause) in expr when (eq type 'set) - collect `(setq ,(cdr (assoc (car clause) name)) (transform (cadr clause))) - when (eq type 'use-var) + collect `(setq ,(cdr (assoc (car clause) name)) ,(transform (cadr clause))) + else when (eq type 'use-var) do (push (assoc (car clause) name) env-var) - when (eq type 'use-fun) + else when (eq type 'use-fun) do (push (assoc (car clause) name) env-fun) - when (eq type 'if) - do `(if ,(transform (car clause)) - (progn ,(mapcar #'transform-super-let (cadr clause))) - (progn ,(mapcar #'transform-super-let (caddr clause)))) - when (eq type 'progn) - collect `(progn ,(mapcar (lambda (x) (transform x)) clause)))))) + else when (eq type 'if) + collect `(if ,(transform (car clause)) + ,(transform-super-let (cadr clause)) + ,(transform-super-let (caddr clause))) + else when (eq type 'progn) + collect `(progn ,@(mapcar (lambda (x) (transform x)) clause)) + else do (error "transform-super-let : internal error : ~a not expected here" type))))) ;; Note : ce ne sera pas re-transformé (sinon boucle infinie). `(let ,(mapcar #'cdr name) - ,(transform-super-let expr)))) + ,(transform-super-let stuff)))) ((let ((:name $$ :value _)*) :body _*) (transform @@ -252,14 +253,14 @@ collect `(use-var ,n)) (progn ,@body)))) - ((simple-flet ((:name $$ :params @ :fbody _*)*) :body _*) + ((flet ((:name $$ :params @ :fbody _*)*) :body _*) (transform `(super-let ,name ,@(mapcar (lambda (n params fbody) `(set ,n (lambda ,params (progn ,@fbody)))) name params fbody) ,@(mapcar (lambda (n) `(use-fun ,n)) name) (progn ,@body)))) - ((simple-labels ((:name $$ :params @ :fbody _*)*) :body _*) + ((labels ((:name $$ :params @ :fbody _*)*) :body _*) (transform `(super-let ,name ,@(mapcar (lambda (n) `(use-fun ,n)) name) @@ -283,6 +284,7 @@ (key (cdr (assoc 'key sliced-lambda-list))) (other (cdr (assoc 'other sliced-lambda-list))) (aux (cdr (assoc 'aux sliced-lambda-list)))) + (push (cons whole-sym whole-sym) env-var) `(lambda (&rest ,whole-sym) ,(transform `(super-let (,@fixed @@ -296,21 +298,21 @@ ,@(loop for param in fixed collect `(set ,param (car ,whole-sym)) - collect `(use ,param) + collect `(use-var ,param) collect `(progn (setq ,whole-sym (cdr ,whole-sym)))) ,@(loop for (param default predicate) in optional collect `(if ,whole-sym - ((set ,param (car whole-sym)) + ((set ,param (car ,whole-sym)) (progn (setq ,whole-sym (cdr ,whole-sym))) - (use ,param) - ,@(if predicate `((set ,predicate t) (use predicate)) nil)) + (use-var ,param) + ,@(if predicate `((set ,predicate t) (use-var ,predicate)) nil)) ((set ,param ,default) - (use ,param) - ,@(if predicate `((set ,predicate nil) (use predicate)) nil)))) + (use-var ,param) + ,@(if predicate `((set ,predicate nil) (use-var ,predicate)) nil)))) ,@(if rest `((set ,(car rest) ,whole-sym) - (use ,(car rest))) + (use-var ,(car rest))) nil) ,@(if key `(progn (if (evenp (length ,whole-sym)) nil (error "Odd number of arguments, but function has &key."))) @@ -318,7 +320,7 @@ ,@(if key (loop for (keyword param default predicate) in key - ;; TODO : quand on a trouvé, pouvoir faire set et use (support de simple-tagbody & jump-label super-let) + ;; TODO : quand on a trouvé, pouvoir faire set et use-var (support de simple-tagbody & jump-label super-let) collect (let ((search-key (make-symbol "SEARCH-KEY"))) `((progn (simple-tagbody (jump-label ,search-key) @@ -334,25 +336,29 @@ nil))) (if ,temp-key-sym ((set ,param (car ,temp-key-sym)) - (use ,param) - ,@(if predicate `((set predicate t) (use predicate)) nil)) + (use-var ,param) + ,@(if predicate `((set predicate t) (use-var ,predicate)) nil)) ((set ,param ,default) - (use ,param) - ,@(if predicate `((set predicate nil) (use predicate)) nil)))))) + (use-var ,param) + ,@(if predicate `((set predicate nil) (use-var ,predicate)) nil)))))) nil) ;; TODO : not implemented yet : vérifier s'il y a des key non autorisées. ,@(loop for (param val) in aux collect `(set ,param ,val) - collect `(use ,param)) + collect `(use-var ,param)) (progn ,@body)))))) ((function :fun (lambda . _)) (transform fun)) ((function :fun $$) - `(get-var ,(assoc-or fun env-fun (assoc-or-push fun (derived-symbol (string fun)) (cdr globals))))) - + (if-assoc fun env-fun + `(get-var ,(cdr assoc)) + (progn + (pushnew fun (cdr globals)) + `(fdefinition ',fun)))) + ((funcall :fun _ :params _*) `(funcall ,(transform fun) ,@(mapcar (lambda (x) (transform x)) params))) @@ -360,23 +366,39 @@ ;; => TODO : définir la fonction funcall : (funcall #'funcall #'cons 1 2) ;; => TODO : définir la fonction apply : (funcall #'apply #'cons '(1 2)) + ((? or numberp stringp) + `(quote ,expr)) + ((setq :name $$ :value _) - `(setq ,(assoc-or name env-var (assoc-or-push name (derived-symbol name) (car globals))) - ,(transform value))) + (if-assoc name env-var + `(setq ,(cdr assoc) ,(transform value)) + (progn + (pushnew name (car globals)) + `(set ',name ,(transform value))))) ((quote _) expr) - ((? or numberp stringp) - `(quote ,expr)) - + ((fdefinition (quote $$)) + expr) + + ((symbol-value (quote $$)) + expr) + + ((set (quote $$)) + expr) + ;; TODO : nil et t devraient être des defconst ;; Doit être avant les symboles (nil ''nil) ($$ - (print `(get-var ,(assoc-or expr env-var (assoc-or-push expr (derived-symbol expr) (car globals)))))) + (if-assoc expr env-var + `(get-var ,(cdr assoc)) + (progn + (pushnew expr (car globals)) + `(symbol-value ',expr)))) ;; Appels de fonction ;; Doivent être après tout le monde. @@ -393,7 +415,7 @@ (transform `(funcall (function ,name) ,@params))) (_ - (error "squash-lisp-1: Not implemented yet : ~a" expr))))) + (error "squash-lisp-1: Not implemented yet : ~w" expr))))) (defun squash-lisp-1-wrap (expr) `(macrolet ((unwind-catch (object body catch-code) @@ -419,8 +441,6 @@ ;; name) (jump (dest) `(go ,dest)) - (simple-let (spec body) - `(let spec body)) (get-var (x) x)) ,expr)) @@ -459,8 +479,6 @@ Attention : il y a quelques invariants qui ne sont pas présents dans cette vér (squash-lisp-1-check body)) ((lambda (&rest $$) :body _) (squash-lisp-1-check body)) - ((function :fun $$) - t) ((funcall :fun _ :params _*) (every #'squash-lisp-1-check (cons fun params))) ((quote _) @@ -469,8 +487,14 @@ Attention : il y a quelques invariants qui ne sont pas présents dans cette vér t) ((setq :name $$ :value _) (squash-lisp-1-check value)) + ((fdefinition (quote $$)) + t) + ((symbol-value (quote $$)) + t) + ((set (quote $$) :value _) + (squash-lisp-1-check value)) (_ - (warn "squash-lisp-1-check: Assertion failed ! This should not be here : ~a" expr) + (warn "squash-lisp-1-check: Assertion failed ! This should not be here : ~w" expr) nil))) (require 'test-unitaire "test-unitaire") diff --git a/lisp/util.lisp b/lisp/util.lisp index 75518b6..42f43ed 100644 --- a/lisp/util.lisp +++ b/lisp/util.lisp @@ -221,11 +221,11 @@ `(with-symbol (,var (derived-symbol ,symbol)) ,@body)) -(defmacro assoc-or (key alist &rest body) +(defmacro if-assoc (key alist body-if body-else) `(let ((assoc (assoc ,key ,alist))) (if assoc - (cdr assoc) - (progn ,@body)))) + ,body-if + ,body-else))) (defmacro assoc-or-push (key datum alist-place) "Fait un assoc de key dans alist-place, et si l'association échoue,