commit 78b4ccfd0b5aa468700b74c73a391f7c5c199c7d
parent 709ef979c67725f02e158aa242141e0df76954ca
Author: Georges Dupéron <jahvascriptmaniac+github@free.fr>
Date: Wed, 12 Jan 2011 12:53:53 +0100
squash-lisp-2 est mort, vive squash-lisp-3 !
Sous clisp et sbcl : tous les tests passent, aucun warning.
Diffstat:
5 files changed, 236 insertions(+), 373 deletions(-)
diff --git a/lisp/equiv-tests.lisp b/lisp/equiv-tests.lisp
@@ -8,10 +8,15 @@
(deftest ,(append '(equiv expected/mini-meval) module) (mini-meval ,test etat) ,expected)
(deftest ,(append '(equiv squash-lisp-1-check) module) (squash-lisp-1-check (squash-lisp-1 ,test t etat)) t) ;; etat -> pour les macros
(deftest ,(append '(equiv expected/squash-lisp-1) module) (eval (squash-lisp-1-wrap (squash-lisp-1 ,test t etat))) ,expected) ;; etat -> pour les macros
- ;; (deftest ,(append '(equiv squash-lisp-2-check) module) (squash-lisp-2-check (squash-lisp-2 ,test)) t)
- ;; (deftest ,(append '(equiv expected/squash-lisp-2) module) (eval (squash-lisp-2-wrap (squash-lisp-2 ,test))) ,expected)
- ))
-
+ (deftest ,(append '(equiv squash-lisp-3-check) module)
+ (let ((globals (cons nil nil)))
+ (squash-lisp-3-check (squash-lisp-3 (squash-lisp-1 ,test t etat nil nil globals) globals)))
+ t)
+ ;; (deftest ,(append '(equiv expected/squash-lisp-3) module)
+ ;; (let ((globals (cons nil nil)))
+ ;; (eval (squash-lisp-3-wrap (squash-lisp-3 (squash-lisp-1 ,test t etat nil nil globals) globals))))
+ ;; ,expected)))
+))
(erase-tests equiv)
(deftestvar (equiv) etat (push-local (make-etat list + - cons car cdr < > <= >= =) '*test-equiv-var-x* 'variable 42))
@@ -218,4 +223,8 @@
'#'+
#'+)
+(deftest-equiv (lambda captures)
+ '(funcall ((lambda (x y) x (lambda (x) (+ x y))) 1 2) 3)
+ 5)
+
(provide 'equiv-tests)
diff --git a/lisp/main.lisp b/lisp/main.lisp
@@ -10,8 +10,9 @@
(load "vm")
(load "match")
(load "mini-meval")
-(load "squash-lisp")
(load "squash-lisp-1")
+(load "squash-lisp-3")
+(load "squash-lisp")
(load "equiv-tests")
(provide 'main)
diff --git a/lisp/squash-lisp-1.lisp b/lisp/squash-lisp-1.lisp
@@ -285,7 +285,7 @@
(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)
+ `(named-lambda ,(make-symbol "LAMBDA") (&rest ,whole-sym)
,(transform whole-sym) ;; pour pas qu'il soit unused si aucun paramètre.
,(transform
`(super-let (,@fixed
@@ -436,6 +436,9 @@
(unwind-for-tagbody (object post-unwind-code)
object ;; unused variable
post-unwind-code)
+ (named-lambda (name params &rest body)
+ name ;; unused variable
+ `(lambda ,params ,@body))
;;Les macros ne sont pas expansées à la racine d'un tagbody, donc on expanse à la main
;; les jump-label lorsqu'on rencontre un tagbody-unwind-catch.
;;(jump-label (name)
@@ -478,7 +481,7 @@ Attention : il y a quelques invariants qui ne sont pas présents dans cette vér
t)
((let ($$*) :body _)
(squash-lisp-1-check body))
- ((lambda (&rest $$) :unused _ :body (let ($$*) _*))
+ ((named-lambda :name $$ (&rest $$) :unused _ :body (let ($$*) _*))
(squash-lisp-1-check body))
((funcall :fun _ :params _*)
(every #'squash-lisp-1-check (cons fun params)))
diff --git a/lisp/squash-lisp-3.lisp b/lisp/squash-lisp-3.lisp
@@ -1,103 +1,253 @@
(require 'match "match")
-(defun squash-lisp-3 (expr local-env globals)
- "Lorsqu'une variable à l'intérieur d'une `lambda` référence une déclaration à l'extérieur de la `lambda`, on la marque comme étant *capturée*.
+(defun squash-lisp-3-internal (expr globals &optional (local-env (cons nil nil)) (getset (cons nil nil)) (top-level (cons nil nil)))
+ "Lorsqu'une variable à l'intérieur d'une `lambda' référence une déclaration à l'extérieur de la `lambda', on la marque comme étant *capturée*.
- On fusionne tous les `let` d'une `lambda` en les remontant dans un `let` unique à la racine de la `lamdba`.
+ On fusionne tous les `let' d'une `lambda' en les remontant dans un `let' unique à la racine de la `lamdba'.
+
+ [Abandonné, fait dans la compilation] On fusionne tous les `tagbody' d'une `lambda' en les remontant dans un `tagbody' unique à la
+ racine de la `lambda' ? + transformation des if en tagbody.
+
+ On sort toutes les lambdas (fonctions anonymes), on les nomme avec un symbole unique, et on les met au top-level.
- On sort toutes les lambdas (fonctions anonymes), on les nomme avec un symbole unique, et on les met au top-level."
- (macrolet ((transform (expr &optional (local-env 'local-env)) `(squash-lisp-3 ,expr ,local-env globals)))
+ local-env : car = variables locales, cdr = variables capturées."
+ (macrolet ((transform (expr &optional (local-env 'local-env) (getset 'getset)) `(squash-lisp-3-internal ,expr globals ,local-env ,getset top-level)))
(cond-match
expr
;; simple-tagbody est équivalent à un progn, mais nécessaire pour les macrolet.
- (((? (member x '(progn simple-tagbody))) :body _*)
- (let ((res (list 'progn)))
+ ((:type (? (member x '(progn simple-tagbody))) :body _*)
+ (let ((res (list 'progn))
+ (is-tagbody (eq type 'simple-tagbody)))
(labels ((squash-progn (body)
(dolist (e body)
(if (and (consp e) (eq 'progn (car e)))
(squash-progn (cdr e))
- (push (squash-lisp-3 e local-env globals) res)))))
- (squash-progn body))
+ (if (and (consp e) (eq 'simple-tagbody (car e)))
+ (progn (setq is-tagbody t)
+ (squash-progn (cdr e)))
+ (push e res))))))
+ (squash-progn (mapcar (lambda (x) (transform x)) body)))
;; TODO : ici : filtrer les expressions de `res' qui sont sans effet de bord, sauf la dernière.
- (print res)
- (if (cdr res) ;; res != '(progn)
- (if (cddr res) ;; res != '(single-expr progn)
- (reverse res)
- (car res))
- '(quote nil))))
+ (setq res (reverse res))
+ (setq res (append (remove ''nil (butlast res) :test #'equal) (last res)))
+ (setq res (if (cdr res) ;; res != '(progn)
+ (if (cddr res) ;; res != '(progn single-expr)
+ res
+ (cadr res))
+ '(quote nil)))
+ (when is-tagbody (setf (car res) 'simple-tagbody))
+ res))
((if :condition _ :si-vrai _ :si-faux _)
- (and (squash-lisp-3 condition)
- (squash-lisp-3 si-vrai)
- (squash-lisp-3 si-faux)))
+ `(if ,(transform condition)
+ ,(transform si-vrai)
+ ,(transform si-faux)))
((unwind-protect :body _ :cleanup _)
- (and (squash-lisp-3 body)
- (squash-lisp-3 cleanup)))
+ `(unwind-protect ,(transform body)
+ ,(transform cleanup)))
;; tagbody-unwind-catch est équivalent à unwind-catch, mais nécessaire pour les macrolet.
- (((? (member x '(unwind-catch tagbody-unwind-catch))) :object _ :body (progn _*) :catch-code _)
- (and (squash-lisp-3 object)
- (squash-lisp-3 body)
- (squash-lisp-3 catch-code)))
+ ((:type (? (member x '(unwind-catch tagbody-unwind-catch))) :object _ :body (progn _*) :catch-code _)
+ `(,type ,(transform object)
+ ,(transform body)
+ ,(transform catch-code)))
((unwind :object _)
- (squash-lisp-3 object))
+ `(unwind ,(transform object)))
((unwind-for-tagbody :object _ :post-unwind-code _)
- (and (squash-lisp-3 object)
- (squash-lisp-3 post-unwind-code)))
+ `(unwind-for-tagbody ,(transform object)
+ ,(transform post-unwind-code)))
((jump-label :name $$)
- t)
+ expr)
((jump :dest $$)
- t)
- ((let ($$*) :body _)
- (squash-lisp-3 body))
- ((lambda :params (&rest $$) :unused _ :body (let ($$*) _*))
- (push let-vars stack)
- (push `(lambda ,params
- ,unused
- (let (,let-vars)
- ,(squash-lisp-3 body)))
- top-level)
- (setq let-vars (pop stack)))
+ expr)
+ ((let :vars ($$*) :body _)
+ (setf (car local-env) (append vars (car local-env)))
+ (transform body))
+ ((named-lambda :name $$ :params (&rest :params-name $$) :unused _ :body (let ($$*) _*))
+ (let* ((new-local-env (cons (list params-name) nil))
+ (tbody (transform body new-local-env))
+ (new-getset nil)
+ (our-captures nil)
+ (not-our-captures nil))
+ ;; on "nomme" la lambda, et ce nom est global
+ (push name (car globals))
+ ;; on transforme les get-var de variables capturées en get-captured-var
+ (dolist (getter (car getset))
+ (if (member (cadr getter) (cdr local-env))
+ (setf (car getter) 'get-captured-var)
+ (push getter new-getset)))
+ ;; on remplace le (car getset) par ceux qui ont été ignorés
+ (setf (car getset) new-getset)
+ ;; on nettoie pour faire les sets
+ (setf new-getset nil)
+ ;; on transforme les get-var de variables capturées en get-captured-var
+ (dolist (setter (cdr getset))
+ (if (member (cadr setter) (cdr local-env))
+ (setf (car setter) 'set-captured-var)
+ (push setter new-getset)))
+ ;; on remplace le (cdr getset) par ceux qui ont été ignorés
+ (setf (cdr getset) new-getset)
+ ;; on récupère les noms variables qu'on a déclaré (c'est nous qui les capturons).
+ (setf our-captures (intersection (car new-local-env) (cdr new-local-env)))
+ (setf not-our-captures (set-difference (cdr new-local-env) our-captures))
+ ;; on ajoute celles qu'on n'a pas capturé aux captures d'au-dessus
+ (setf (cdr local-env) (append not-our-captures (cdr local-env)))
+ ;; on construit la lambda au top-level
+ (push `(set ,name (lambda ,params ,unused
+ (let ,(car new-local-env)
+ ,@(mapcar (lambda (x) `(make-captured-var ,x)) our-captures)
+ ,tbody)))
+ (car top-level))
+ ;; on remplace toute la lambda par un accès à sa définition au top-level
+ `(symbol-value ',name)))
((funcall :fun _ :params _*)
- (every #'squash-lisp-3 (cons fun params)))
+ `(funcall ,@(mapcar (lambda (x) (transform x)) (cons fun params))))
((quote _)
- t)
+ expr)
((get-var :var $$)
- ;; chercher si var est dans local-env ou bien dans global
+ ;; chercher si var est dans (car local-env) ou bien dans global
;; si oui -> get-var
;; sinon, -> get-captured-var
- t)
+ (if (or (member var (car local-env)) (member var (car globals)))
+ (progn
+ (push expr (car getset))
+ expr)
+ (progn
+ (pushnew var (cdr local-env))
+ `(get-captured-var ,var))))
((setq :name $$ :value _)
;; comme ci-dessus
- (squash-lisp-3 value))
+ (if (or (member name (car local-env)) (member name (car globals)))
+ (progn
+ (push expr (car getset))
+ `(setq ,name ,(transform value)))
+ (progn
+ (pushnew name (cdr local-env))
+ `(set-captured-var ,name ,(transform value)))))
+ ;; + (transform value)
((fdefinition (quote $$))
- t)
+ expr)
((symbol-value (quote $$))
- t)
- ((set (quote $$) :value _)
- (squash-lisp-3 value)))))
+ expr)
+ ((set :var (quote $$) :value _)
+ `(set ,var ,(transform value)))
+ (_
+ (error "squash-lisp-3-internal : Assertion failed ! this should not be here : ~a" expr)))))
+
+(defun squash-lisp-3 (expr globals)
+ (let* ((tl (cons nil nil))
+ (lsym (make-symbol "MAIN"))
+ (psym (make-symbol "NO-PARAMETERS")))
+ (squash-lisp-3-internal `(named-lambda ,lsym (&rest ,psym) (get-var ,psym) (let () ,expr)) globals (cons nil nil) (cons nil nil) tl)
+ `(top-level ,lsym (progn ,@(car tl)))))
+
+
+(defun squash-lisp-3-check-internal (expr)
+ "Vérifie si expr est bien un résultat valable de squash-lisp-1.
+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
+ ;; simple-tagbody est équivalent à un progn, mais nécessaire pour les macrolet.
+ (((? (member x '(progn simple-tagbody))) :body _*)
+ (every #'squash-lisp-3-check-internal body))
+ ((if :condition _ :si-vrai _ :si-faux _)
+ (and (squash-lisp-3-check-internal condition)
+ (squash-lisp-3-check-internal si-vrai)
+ (squash-lisp-3-check-internal si-faux)))
+ ((unwind-protect :body _ :cleanup _)
+ (and (squash-lisp-3-check-internal body)
+ (squash-lisp-3-check-internal cleanup)))
+ ;; tagbody-unwind-catch est équivalent à unwind-catch, mais nécessaire pour les macrolet.
+ (((? (member x '(unwind-catch tagbody-unwind-catch))) :object _ :body (progn _*) :catch-code _)
+ (and (squash-lisp-3-check-internal object)
+ (squash-lisp-3-check-internal body)
+ (squash-lisp-3-check-internal catch-code)))
+ ((unwind :object _)
+ (squash-lisp-3-check-internal object))
+ ((unwind-for-tagbody :object _ :post-unwind-code _)
+ (and (squash-lisp-3-check-internal object)
+ (squash-lisp-3-check-internal post-unwind-code)))
+ ((jump-label :name $$)
+ t)
+ ((jump :dest $$)
+ t)
+ ;; ((let ($$*) :body _)
+ ;; (squash-lisp-3-check-internal body))
+ ;; ((lambda (&rest $$) :unused _ :body (let ($$*) _*))
+ ;; (squash-lisp-3-check-internal body))
+ ((funcall :fun _ :params _*)
+ (every #'squash-lisp-3-check-internal (cons fun params)))
+ ((quote _)
+ t)
+ ((get-var $$)
+ t)
+ ((setq :name $$ :value _)
+ (squash-lisp-3-check-internal value))
+ ((fdefinition (quote $$))
+ t)
+ ((symbol-value (quote $$))
+ t)
+ ((set (quote $$) :value _)
+ (squash-lisp-3-check-internal value))
+ ((make-captured-var $$)
+ t)
+ ((get-captured-var $$)
+ t)
+ ((set-captured-var $$ :value _)
+ (squash-lisp-3-check-internal value))
+ (_
+ (warn "squash-lisp-3-check-internal: Assertion failed ! This should not be here : ~w" expr)
+ nil)))
+
+(defun squash-lisp-3-check (expr)
+ (cond-match expr
+ ((top-level $$ (progn :body _*))
+ (every (lambda (x)
+ (cond-match x
+ ((set $$ (lambda (&rest $$) (get-var $$)
+ (let ($$*) :bodys _*)))
+ (every #'squash-lisp-3-check-internal bodys))
+ (_
+ (warn "~&squash-lisp-3-check : this should not be here :~&~a" x)
+ nil)))
+ body))
+ (_ (warn "~&squash-lisp-3-check : this should not be here :~&~a" expr)
+ nil)))
+
+(defun nice-squash-lisp-3-check (expr)
+ (match (top-level $$ (progn
+ (set $$ (lambda (&rest $$) (get-var $$)
+ (let ($$*) (? squash-lisp-3-check-internal)*)))*))
+ expr))
+
+(defun squash-lisp-1+3 (expr &optional (etat (list nil nil nil)))
+ (let ((globals (cons nil nil)))
+ (squash-lisp-3 (squash-lisp-1 expr t etat nil nil globals) globals)))
(require 'test-unitaire "test-unitaire")
(erase-tests squash-lisp-3)
-(deftest (squash-lisp-3 progn)
- (squash-lisp-3 '(progn
- (progn (progn) (progn))
- (progn)
- (progn (progn) (progn) (progn))))
+(deftest (squash-lisp-3 internal progn)
+ (squash-lisp-3-internal '(progn
+ (progn (progn) (progn))
+ (progn)
+ (progn (progn) (progn) (progn)))
+ '(nil . nil))
''nil)
-(deftest (squash-lisp-3 progn)
- (squash-lisp-3 '(progn))
+(deftest (squash-lisp-3 internal progn)
+ (squash-lisp-3-internal '(progn) '(nil . nil))
''nil)
-(deftest (squash-lisp-3 progn)
- (squash-lisp-3 '(progn (symbol-value 'a)))
+(deftest (squash-lisp-3 internal progn)
+ (squash-lisp-3-internal '(progn (symbol-value 'a)) '((a) . nil))
'(symbol-value 'a))
-(deftest (squash-lisp-3 progn)
- (squash-lisp-3 '(progn
- (progn (progn (symbol-value 'a)) (progn))
- (progn)
- (progn (progn) (progn) (progn))))
- '(symbol-value 'a))
+(deftest (squash-lisp-3 internal progn)
+ (squash-lisp-3-internal '(progn
+ (progn (progn (symbol-value 'a)) (progn))
+ (progn)
+ (progn (progn) (progn) (progn)))
+ '((a) . nil))
+ '(progn (symbol-value 'a) 'nil))
;(run-tests squash-lisp-3)
\ No newline at end of file
diff --git a/lisp/squash-lisp.lisp b/lisp/squash-lisp.lisp
@@ -1,311 +1,11 @@
(require 'mini-meval "mini-meval")
(require 'match "match")
-;; À 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 ...) pour les "special-operator" qu'on rajoute.
+(require 'squash-lisp-1 "squash-lisp-1")
+(require 'squash-lisp-1 "squash-lisp-3")
-;; 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.
+;; Notes sur le fonctionnement (théorique) de squash-lisp
-(require 'squash-lisp-1 "squash-lisp-1")
-;;(require 'squash-lisp-2 "squash-lisp-2")
-
-;; captures = ((capture*)*)
-;; env-var = (((nom-variable symbole-unique état (référence-lecture*) (référence-écriture*))*)*)
-;; état = [nil == variable normale] || ['captured == variable capturée] || ['special == variable spéciale]
-;; env-fun = ((nom-fonction . symbole-unique)*)
-
-(defun squash-lisp-3 (expr &optional (captures (list nil)) (env-var (list nil)) env-fun special-vars)
- "Détecte les variables capturées, supprime les let, let*, flet, labels, lambda en les transformant en simple-let et simple-lambda."
- (cond-match
- expr
-
- ;; let et let*
- ((:type (? or (eq x 'let) (eq x 'let*)) ((:names $$ :values _)*) :body _)
- ;; => new-env-var := env-var
- (let ((new-env-var env-var)
- (simple-let-vars nil)
- (simple-let-backups nil)
- (simple-let-pre-body nil)
- (simple-let-body nil)
- (simple-let-restore nil)
- (set-expression)
- (unique-sym nil)
- (let* (eq type 'let*)))
- ;; => Pour chaque binding
- (dolist* ((n names) (v values))
- ;; => On crée un symbole unique pour représenter cette liaison
- (setq unique-sym (make-symbol (string n)))
- ;; => ajouter unique-sym dans le simple-let qu'on crée
- (push unique-sym simple-let-vars)
-
- (if (member n special-vars)
- ;; => Si c'est une variable spéciale,
- (progn
- ;; => On garde le nom d'origine comme nom de variable, et on utilise le nom unique comme symbole de sauvegarde.
- ;; => au tout début du body, avant les autres set, sauvegarder la variable
- (push `(setq ,unique-sym ,n) simple-let-backups)
- ;; => au début du body, set la variable avec (transform valeur (new- si let*)env-var env-fun)
- (push `(setq ,n ,(squash-lisp-3 v captures (if let* new-env-var env-var) env-fun)) simple-let-pre-body)
- ;; => à la fin du body (dans un unwind-protect), restaurer la variable
- (push `(setq ,n ,unique-sym) simple-let-restore))
- ;; => Sinon (variable "normale" ou futurement capturée),
- (progn
- ;; => au début du body, set la variable unique-sym avec (transform valeur (new- si let*)env-var env-fun)
- (setq set-expression `(setq ,unique-sym ,(squash-lisp-3 v captures (if let* new-env-var env-var) env-fun)))
- (push set-expression simple-let-pre-body)
- ;; => push (nom unique-sym nil <pas-de-get> <set-expression>) sur new-env-var
- (push `(,n ,unique-sym nil nil (,set-expression)) (car new-env-var)))))
- ;; => transforme le body dans new-env-var env-fun
- (setq simple-let-body (squash-lisp-3 body captures new-env-var env-fun))
- ;; => construit et renvoie le simple-let
- (if simple-let-restore
- `(simple-let ,(reverse simple-let-vars)
- (unwind-protect
- (progn ,@(reverse simple-let-backups) ;; Ne peut / doit pas déclenger d'unwind
- ,@(reverse simple-let-pre-body) ;; À partir d'ici on peut
- ,simple-let-body)
- (progn ,@(reverse simple-let-restore))))
- `(simple-let ,(reverse simple-let-vars)
- (progn ,@(reverse simple-let-pre-body)
- ,simple-let-body)))))
-
- ;; flet et labels
- ((:type (? or (eq x 'flet) (eq x 'labels)) ((:names $ :values _)*) :body _)
- ;; => new-env-var := env-var
- ;; => new-env-fun := env-fun
- (let ((new-env-var env-var)
- (new-env-fun env-fun)
- (simple-let-vars nil)
- (simple-let-pre-body nil)
- (simple-let-body nil)
- (set-expression)
- (unique-sym nil)
- (labels (eq type 'labels)))
- ;; => Pour chaque binding
- (dolist* ((n names) (v values))
- ;; => On crée un symbole unique pour représenter cette liaison dans l'environnement des variables
- (setq unique-sym (make-symbol (string n)))
- ;; => ajouter unique-sym dans le simple-let qu'on crée
- (push unique-sym simple-let-vars)
- ;; => On push le unique-sym dans les variables : (unique-sym unique-sym nil <pas-de-get> <set-expression qui sera déterminé plus tard>)
- (setq set-expression (list 'setq unique-sym 'not-yet-defined))
- (push `(,unique-sym ,unique-sym nil nil (,set-expression)) (car new-env-var))
- ;; => push (nom . unique-sym) sur new-env-fun
- (push `(,n . ,unique-sym) new-env-fun)
- ;; => au début du body, set la variable unique-sym avec (transform <lambda> (new- si labels)env-var (new- si labels)env-fun)
- ;; + set sur le champ "valeur" du set-expression
- ;; Note : on marche sur de l'ether…
- (setf (third set-expression) (squash-lisp-3 v captures (if labels new-env-var env-var) (if labels new-env-fun env-fun)))
- (push set-expression simple-let-pre-body))
- ;; => On transforme le body dans new-env-var new-env-fun
- (setq simple-let-body (squash-lisp-3 body captures new-env-var new-env-fun))
- ;; => construit et renvoie le simple-let
- `(simple-let ,(reverse simple-let-vars)
- (progn ,@(reverse simple-let-pre-body)
- ,simple-let-body))))
-
- ;; lambda
- ;; Beaucoup de code dupliqué entre les let[*] / lambda / flet / labels
- ;; TODO : gérer le &rest
- ((lambda :params ($$*) :body _)
- (let ((simple-lambda-captures (list nil))
- (simple-lambda-body))
- ;; Shift l'environnement courant en le remplaçant par un tout nouveau tout bô.
- (setq env-var (cons nil env-var))
- (push simple-lambda-captures captures)
- ;; Quand on capture, on ne sait pas si la variable sera déclarée spéciale plus tard.
- ;; Mais on a décidé (cf. les notes plus bas) de ne pas supporter la re-déclaration d'une variable comme spéciale.
- ;; Création du simple-lambda
- ;; TODO : insérer du code pour avoir les captures.
- ;; TODO : closure ? make-closure ? ???
- (setq simple-lambda-body
- (squash-lisp-3
- `(let ,(loop
- for i upfrom 1
- for var in params
- collect `(,var (get-param ,i)))
- ,body)))
- (print simple-lambda-captures)
- (print captures)
- `(simple-lambda
- ,(length params)
- ,simple-lambda-body)))
-
- ;; Appel de fonction
- ((funcall :fun _ :args _*)
- (cons 'funcall (mapcar (lambda (x) (squash-lisp-3 x captures env-var env-fun)) (cons fun args))))
-
- ;; TODO : apply ?
-
- ;; Référence à une fonction
- ((function :fun $$)
- (let ((association (assoc fun env-fun)))
- (unless association
- (setq association `(,fun . ,(make-symbol (string fun))))
- (push association env-fun))
- (squash-lisp-3 `(get-var ,(cdr association)) captures env-var env-fun)))
-
- ;; Progn
- ((progn :exprs _*)
- (cons 'progn (mapcar (lambda (x) (squash-lisp-3 x captures env-var env-fun)) exprs)))
-
- ;; Récupération d'un paramètre
- ((get-param (? numberp))
- expr)
-
- ;; Référence à une variable
- ;; (get-var var)
- ((:type (? or (eq x 'get-var) (eq x 'setq)) :var $$ :val _?)
- (format t "~&var:~a~&env:~a~&~%" var env-var)
- (let ((resultat nil)
- (search-env-var env-var)
- (envs nil)
- (through-captures captures)
- (is-global nil)
- (variable nil)
- (setq (eq type 'setq)))
- ;; => chercher la définition de la variable.
- (tagbody
- search-loop
- (push (car search-env-var) envs)
- start
- (when (endp (cdr search-env-var))
- (setq is-global t))
- (setq variable (assoc expr (car search-env-var)))
- (unless variable
- (when (endp (cdr search-env-var))
- (go end))
- (setq search-env-var (cdr search-env-var))
- (go search-loop))
- end)
- ;; => resultat := (get-var var) ou (setq var (transform val …))
- (setq resultat (if setq
- (list 'setq (or (second variable) var)
- (squash-lisp-3 (car val) captures env-var env-fun))
- (list 'get-var (or (second variable) var))))
- ;; => Si la variable n'existe pas (globale donc)
- (when (not variable)
- (when (not is-global) (error "Assertion failed !!! La variable devrait être marquée comme globale apr le tagbody qu'on vient de passer.")) ;; DEBUG
- ;; => la pusher dans l'env-var le plus haut (last …) == search-env-var
- (if setq
- (push (setq variable `(,var ,var nil nil ,resultat)) (car search-env-var))
- (push (setq variable `(,var ,var nil ,resultat nil)) (car search-env-var))))
- ;; => Si elle ne se trouve ni dans l'env-var local (car) ni dans l'env-var global (last), alors c'est une capture
- ;; => Autre possibilité : la variable est spéciale, on la traite alors comme si elle était non capturée.
- (if (not (or (length=1 envs) is-global (eq 'special (third variable))))
- (progn
- (if setq
- (setf (car resultat) 'setq-indirection)
- (setf (car resultat) 'get-var-indirection))
- ;; => si c'est une nouvelle capture
- (unless (eq (third variable) 'captured)
- ;; => Pour chaque environnement intermédiaire + l'env-var local,
- (dotimes (i (length envs))
- ;; => On marque la variable comme capturée sur tous les niveaux entre sa déclaration et son utilisation
- (pushnew var (car through-captures))
- (setq through-captures (cdr through-captures)))
- ;; => On transforme tous les (get-var var) en (get-var-indirection var)
- (dolist (reference-get (fourth variable))
- (setf (car reference-get) 'get-var-indirection))
- (setf (fourth variable) nil)
- ;; => On transforme tous les (setq var val) en (setq-indirection var val)
- (dolist (reference-set (fifth variable))
- (setf (car reference-set) 'setq-indirection))
- (setf (fifth variable) nil)))
- ;; => Sinon, ce n'est pas (encore) une capture
- ;; => push resultat sur l'entrée de la variable dans env-var.
- (if setq
- (push resultat (fifth variable))
- (push resultat (fourth variable))))
- ;; renvoyer resultat
- resultat))
- ((quote _)
- expr)
- (_
- (error "squash-lisp-3: not implemented yet: ~a" expr)))) ;; end squash-lisp-3
-
-(defun squash-lisp-3-check (expr)
- "Vérifie si expr est bien un résultat valable de squash-lisp-3.
-Permet aussi d'avoir une «grammaire» du simple-lisp niveau 3.
-Attention : il y a quelques invariants qui ne sont pas présents dans cette vérification."
- (cond-match
- expr
- ((simple-let :vars ($$*) :body _)
- (every #'squash-lisp-3-check body))
- ((simple-lambda :nb-params (? numberp) :body _)
- ;; nb-params = sans compter le paramètre de closure.
- (every #' squash-lisp-3-check body))
- ((funcall :function _ :args _*)
- (every #'squash-lisp-3-check (cons function args)))
- ((progn :body _*)
- (every #'squash-lisp-3-check body))
- ((get-param (? numberp))
- t)
- ((setq :var $$ :val _)
- (squash-lisp-3-check val))
- ((get-var :var $$)
- t)
- ((setq-indirection :var $$ :val _)
- (squash-lisp-3-check val))
- ((get-var-indirection $$)
- t)
- ((quote :val _)
- t)
- (_
- (error "squash-lisp-3-check: Assertion failed ! This should not be here : ~a" expr))))
-
-;; TODO : pouquoi les let de squash-lisp-3 sont à l'envers ?
-
-(defun make-sql4-lambda (name nbargs slet-vars slet-body)
- ;; TODO reverse et append les slet-body et slet-vars
- `(named-lambda ,name ,nbargs (simple-let ,slet-vars (progn ,@slet-body))))
-
-;; TODO : où mettre les globales ?
-(defun squash-lisp-4 (expr)
- (let ((stack nil)
- (slet-vars nil)
- (flat nil))
- (labels ((rec (expr)
- (cond-match
- expr
- ((simple-let :vars ($$*) :body _*)
- (push vars slet-vars)
- (rec body))
- ((simple-lambda :nb-params (? numberp) :body _*)
- (let ((fun-name (make-symbol "a-function")))
- ;; nb-params = sans compter le paramètre de closure.
- ;; On push tout le monde
- (push slet-vars stack)
- ;; On raz pour un nouveau lambda
- (setq slet-vars nil)
- ;; On transforme le body : (rec body) ci-dessous,
- ;; et on crée la lambda et on l'ajoute au grand flat.
- ;; TODO : ajouter la liste de captures si nécessaire (?)
- (push (make-sql4-lambda fun-name nb-params slet-vars (rec body)) flat)
- ;; On réstaure tout le monde
- (setq slet-vars (pop stack))))
- ((funcall :function _ :args _*)
- `(funcall ,(rec function) ,@(mapcar #'rec args)))
- ((progn :body _*)
- (every #'squash-lisp-3-check body))
- ((get-param (? numberp))
- expr)
- ((setq :var $$ :val _)
- `(setq ,var ,(rec val)))
- ((get-var $$)
- expr)
- ((setq-indirection :var $$ :val _)
- `(setq-indirection ,var ,(rec val)))
- ((get-var-indirection $$)
- expr)
- ((quote _)
- expr)
- (_
- (error "squash-lisp-4: Not implemented yet : ~a" expr)))))
- (rec expr)
- flat)))
#|
