commit 9a64e1266009ea775c961a67e2d2b25fb4d066c3
parent 0ab6bc0d559b376f69c3f12f6a7ce5500960f967
Author: Georges Dupéron <jahvascriptmaniac+github@free.fr>
Date: Tue, 11 Jan 2011 14:18:57 +0100
Fuuuuusion !
Diffstat:
5 files changed, 434 insertions(+), 353 deletions(-)
diff --git a/lisp/equiv-tests.lisp b/lisp/equiv-tests.lisp
@@ -1,4 +1,4 @@
-(require 'squash-lisp "squash-lisp")
+;(require 'squash-lisp "squash-lisp")
(require 'mini-meval "mini-meval")
(require 'test-unitaire "test-unitaire")
diff --git a/lisp/notes/soutenance.markdown b/lisp/notes/soutenance.markdown
@@ -7,7 +7,7 @@ Tests unitaires
mini-meval
==========
-`mini-meval` est un méta-évaluateur «naïf» mais qui supporte pratiquement tout LISP sauf CLOS (Common Lisp Object System).
+`mini-meval` est un méta-évaluateur «naïf» mais qui supporte pratiquement tout LISP sauf CLOS (Common Lisp Object System), les packages, les hash, ….
Syntaxe supportée par mini-meval et le simplificateur
=====================================================
@@ -31,6 +31,10 @@ lisp2li
squash-lisp
===========
+* Pour transformer les let/let*/flet/labels/lambda en let simplifiés : décorrelation de l'étape de déclaration d'une variable, son
+ affectation, et son utilisation.
+* La transformation est hygénique (les special-form intermédiaires qu'on ajoute sont des symboles uniques. On aurait pu utiliser le système
+ de package, mais on aurait dû supporter les packages à ce moment-là).
* En 3 passes :
* Passe 1 :
* macro-expansion (on utilise `mini-meval`) et `eval-when`.
@@ -100,3 +104,4 @@ Ramasse-miettes
Implémentation de fonctions LISP
================================
* On a notre propre fonction `read` et notre propre fonction `format` pour être autonomes.
+* Implémentation de loop avec toutes les extensions sauf celles de typage (analysées mais ignorées silencieusement)
diff --git a/lisp/squash-lisp-1.lisp b/lisp/squash-lisp-1.lisp
@@ -1,5 +1,6 @@
-(require 'mini-meval "mini-meval")
+(require 'mini-meval "mini-meval") ;; slice-up-lambda-list, macro-expansion, eval-when
(require 'match "match")
+(require 'util "match") ;; derived-symbol, assoc-or, assoc-or-push
;; À la fin du fichier se trouvent des notes sur la compilation d'unwind & co.
@@ -7,6 +8,12 @@
;; TODO !!! donc adapter les calculs pour unwind,
;; TODO !!! sinon on n'aura pas la compatibilité x86
+
+
+;; TODO : transformer les if (cond?) en simple-tagbody
+;; TODO : mini-meval + squash-lisp-1 : les defmacro doivent définir une macro-fonction, pour qu'on puisse utiliser macroexpand dans le
+;; source passé en paramètre. donc (defmacro foo (params) body*) -> (setf (fdefinition 'foo) (lambda (params) (block foo body*)))
+
(defun simple-splice-up-tagbody (body)
"Découpe le body d'un tagbody en une liste associative ordonnée toute simple :
(tagbody a b (foo bar) c (baz) (quux) d) => '((a) (b (foo bar)) (c (baz) (quux)) (d))"
@@ -27,249 +34,366 @@
end)
(reverse all-res)))
-(defun squash-lisp-1 (expr &optional (at-toplevel t) (etat (list nil nil nil)))
- "Supprime les macros, eval-when, tagbody/go, throw/catch, block/return-from,
- transforme les appels de fonction en funcall, les constantes en quote
- et simplifie pas mal d'autres choses."
- (cond-match
- expr
- ;; - Si on rencontre une macro définie dans l'environnement de compiler-meval,
- ;; 1) On demande à compiler-meval d'expanser la macro sur un niveau.
- ;; 2) On re-lance la transformation (eval-when / defmacro / appel de macro / ...) sur le résultat s'il y a a eu expansion.
- ((:name $$ :params _*)
- (let ((definition (assoc-etat name 'macro etat)))
- (if definition
- (squash-lisp-1 (apply (cdr definition) params) at-toplevel etat)
- (else))))
-
- ;; - Si on rencontre EVAL-WHEN,
- ;; - Au top-level,
- ;; - Pour chaque form du body,
- ;; - Si la situation contient :compile-toplevel, le form est évalué dans compiler-meval.
- ;; - Si la situation contient :load-toplevel, le form est compilé (après évaluation dans compiler-meval s'il y a lieu).
- ;; - Lorsqu'un eval-when au top-level contient des eval-when directement sous lui, ils sont traités comme s'ils étaient directement au top-level.
- ;; - Ailleurs
- ;; - Si la situation contient :load-toplevel, le form est compilé
- ((eval-when :situations ($*) :body _*)
- (when (and at-toplevel (member :compile-toplevel situations))
- (mini-meval `(progn ,@body) etat))
- (if (member :load-toplevel situations)
- (squash-lisp-1 body at-toplevel etat)
- (squash-lisp-1 nil at-toplevel etat))) ;; on renvoie nil
-
- ;; - Si on rencontre un defmacro (au toplevel ou ailleurs).
- ;; - On demande à compiler-meval de l'exécuter.
- ((defmacro :name $ :lambda-list @ :body _*)
- (mini-meval expr etat)
- (squash-lisp-1 nil at-toplevel etat)) ;; on renvoie nil
-
- ;; - Si on rencontre un macrolet
- ;; - On fait une copie de l'état de compiler-meval
- ;; - On lui demande d'exécuter les définitions
- ;; - On évalue le body avec ce nouvel état
- ;; - On continue avec l'ancien état
- ((macrolet :definitions ((:name $ :lambda-list @ :mbody _*)*) :body _*)
- (let ((get-etat (make-symbol "GET-ETAT")))
- (squash-lisp-1
- `(progn ,@body)
- at-toplevel
- (mini-meval `(macrolet ,definitions ,get-etat) (push-local etat 'trapdoor 'squash-trapdoor get-etat)))))
-
- ;; - Si on gère le symbol-macrolet
- ;; - Le fonctionnement est le même que pour le macrolet
- ;; - Lorsqu'on rencontre un symbole, on regarde s'il a une définition de type symbol-macrolet
- ((symbol-macrolet . _)
- (error "squash-lisp-1 : Symbol-macrolet n'est pas implémenté."))
-
- ((progn :body _*)
- (cons 'progn (mapcar (lambda (form) (squash-lisp-1 form at-toplevel etat)) body)))
-
- ((if :condition _ :si-vrai _ :si-faux _?)
- `(if ,(squash-lisp-1 condition nil etat)
- ,(squash-lisp-1 si-vrai nil etat)
- ,(squash-lisp-1 (car si-faux) nil etat)))
-
- ;; Lorsqu'on rentre dans un block, on met sur la pile un marqueur spécial avec un pointeur vers un objet créé à l'exécution.
- ((block :block-name $$ :body _*)
- (let ((retval-sym (make-symbol "RETVAL"))
- (block-id-sym (make-symbol "BLOCK-ID")))
- (squash-lisp-1
- `(let ((,retval-sym nil)
- ;; Il y a un peu de redondance, car block-id-sym
- ;; stocké dans le let et dans le unwind-catch
- (,block-id-sym (cons nil nil)))
- (unwind-catch ,block-id-sym
- (progn ,@body)
- ,retval-sym))
- nil
- (push-local etat block-name 'squash-block-catch (cons block-id-sym retval-sym)))))
-
- ;; Les return-from <nom> qui sont accessibles lexicalement sont remplacés par un (unwind <l'objet>)
- ;; Unwind remonte la pile jusqu'à trouver le marqueur spécial, tout en exécutant les unwind-protect éventuels.
- ;; Si unwind ne trouve pas le marqueur et arrive en haut de la pile, il signale une erreur et termine le programme.
- ;; Sinon, l'exécution reprend après le block.
- ((return-from :block-name $$ :value _)
- (let ((association (assoc-etat block-name 'squash-block-catch etat)))
- (unless association (error "Squash-Lisp-1 : Can't return from block ~w, it is inexistant or not lexically apparent." block-name))
- (squash-lisp-1 `(progn (setq ,(cddr association) ,value)
- (unwind ,(cadr association)))
- nil etat)))
-
+(defun squash-lisp-1 (expr &optional (at-toplevel t) (etat (list nil nil nil)) env-var env-fun (globals (cons nil nil)))
+ "Transformation 1 :
- ;; Le traitement de tagbody/go est similaire pour sortir d'un tag, puis on jmp directement sur le tag de destination (vu qu'il est au même niveau).
- ((tagbody :body _*)
- (let ((spliced-body (simple-splice-up-tagbody body))
- (res nil)
- (unwind-catch-marker-sym (make-symbol "UNWIND-CATCH-MARKER-SYM"))
- (new-etat etat)
- (unique-label-sym nil)
- (tagbody-id-sym (make-symbol "TAGBODY-ID")))
- (dolist (zone spliced-body)
- (setq unique-label-sym (make-symbol (format nil "~a" (car zone))))
- (setq new-etat (push-local new-etat (car zone) 'squash-tagbody-catch (cons unwind-catch-marker-sym unique-label-sym)))
- (setf (car zone) unique-label-sym))
- (squash-lisp-1
- `(let ((,tagbody-id-sym (cons nil nil)))
- (tagbody-unwind-catch ,tagbody-id-sym
- (progn
- ,@(progn (dolist (zone spliced-body)
- (push `(jump-label ,(car zone)) res)
- (push `(progn ,@(cdr zone)) res))
- ;; (cdr (reverse …)) pour zapper le tout premier (jump-label …)
- (cdr (reverse res))))
- nil)
- nil)
- nil
- new-etat)))
-
- ((go :target (? or symbolp numberp))
- (let ((association (assoc-etat target 'squash-tagbody-catch etat)))
- (unless association (error "Squash-Lisp-1 : Can't go to label ~w, it is inexistant or not lexically apparent." target))
- (squash-lisp-1 `(progn (unwind-for-tagbody ,(cadr association)
- (jump ,(cddr association))))
- nil etat)))
-
- ;; Le traitement de catch/throw est similaire, sauf que le pointeur est simplement un pointeur vers l'objet utilisé pour le catch / throw.
- ((catch :tag _ :body _*)
- (squash-lisp-1
- `(unwind-catch ,tag (progn ,@body) singleton-catch-retval)
- nil etat))
-
- ((throw :tag _ :result _)
- (squash-lisp-1
- `(progn (setq singleton-catch-retval ,result)
- (unwind ,tag))
- nil etat))
-
- ;; Simplification du unwind-protect
- ((unwind-protect :body _ :a-cleanup _ :other-cleanups _+)
- `(unwind-protect ,(squash-lisp-1 body nil etat)
- ,(squash-lisp-1 `(progn ,a-cleanup ,@other-cleanups) nil etat)))
-
- ((unwind-protect :body _ :a-cleanup _)
- `(unwind-protect ,(squash-lisp-1 body nil etat)
- ,(squash-lisp-1 a-cleanup nil etat)))
-
- ((:type (? (member x '(unwind-catch tagbody-unwind-catch))) :object _ :body _ :catch-code _)
- `(,type ,(squash-lisp-1 object nil etat)
- ,(squash-lisp-1 body nil etat)
- ,(squash-lisp-1 catch-code nil etat)))
-
- ((unwind :object _)
- `(unwind ,(squash-lisp-1 object nil etat)))
-
- ((unwind-for-tagbody :object _ :post-unwind-code _)
- `(unwind-for-tagbody ,(squash-lisp-1 object nil etat) ,(squash-lisp-1 post-unwind-code nil etat)))
-
- ((jump-label :name $$)
- expr)
-
- ((jump :dest $$)
- expr)
+ Supprime les macros, eval-when, tagbody/go, throw/catch, block/return-from,
+ transforme les appels de fonction en funcall, les constantes en quote
+ et simplifie pas mal d'autres choses.
- ;; Transformation des (let[*] (var1 var2 var3) …) en (let[*] ((var1 nil) (var2 nil) (var3 nil)) …)
- ((:type (? or (eq x 'let) (eq x 'let*)) :bindings (? and consp (find-if #'symbolp x)) :body . _)
- (squash-lisp-1 `(,type ,(mapcar (lambda (b) (if (consp b) b `(b nil))) bindings) ,@body) nil etat))
-
- ((let ((:name $$ :value _)*) :body _*)
- `(let ,(mapcar (lambda (n v) `(,n ,(squash-lisp-1 v nil etat))) name value)
- ,(squash-lisp-1 `(progn ,@body) nil etat)))
-
- (((? (eq x 'let*)) ((:name $$ :value _)*) :body _*)
- `(let* ,(mapcar (lambda (n v) `(,n ,(squash-lisp-1 v nil etat))) name value)
- ,(squash-lisp-1 `(progn ,@body) nil etat)))
+ Transformation 2 :
- ((flet ((:name $$ :params @ :fbody _*)*) :body _*)
- `(simple-flet ,(mapcar (lambda (name params fbody)
- (list name (squash-lisp-1 `(lambda ,params (progn ,@fbody)) nil etat)))
- name params fbody)
- ,(squash-lisp-1 `(progn ,@body) nil etat)))
-
- ((labels ((:name $$ :params @ :fbody _*)*) :body _*)
- `(simple-labels ,(mapcar (lambda (name params fbody)
- (list name (squash-lisp-1 `(lambda ,params (progn ,@fbody)) nil etat)))
- name params fbody)
- ,(squash-lisp-1 `(progn ,@body) nil etat)))
-
- ;; TODO : defun
- ;; TODO : defvar
- ;; => TODO : global-setq
- ;; => TODO : global-setfun
- ;; => TODO : proclaim
-
- ;; TODO: simplifier la lambda-list.
- ((lambda :params _ :body _)
- `(lambda ,params ,(squash-lisp-1 body nil etat)))
-
- ((lambda :params _ :body _*)
- (squash-lisp-1 `(lambda ,params (progn ,@body)) nil etat))
-
- ((function :fun (lambda . _))
- (squash-lisp-1 fun nil etat))
-
- ((function :fun $$)
- expr)
+ Transforme les let, let*, flet, labels, lambda en super-let et simple-lambda,
+ détecte les variables et fonctions globales et stocke leurs noms dans le
+ paramètre globals, qui est une paire (noms-variables . noms-fonctions), et
+ rend tous les noms locaux de fonction (flet/labels) et de
+ variables (let/let*/lambda) uniques, mais pas les globaux.
- ((funcall :fun _ :params _*)
- `(funcall ,@(mapcar (lambda (x) (squash-lisp-1 x nil etat)) (cons fun params))))
-
- ;; TODO : apply
- ;; => TODO : définir la fonction funcall : (funcall #'funcall #'cons 1 2)
- ;; => TODO : définir la fonction apply : (funcall #'apply #'cons '(1 2))
-
- ((setq :name $$ :value _)
- `(setq ,name ,(squash-lisp-1 value nil etat)))
-
- ((quote _)
- expr)
-
- ((? or numberp stringp)
- `(quote ,expr))
-
- ;; TODO : nil et t devraient être des defconst
- ;; Doit être avant les symboles
- (nil
- ''nil)
-
- ($$
- `(get-var ,expr))
-
- ;; Appels de fonction
- ;; Doivent être après tout le monde.
- ((:fun $$ :params _*)
- (squash-lisp-1 `(funcall (function ,fun) ,@params) nil etat))
-
- ((:lambda (lambda . _) :params _*)
- (squash-lisp-1 `(funcall ,lambda ,@params) nil etat))
-
- (((function :lambda (lambda . _)) :params . _)
- (squash-lisp-1 `(funcall ,lambda ,@params) nil etat))
-
- (((function :name $$) :params _*)
- (squash-lisp-1 `(funcall (function ,name) ,@params) nil etat))
-
- (_
- (error "squash-lisp-1: Not implemented yet : ~a" expr))))
+ `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
+ lui-même (les affectations sont faites avec des setq)
+
+ `at-toplevel' permet de déterminer si une expression est considérée comme
+ étant au top-level (pour les defmacro, eval-when, etc).
+
+ `etat' est l'état du compilateur (macro-expansion, eval-when avec
+ compile-time) env-var et env-fun et globals sont les environnements du code
+ compilé, utilisés pour rendre uniques tous les symboles."
+ (macrolet ((transform (expr &optional at-toplevel (etat 'etat)) `(squash-lisp-1 ,expr ,at-toplevel ,etat env-var env-fun globals)))
+ (cond-match
+ expr
+ ;; - Si on rencontre une macro définie dans l'environnement de compiler-meval,
+ ;; 1) On demande à compiler-meval d'expanser la macro sur un niveau.
+ ;; 2) On re-lance la transformation (eval-when / defmacro / appel de macro / ...) sur le résultat s'il y a a eu expansion.
+ ((:name $$ :params _*)
+ (let ((definition (assoc-etat name 'macro etat)))
+ (if definition
+ (transform (apply (cdr definition) params) at-toplevel)
+ (else))))
+
+ ;; - Si on rencontre EVAL-WHEN,
+ ;; - Au top-level,
+ ;; - Pour chaque form du body,
+ ;; - Si la situation contient :compile-toplevel, le form est évalué dans compiler-meval.
+ ;; - Si la situation contient :load-toplevel, le form est compilé (après évaluation dans compiler-meval s'il y a lieu).
+ ;; - Lorsqu'un eval-when au top-level contient des eval-when directement sous lui, ils sont traités comme s'ils étaient directement au top-level.
+ ;; - Ailleurs
+ ;; - Si la situation contient :load-toplevel, le form est compilé
+ ((eval-when :situations ($*) :body _*)
+ (when (and at-toplevel (member :compile-toplevel situations))
+ (mini-meval `(progn ,@body) etat))
+ (if (member :load-toplevel situations)
+ (transform body at-toplevel)
+ (transform 'nil))) ;; on renvoie nil
+
+ ;; - Si on rencontre un defmacro (au toplevel ou ailleurs).
+ ;; - On demande à compiler-meval de l'exécuter.
+ ((defmacro :name $ :lambda-list @ :body _*)
+ (mini-meval expr etat)
+ (transform `',name)) ;; on renvoie le nom
+
+ ;; - Si on rencontre un macrolet
+ ;; - On fait une copie de l'état de compiler-meval
+ ;; - On lui demande d'exécuter les définitions
+ ;; - On évalue le body avec ce nouvel état
+ ;; - On continue avec l'ancien état
+ ((macrolet :definitions ((:name $ :lambda-list @ :mbody _*)*) :body _*)
+ (let ((get-etat (make-symbol "GET-ETAT")))
+ (transform
+ `(progn ,@body)
+ at-toplevel
+ (mini-meval `(macrolet ,definitions ,get-etat) (push-local etat 'trapdoor 'squash-trapdoor get-etat)))))
+
+ ;; - Si on gère le symbol-macrolet
+ ;; - Le fonctionnement est le même que pour le macrolet
+ ;; - Lorsqu'on rencontre un symbole, on regarde s'il a une définition de type symbol-macrolet
+ ((symbol-macrolet . _)
+ (error "squash-lisp-1 : Symbol-macrolet n'est pas implémenté."))
+
+ ((progn :body _*)
+ (cons 'progn (mapcar (lambda (form) (transform form at-toplevel)) body)))
+
+ ((if :condition _ :si-vrai _ :si-faux _?)
+ `(if ,(transform condition)
+ ,(transform si-vrai)
+ ,(transform (car si-faux))))
+
+ ;; Lorsqu'on rentre dans un block, on met sur la pile un marqueur spécial avec un pointeur vers un objet créé à l'exécution.
+ ((block :block-name $$ :body _*)
+ (let ((retval-sym (make-symbol "RETVAL"))
+ (block-id-sym (make-symbol "BLOCK-ID")))
+ (transform
+ `(let ((,retval-sym nil)
+ ;; Il y a un peu de redondance, car block-id-sym
+ ;; stocké dans le let et dans le unwind-catch
+ (,block-id-sym (cons nil nil)))
+ (unwind-catch ,block-id-sym
+ (progn ,@body)
+ ,retval-sym))
+ nil
+ (push-local etat block-name 'squash-block-catch (cons block-id-sym retval-sym)))))
+
+ ;; Les return-from <nom> qui sont accessibles lexicalement sont remplacés par un (unwind <l'objet>)
+ ;; Unwind remonte la pile jusqu'à trouver le marqueur spécial, tout en exécutant les unwind-protect éventuels.
+ ;; Si unwind ne trouve pas le marqueur et arrive en haut de la pile, il signale une erreur et termine le programme.
+ ;; Sinon, l'exécution reprend après le block.
+ ((return-from :block-name $$ :value _)
+ (let ((association (assoc-etat block-name 'squash-block-catch etat)))
+ (unless association (error "Squash-Lisp-1 : Can't return from block ~w, it is inexistant or not lexically apparent." block-name))
+ (transform `(progn (setq ,(cddr association) ,value)
+ (unwind ,(cadr association))))))
+
+ ;; Le traitement de tagbody/go est similaire pour sortir d'un tag, puis on jmp directement sur le tag de destination (vu qu'il est au même niveau).
+ ((tagbody :body _*)
+ (let ((spliced-body (simple-splice-up-tagbody body))
+ (res nil)
+ (unwind-catch-marker-sym (make-symbol "UNWIND-CATCH-MARKER-SYM"))
+ (new-etat etat)
+ (unique-label-sym nil)
+ (tagbody-id-sym (make-symbol "TAGBODY-ID")))
+ (dolist (zone spliced-body)
+ (setq unique-label-sym (make-symbol (format nil "~a" (car zone))))
+ (setq new-etat (push-local new-etat (car zone) 'squash-tagbody-catch (cons unwind-catch-marker-sym unique-label-sym)))
+ (setf (car zone) unique-label-sym))
+ (transform
+ `(let ((,tagbody-id-sym (cons nil nil)))
+ (tagbody-unwind-catch ,tagbody-id-sym
+ (progn
+ ,@(progn (dolist (zone spliced-body)
+ (push `(jump-label ,(car zone)) res)
+ (push `(progn ,@(cdr zone)) res))
+ ;; (cdr (reverse …)) pour zapper le tout premier (jump-label …)
+ (cdr (reverse res))))
+ nil)
+ nil)
+ nil
+ new-etat)))
+
+ ((go :target (? or symbolp numberp))
+ (let ((association (assoc-etat target 'squash-tagbody-catch etat)))
+ (unless association (error "Squash-Lisp-1 : Can't go to label ~w, it is inexistant or not lexically apparent." target))
+ (transform `(progn (unwind-for-tagbody ,(cadr association)
+ (jump ,(cddr association)))))))
+
+ ;; Le traitement de catch/throw est similaire, sauf que le pointeur est simplement un pointeur vers l'objet utilisé pour le catch / throw.
+ ((catch :tag _ :body _*)
+ (transform `(unwind-catch ,tag (progn ,@body) singleton-catch-retval)))
+
+ ((throw :tag _ :result _)
+ (transform `(progn (setq singleton-catch-retval ,result)
+ (unwind ,tag))))
+
+ ;; Simplification du unwind-protect
+ ((unwind-protect :body _ :a-cleanup _ :other-cleanups _+)
+ `(unwind-protect ,(transform body)
+ ,(transform `(progn ,a-cleanup ,@other-cleanups))))
+
+ ((unwind-protect :body _ :a-cleanup _)
+ `(unwind-protect ,(transform body)
+ ,(transform a-cleanup)))
+
+ ((:type (? (member x '(unwind-catch tagbody-unwind-catch))) :object _ :body _ :catch-code _)
+ `(,type ,(transform object)
+ ,(transform body)
+ ,(transform catch-code)))
+
+ ((unwind :object _)
+ `(unwind ,(transform object)))
+
+ ((unwind-for-tagbody :object _ :post-unwind-code _)
+ `(unwind-for-tagbody ,(transform object) ,(transform post-unwind-code)))
+
+ ((jump-label :name $$)
+ expr)
+
+ ((jump :dest $$)
+ expr)
+
+ ;; Transformation des (let[*] (var1 var2 var3) …) en (let[*] ((var1 nil) (var2 nil) (var3 nil)) …)
+ ((:type (? or (eq x 'let) (eq x 'let*)) :bindings (? and consp (find-if #'symbolp x)) :body . _)
+ (transform `(,type ,(mapcar (lambda (b) (if (consp b) b `(b nil))) bindings) ,@body)))
+
+ ((super-let :name ($$*) :stuff _*)
+ (setq name (mapcar (lambda (x) (cons x (derived-symbol x))) name))
+ (labels ((transform-super-let (expr)
+ `(progn
+ ,@(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)
+ do (push (assoc (car clause) name) env-var)
+ 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))))))
+ ;; Note : ce <let> ne sera pas re-transformé (sinon boucle infinie).
+ `(let ,(mapcar #'cdr name)
+ ,(transform-super-let expr))))
+
+ ((let ((:name $$ :value _)*) :body _*)
+ (transform
+ `(super-let ,name
+ ,@(mapcar (lambda (n v) `(set ,n ,v)) name value)
+ ,@(mapcar (lambda (n) `(use-var ,n)) name)
+ (progn ,@body))))
+
+ (((? (eq x 'let*)) ((:name $$ :value _)*) :body _*)
+ (transform
+ `(super-let ,name
+ ,@(loop
+ for n in name
+ for v in value
+ collect `(set ,n ,v)
+ collect `(use-var ,n))
+ (progn ,@body))))
+
+ ((simple-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 _*)
+ (transform
+ `(super-let ,name
+ ,@(mapcar (lambda (n) `(use-fun ,n)) name)
+ ,@(mapcar (lambda (n params fbody) `(set ,n (lambda ,params (progn ,@fbody)))) name params fbody)
+ (progn ,@body))))
+
+ ;; TODO : defun
+ ;; TODO : defvar
+ ;; => TODO : global-setq
+ ;; => TODO : global-setfun
+ ;; => TODO : proclaim
+
+ ;; TODO: simplifier la lambda-list.
+ ((lambda :params _ :body _*)
+ (let* ((sliced-lambda-list (slice-up-lambda-list params))
+ (whole-sym (make-symbol "LAMBDA-PARAMETERS"))
+ (temp-key-sym (make-symbol "TEMP-KEY-SYM"))
+ (fixed (cdr (assoc 'fixed sliced-lambda-list)))
+ (optional (cdr (assoc 'optional sliced-lambda-list)))
+ (rest (cdr (assoc 'rest sliced-lambda-list)))
+ (key (cdr (assoc 'key sliced-lambda-list)))
+ (other (cdr (assoc 'other sliced-lambda-list)))
+ (aux (cdr (assoc 'aux sliced-lambda-list))))
+ `(lambda (&rest ,whole-sym)
+ ,(transform
+ `(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)) `(,temp-key-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 `(if ,whole-sym
+ ((set ,param (car whole-sym))
+ (progn (setq ,whole-sym (cdr ,whole-sym)))
+ (use ,param)
+ ,@(if predicate `((set ,predicate t) (use predicate)) nil))
+ ((set ,param ,default)
+ (use ,param)
+ ,@(if predicate `((set ,predicate nil) (use predicate)) nil))))
+ ,@(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)
+ ,@(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)
+ collect (let ((search-key (make-symbol "SEARCH-KEY")))
+ `((progn (simple-tagbody
+ (jump-label ,search-key)
+ (if ,temp-key-sym
+ (if (eq (car ,search-key) ,keyword)
+ ;; trouvé
+ nil
+ ;; chercher encore
+ (progn
+ (setq ,temp-key-sym (cddr ,search-key))
+ (jump ,search-key)))
+ ;; pas trouvé
+ nil)))
+ (if ,temp-key-sym
+ ((set ,param (car ,temp-key-sym))
+ (use ,param)
+ ,@(if predicate `((set predicate t) (use predicate)) nil))
+ ((set ,param ,default)
+ (use ,param)
+ ,@(if predicate `((set predicate nil) (use 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))
+ (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)))))
+
+ ((funcall :fun _ :params _*)
+ `(funcall ,(transform fun) ,@(mapcar (lambda (x) (transform x)) params)))
+
+ ;; TODO : apply
+ ;; => TODO : définir la fonction funcall : (funcall #'funcall #'cons 1 2)
+ ;; => TODO : définir la fonction apply : (funcall #'apply #'cons '(1 2))
+
+ ((setq :name $$ :value _)
+ `(setq ,(assoc-or name env-var (assoc-or-push name (derived-symbol name) (car globals)))
+ ,(transform value)))
+
+ ((quote _)
+ expr)
+
+ ((? or numberp stringp)
+ `(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))))))
+
+ ;; Appels de fonction
+ ;; Doivent être après tout le monde.
+ ((:fun $$ :params _*)
+ (transform `(funcall (function ,fun) ,@params)))
+
+ ((:lambda (lambda . _) :params _*)
+ (transform `(funcall ,lambda ,@params)))
+
+ (((function :lambda (lambda . _)) :params . _)
+ (transform `(funcall ,lambda ,@params)))
+
+ (((function :name $$) :params _*)
+ (transform `(funcall (function ,name) ,@params)))
+
+ (_
+ (error "squash-lisp-1: Not implemented yet : ~a" expr)))))
(defun squash-lisp-1-wrap (expr)
`(macrolet ((unwind-catch (object body catch-code)
@@ -282,6 +406,8 @@
;; les (progn object) et (progn x) sert à permettre l'expansion des macros sur x
;; (il est possible qu'elles ne soient pas expansées à la racine du tagbody)
`(tagbody (progn ,object) ,@(mapcar (lambda (x) (if (eq (car x) 'jump-label) (cadr x) (progn x))) (cdr body))))
+ (simple-tagbody (&rest body)
+ `(tagbody ,@(mapcar (lambda (x) (if (eq (car x) 'jump-label) (cadr x) (progn x))) body)))
(unwind (object)
`(throw ,object nil))
(unwind-for-tagbody (object post-unwind-code)
@@ -293,12 +419,8 @@
;; name)
(jump (dest)
`(go ,dest))
- (simple-flet (spec &rest body)
- `(flet ,(mapcar (lambda (x) (list (car x) (second (second x)) (third (second x)))) spec) ;; nom, lambda-list, fbody
- ,@body))
- (simple-labels (spec &rest body)
- `(labels ,(mapcar (lambda (x) (list (car x) (second (second x)) (third (second x)))) spec) ;; nom, lambda-list, fbody
- ,@body))
+ (simple-let (spec body)
+ `(let spec body))
(get-var (x)
x))
,expr))
@@ -309,7 +431,8 @@ Permet aussi d'avoir une «grammaire» du simple-lisp niveau 1.
Attention : il y a quelques invariants qui ne sont pas présents dans cette vérification."
(cond-match
expr
- ((progn :body _*)
+ ;; simple-tagbody est équivalent à un progn, mais nécessaire pour les macrolet.
+ (((? (member x '(progn simple-tagbody))) :body _*)
(every #'squash-lisp-1-check body))
((if :condition _ :si-vrai _ :si-faux _)
(and (squash-lisp-1-check condition)
@@ -319,7 +442,7 @@ Attention : il y a quelques invariants qui ne sont pas présents dans cette vér
(and (squash-lisp-1-check body)
(squash-lisp-1-check cleanup)))
;; tagbody-unwind-catch est équivalent à unwind-catch, mais nécessaire pour les macrolet.
- (((? (member x '(unwind-catch tagbody-unwind-catch))) :object _ :body _ :catch-code _)
+ (((? (member x '(unwind-catch tagbody-unwind-catch))) :object _ :body (progn _*) :catch-code _)
(and (squash-lisp-1-check object)
(squash-lisp-1-check body)
(squash-lisp-1-check catch-code)))
@@ -332,9 +455,9 @@ Attention : il y a quelques invariants qui ne sont pas présents dans cette vér
t)
((jump :dest $$)
t)
- (((? (member x '(let let* simple-flet simple-labels))) ((:name $$ :value _)*) :body _)
- (every #'squash-lisp-1-check (cons body value)))
- ((lambda :params @ :body _)
+ ((let ($$*) :body _)
+ (squash-lisp-1-check body))
+ ((lambda (&rest $$) :body _)
(squash-lisp-1-check body))
((function :fun $$)
t)
diff --git a/lisp/squash-lisp-2.lisp b/lisp/squash-lisp-2.lisp
@@ -3,10 +3,6 @@
(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 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
expr
((progn :body _*)
@@ -33,20 +29,24 @@
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))
+ (labels ((transform-super-let (expr)
+ `(progn
+ ,@(loop
+ for (type . clause) in stuff
+ when (eq type 'set)
+ collect `(setq ,(cdr (assoc (car clause) name)) (squash-lisp-2 (cadr clause) env-var env-fun globals))
+ when (eq type 'use-var)
+ do (push (assoc (car clause) name) env-var)
+ when (eq type 'use-fun)
+ do (push (assoc (car clause) name) env-fun)
+ when (eq type 'if)
+ do `(if ,(squash-lisp-2 (car clause) env-var env-fun globals)
+ (progn ,(mapcar #'transform-super-let (cadr clause)))
+ (progn ,(mapcar #'transform-super-let (caddr clause))))
+ when (eq type 'progn)
+ collect `(progn ,(mapcar (lambda (x) (squash-lisp-2 x env-var env-fun globals)) clause))))))
`(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)))))))
+ ,(transform-super-let expr))))
((let ((:name $$ :value _)*) :body _)
(squash-lisp-2
`(super-let ,name
@@ -78,39 +78,39 @@
,@(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)))
- `(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)))
- `(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
- `(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
- `(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 ((:name $$ :value _)*) :body _)
+ ;; (setq name (mapcar (lambda (x) (cons x (derived-symbol x))) name))
+ ;; (let ((new-env-var (append name env-var)))
+ ;; `(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)))
+ ;; `(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
+ ;; `(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
+ ;; `(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
@@ -142,57 +142,10 @@
;; 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))))
+;; TODO : raison : transformer les appels de fonction en funcall, etc.
-nil à la fin
+;; 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))))
diff --git a/lisp/squash-lisp.lisp b/lisp/squash-lisp.lisp
@@ -9,7 +9,7 @@
;; TODO : tests unitaires.
(require 'squash-lisp-1 "squash-lisp-1")
-(require 'squash-lisp-2 "squash-lisp-2")
+;;(require 'squash-lisp-2 "squash-lisp-2")
;; captures = ((capture*)*)
;; env-var = (((nom-variable symbole-unique état (référence-lecture*) (référence-écriture*))*)*)
