squash-lisp-2 est mort, vive squash-lisp-3 !
Sous clisp et sbcl : tous les tests passent, aucun warning.
This commit is contained in:
Georges Dupéron
parent
709ef979c6
commit
78b4ccfd0b
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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."
|
||||
(macrolet ((transform (expr &optional (local-env 'local-env)) `(squash-lisp-3 ,expr ,local-env globals)))
|
||||
On sort toutes les lambdas (fonctions anonymes), on les nomme avec un symbole unique, et on les met au top-level.
|
||||
|
||||
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)
|
||||
|
|
@ -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.
|
||||
|
||||
;; 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")
|
||||
(require 'squash-lisp-1 "squash-lisp-3")
|
||||
|
||||
;; 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)*)
|
||||
;; Notes sur le fonctionnement (théorique) de squash-lisp
|
||||
|
||||
(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)))
|
||||
|
||||
#|
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user