commit 4c0a45a5c61079c2f071c9ccfcf383d901137969
parent eed75e446c555f126eab5da132227fcc06ee6ef7
Author: Georges Dupéron <jahvascriptmaniac+github@free.fr>
Date: Thu, 13 Jan 2011 00:00:49 +0100
Correction d'un bug dans la transformation des closures (squash-lisp-3).
742 tests passed sucessfully.
Diffstat:
8 files changed, 412 insertions(+), 235 deletions(-)
diff --git a/lisp/compilation.lisp b/lisp/compilation.lisp
@@ -1,10 +1,231 @@
-;;
-;; TODO !! ATTENTION !! Quand onc récupère des données qui font 1 octet de large, en fait on récupère 4 octets !
-;;
(require 'match "match")
(require 'util "util")
(require 'squash-lisp "implementation/squash-lisp")
+;; TODO !! ATTENTION !! Quand onc récupère des données qui font 1 octet de large, en fait on récupère 4 octets !
+
+(defvar *asm-sections* '(code data)) ;; Note : l'assembleur sera produit dans cet ordre
+
+(defvar *sys-labels*)
+(defun syslabel (label)
+ (assoc-or-push label (derived-symbol label) *sys-labels*))
+
+(defun assembly-label-or-number-p (expr)
+ (or (numberp expr)
+ (match (label $$ $n) expr)))
+
+(defun immutable-assembly-place-p (expr)
+ (match (constant (? assembly-label-or-number-p)) expr))
+
+(defun mutable-assembly-place-p (expr)
+ (cond-match
+ expr
+ ((register (? (member x '(r0 r1 r2 sp bp fp)))) t)
+ ((constant (? assembly-label-or-number-p)) t)
+ ((memory (? assembly-label-or-number-p)) t)
+ ((indexed (? assembly-label-or-number-p)) t)
+ ((indirect-register (? (member x '(r0 r1 r2 sp bp fp)))) t)
+ ((indirect-constant (? assembly-label-or-number-p)) t)
+ ((indirect-indexed $n (? (member x '(r0 r1 r2 sp bp fp)))) t)))
+
+(defun assembly-place-p (expr)
+ (or (immutable-assembly-place-p expr)
+ (mutable-assembly-place-p expr)))
+
+(defun assembly-instruction-p (expr)
+ (cond-match
+ expr
+ ((mov :src $ap :dst $map) t)
+ ((call :fun $ap) t)))
+
+(defun compilo-check (asm)
+ (let ((non-empty nil)
+ (etiquettes nil)
+ (res nil))
+ ;; TODO : vérification de l'existance des étiquettes
+ (labels ((compilo-check-1 (asm)
+ (cond-match
+ asm
+ ((section (? $$ (member x *asm-sections*)) :body . @)
+ (every #'compilo-check-1 body))
+ ((label :l $$)
+ (push l etiquettes)
+ t)
+ (_
+ (if (assembly-instruction-p asm)
+ (progn
+ (setq non-empty t)
+ t)
+ (progn
+ (warn "compilo-check : this should not be here : ~a" asm)
+ nil))))))
+ (setq res (compilo-check-1 asm)))
+ (unless non-empty
+ (warn "compilo-check : Le code assembleur est vide ! Il n'y a aucune instruction.")
+ (setq res nil))
+ (unless (match (section (? $$ (member x *asm-sections*)) . @) asm)
+ (warn "compilo-check : malformed top-level assembly structure.")
+ (setq res nil))
+ res))
+
+(defun flatten-asm (asm)
+ (let ((res (mapcar #'list *asm-sections*))
+ (current nil))
+ (labels ((flatten-asm-1 (asm)
+ (cond-match
+ asm
+ ((section :sec $$ :body)
+ (setq current (assoc sec res))
+ (unless current
+ (error "flatten-asm : invalid section : ~a" sec)))
+ ((:mnemonique $$ :args $ap*)
+ (push asm current)))))
+ (flatten-asm-1 asm))
+ (apply #'append (mapcar (lambda (x) (cons (list 'section (car x)) (reverse (cdr x)))) res))))
+
+
+(defun compilo-1 (expr &aux res)
+ (match
+ (top-level :main $$ (progn (set :names $$ (lambda (:closure-names $$ &rest :params-names $$) (get-var $$) (get-var $$) (let :vars ($$*) :bodys _*)))*))
+ expr
+ (setq res (loop
+ for name in names
+ and closure-name in closure-names
+ and params-name in params-names
+ and var in vars
+ and body in bodys
+ collect `(label name)
+ collect `(mov (constant ,(+ 2 (length var))) (register r0)) ;; +1 pour les paramètres (nécessaire?)
+ collect `(push (register ip))
+ collect `(jmp (constant ,(syslabel 'reserve-stack)))
+ collect (compilo-2 `(progn body) (loop
+ for v in (cons closure-name (cons params-name var))
+ for i upfrom 0
+ collect `(,var . ,i)))))
+ `(section code (jmp main) ,@res)))
+
+(defun compilo (expr)
+ (flatten-asm (compilo-1 (squash-lisp-1+3 expr))))
+
+(defun compilo-2 (expr variables)
+ "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."
+ (labels ((compilo-3 (expr)
+ (cond-match
+ expr
+ ;; simple-tagbody est équivalent à un progn, mais nécessaire pour les macrolet.
+ (((? (member x '(progn simple-tagbody))) :body _*)
+ (every #'compilo-2 body))
+ ((if :condition _ :si-vrai _ :si-faux _)
+ (and (compilo-2 condition)
+ (compilo-2 si-vrai)
+ (compilo-2 si-faux)))
+ ((unwind-protect :body _ :cleanup _)
+ (and (compilo-2 body)
+ (compilo-2 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 (compilo-2 object)
+ (compilo-2 body)
+ (compilo-2 catch-code)))
+ ((unwind :object _)
+ (compilo-2 object))
+ ((unwind-for-tagbody :object _ :post-unwind-code _)
+ (and (compilo-2 object)
+ (compilo-2 post-unwind-code)))
+ ((jump-label :name $$)
+ t)
+ ((jump :dest $$)
+ t)
+ ;; ((let ($$*) :body _)
+ ;; (compilo-2 body))
+ ;; ((lambda (&rest $$) :unused _ :body (let ($$*) _*))
+ ;; (compilo-2 body))
+ ((funcall :fun _ :params _*)
+ (every #'compilo-2 (cons fun params)))
+ ((quote _)
+ t)
+ ((get-var :var $$)
+ (cdr (assoc var variables)))
+ ((setq :name $$ :value _)
+ (compilo-2 value))
+ ((fdefinition (quote $$))
+ t)
+ ((symbol-value (quote $$))
+ t)
+ ((set (quote $$) :value _)
+ (compilo-2 value))
+ ((make-captured-var $$)
+ t)
+ ((get-captured-var $$)
+ t)
+ ((set-captured-var $$ :value _)
+ (compilo-2 value))
+ (_
+ (warn "compilo-2: Assertion failed ! This should not be here : ~w" expr)
+ nil))))
+ (compilo-3 expr)))
+
+(squash-lisp-1+3 '(+ 2 3))
+
+#|
+;;; Exemples
+
+(my-compile '(1 2 3))
+
+(my-compile 3)
+;; section .data
+;; fixnum-constant-1
+;; db 0
+;; db 3
+
+(my-compile (+ 2 3))
+;; =>
+;; section .data
+;; fixnum-constant-1:
+;; db 1
+;; db 2
+;; section .data
+;; fixnum-constant-2:
+;; db 1
+;; db 3
+;; section .code
+;; code-1:
+;; load @global-1 r0
+;; push r0
+;; load @global-2 r0
+;; push r0
+;; push 2
+;; jsr @fn-+
+;; retn
+;; section .text
+;; :fn-+
+;; pop r1
+;; pop r0
+;; add r1 r0
+;; retn
+|#
+
+(provide 'compilation)
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+#|
(defvar *asm-fixnum-size* 32)
(defvar *asm-max-fixnum* (expt 2 *asm-fixnum-size*))
(defun type-number (type)
@@ -19,7 +240,7 @@
;; My-compile
(defvar *result-asm* nil)
-(defvar *sections* '(data code))
+(defvar *asm-sections* '(code data)) ;; Note : l'assembleur sera produit dans cet ordre
(defun real-asm-block (section label body)
(when (not (member section *sections*))
@@ -118,123 +339,4 @@
(compile si-faux)
(fasm "label @~a" end-if-label)))
-
-
- ;===========================
- ; ((( V2 *)))
- ;===========================
-
-(defun compilo (expr)
- (match
- (top-level :main $$
- (progn (set :name $$ (lambda :params (&rest $$) :unused (get-var $$)
- (let :vars ($$*) :body _*)))*))
- expr
- (setq res
- (loop
- for n in name
- and p in params
- and v in vars
- and b in body
- collect `(label n)
- collect `(mov ,(+ 1 (length vars)) r0)
- collect `(call ,(syslabel reserve-stack))
- (setq res (append `((jmp ,main)) (flatten-asm res)))
- res))
-
-(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)))
-
-
-;;; Exemples
-
-(my-compile '(1 2 3))
-
-(my-compile 3)
-;; section .data
-;; fixnum-constant-1
-;; db 0
-;; db 3
-
-(my-compile (+ 2 3))
-;; =>
-;; section .data
-;; fixnum-constant-1:
-;; db 1
-;; db 2
-;; section .data
-;; fixnum-constant-2:
-;; db 1
-;; db 3
-;; section .code
-;; code-1:
-;; load @global-1 r0
-;; push r0
-;; load @global-2 r0
-;; push r0
-;; push 2
-;; jsr @fn-+
-;; retn
-;; section .text
-;; :fn-+
-;; pop r1
-;; pop r0
-;; add r1 r0
-;; retn
-
-(provide 'compilation)
-\ No newline at end of file
+|#
diff --git a/lisp/equiv-tests.lisp b/lisp/equiv-tests.lisp
@@ -4,19 +4,13 @@
(defmacro deftest-equiv (module test expected)
`(progn
- (deftest ,(append '(equiv expected/eval) module) (eval ,test) ,expected)
- (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-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)))
-))
+ (deftest ,(append '(equiv eval expected) module) (eval ,test) ,expected)
+ (deftest ,(append '(equiv mini-meval expected) 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)
+ (deftest ,(append '(equiv squash-lisp-1 expected) module) (eval (squash-lisp-1-wrap (squash-lisp-1 ,test t etat))) ,expected)
+ (deftest ,(append '(equiv squash-lisp-3 check) module) (squash-lisp-3-check (squash-lisp-1+3 ,test etat)) t)
+ (deftest ,(append '(equiv squash-lisp-3 expected) module) (eval (squash-lisp-3-wrap (squash-lisp-1+3 ,test etat))) ,expected)))
+
(erase-tests equiv)
(deftestvar (equiv) etat (push-local (make-etat list + - cons car cdr < > <= >= =) '*test-equiv-var-x* 'variable 42))
@@ -227,4 +221,17 @@
'(funcall ((lambda (x y) x (lambda (x) (+ x y))) 1 2) 3)
5)
+(deftest-equiv (lambda captures ycombinator)
+ '((lambda (fibo)
+ (list (funcall fibo 0)
+ (funcall fibo 1)
+ (funcall fibo 2)
+ (funcall fibo 3)
+ (funcall fibo 4)
+ (funcall fibo 5)
+ (funcall fibo 6)
+ (funcall fibo 7)))
+ ((lambda (f) (lambda (x) (funcall f f x))) (lambda (f n) (if (<= n 1) n (+ (funcall f f (- n 1)) (funcall f f (- n 2)))))))
+ '(0 1 1 2 3 5 8 13))
+
(provide 'equiv-tests)
diff --git a/lisp/match.lisp b/lisp/match.lisp
@@ -18,6 +18,10 @@
;; $ (and (atom expr) (not (null expr)))
;; $$ (symbolp expr)
;; $k (keywordp expr)
+;; $n (numberp expr)
+;; $ap (assembly-place-p expr) ;; définie dans compilation.lisp
+;; $iap (immutable-assembly-place-p expr) ;; définie dans compilation.lisp
+;; $map (mutable-assembly-place-p expr) ;; définie dans compilation.lisp
;; $& (and (symbolp expr) (member expr '(&optional &rest &key &allow-other-keys &aux)))
;; @ liste propre : (and (listp expr) (match @ (cdr expr)))
;; @. cons : (consp expr)
@@ -36,6 +40,10 @@
;; Dans le cas où le pattern n'est pas "simple", la valeur correspondante
;; sera une liste de toutes les occurences de pattern
+(declaim (ftype function assembly-place-p)) ;; définie dans compilation.lisp
+(declaim (ftype function immutable-assembly-place-p)) ;; définie dans compilation.lisp
+(declaim (ftype function mutable-assembly-place-p)) ;; définie dans compilation.lisp
+
(defun pattern-match-do-lambdas-transform (pattern)
(mapcar (lambda (pred)
(cond ((atom pred) (list 'function pred))
@@ -53,7 +61,7 @@
,(if (second pattern)
(let ((?-clause (cdr (third pattern)))
(type '_))
- (when (and (consp ?-clause) (member (car ?-clause) '(nil _ $ $$ $k $& @ @.)))
+ (when (and (consp ?-clause) (member (car ?-clause) '(nil _ $ $$ $k $n $ap $iap $map $& @ @.)))
(setq type (car ?-clause))
(setq ?-clause (cdr ?-clause)))
;; TODO : (? or foo (? _ and bar baz) (? $ and quux))
@@ -365,6 +373,22 @@
((eq '$k pattern)
(when (keywordp expr)
(acons-capture capture-name expr nil)))
+ ;; $ap
+ ((eq '$ap pattern)
+ (when (assembly-place-p expr)
+ (acons-capture capture-name expr nil)))
+ ;; $iap
+ ((eq '$iap pattern)
+ (when (immutable-assembly-place-p expr)
+ (acons-capture capture-name expr nil)))
+ ;; $ap
+ ((eq '$map pattern)
+ (when (mutable-assembly-place-p expr)
+ (acons-capture capture-name expr nil)))
+ ;; $n
+ ((eq '$n pattern)
+ (when (numberp expr)
+ (acons-capture capture-name expr nil)))
;; $&
((eq '$& pattern)
(when (and (symbolp expr) (member expr '(&optional &rest &key &allow-other-keys &aux)))
diff --git a/lisp/mini-meval.lisp b/lisp/mini-meval.lisp
@@ -118,7 +118,7 @@
;; - &rest
;; - eq (vérifier qu'on préserve bien l'égalité de pointeurs là où il faut) / = / eql / equal / equalp
;; - load / open / close
-;; - defvar (gestion correcte des variables spéciales)
+;; - defvar [done mini-meval] (gestion correcte des variables spéciales)
;; - array support (array-total-size, row-major-aref, copy-seq)
;; - string support (char=, map, string (symbol => string), format, print)
;; - coder un reverse rapide.
@@ -477,7 +477,7 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
#| Traitement des appels de fonction |#
((:lambda (lambda @ _*) :params _*)
#| - Si c'est une fonction anonyme, on l'exécute. |#
- (apply (mini-meval lambda etat) params))
+ (apply (mini-meval lambda etat) (mapcar (lambda (x) (mini-meval x etat)) params)))
(((function :fun (lambda _ . _)) :params . _)
(mini-meval `(,fun ,@params) etat))
((:name (function $$) :params _*)
@@ -569,7 +569,7 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
(deftest (mini-meval setf setq)
(mini-meval '(list (defvar *test-var-z* 42) *test-var-z* (setq *test-var-z* 123) *test-var-z*) etat)
- '(x 42 123 123))
+ '(*test-var-z* 42 123 123))
;; TODO : tests setf
diff --git a/exemples-asm.lisp b/lisp/notes/exemples-asm.lisp
diff --git a/lisp/notes/soutenance.markdown b/lisp/notes/soutenance.markdown
@@ -92,6 +92,7 @@ compilation
* On avait déjà un système d'exploitation assez simple qui tournait de manière autonome sur un PC.
* On a donc stotché ensemble une REPL compilée et le SE de manière à avoir une REPL autonome qui ne dépend de rien.
* Le système d'exploitation sous-jacent fournit juste de quoi faire des entrées-sorties.
+* On a choisi de l'hypothèse d'un «monde fermé», dans lequel on connait tout le code à compiler dès le départ.
Ramasse-miettes
===============
diff --git a/lisp/squash-lisp-1.lisp b/lisp/squash-lisp-1.lisp
@@ -276,8 +276,8 @@
;; 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"))
+ (whole-sym (derived-symbol "LAMBDA-PARAMETERS"))
+ (temp-key-sym (derived-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)))
@@ -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)
- `(named-lambda ,(make-symbol "LAMBDA") (&rest ,whole-sym)
+ `(named-lambda ,(derived-symbol "ANONYMOUS-LAMBDA") (&rest ,whole-sym)
,(transform whole-sym) ;; pour pas qu'il soit unused si aucun paramètre.
,(transform
`(super-let (,@fixed
diff --git a/lisp/squash-lisp-3.lisp b/lisp/squash-lisp-3.lisp
@@ -11,7 +11,7 @@
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)))
+ (macrolet ((transform (expr &optional (local-env 'local-env)) `(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.
@@ -60,87 +60,91 @@
expr)
((let :vars ($$*) :body _)
(setf (car local-env) (append vars (car local-env)))
+ (dolist (v vars)
+ (when (assoc v (car getset))
+ (error "squash-lisp-3-internal : Assertion failed ! Duplicate definition of ~w" v))
+ (push (cons v (cons nil nil)) (car getset)))
(transform body))
- ((named-lambda :name $$ :params (&rest :params-name $$) :unused _ :body (let ($$*) _*))
- (let* ((new-local-env (cons (list params-name) nil))
+ ((named-lambda :name $$ :params (&rest :params-sym $$) :unused _ :body (let ($$*) _*))
+ (let* ((closure-sym (derived-symbol "CLOSURE"))
+ (new-local-env (progn (push (cons params-sym (cons nil nil)) (car getset))
+ (push (cons closure-sym (cons nil nil)) (car getset))
+ (cons (list closure-sym params-sym) nil)))
(tbody (transform body new-local-env))
- (new-getset nil)
- (our-captures nil)
- (not-our-captures nil))
+ (transitive-captures nil)
+ (here-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)))
+ (dolist (cap (cdr new-local-env))
+ (unless (or (member cap here-captures) (member cap transitive-captures))
+ (if (member cap (car new-local-env))
+ (let ((gs (assoc cap (car getset))))
+ (unless gs (error "squash-lisp-3-internal : Assertion failed ! ~w is captured, but not in getset." cap))
+ (dolist (getter (cadr gs))
+ (setf (car getter) 'get-captured-var))
+ (dolist (setter (cddr gs))
+ (setf (car setter) 'set-captured-var))
+ (push cap here-captures))
+ (progn
+ (push cap (cdr local-env))
+ (push cap transitive-captures)))))
;; 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)))
+ (push `(set ',name (lambda (,closure-sym &rest ,params-sym) (get-var ,closure-sym) ,unused
+ (let (,@(remove closure-sym (remove params-sym (car new-local-env)))
+ ,@transitive-captures)
+ (progn
+ ,@(mapcar (lambda (x) `(make-captured-var ,x)) here-captures)
+ ,@(loop for x in transitive-captures
+ collect `(setq ,x (funcall (fdefinition 'car) (get-var ,closure-sym)))
+ collect `(setq ,closure-sym (funcall (fdefinition 'cdr) (get-var ,closure-sym))))
+ ,tbody))))
(car top-level))
;; on remplace toute la lambda par un accès à sa définition au top-level
- `(symbol-value ',name)))
+ `(make-closure ,name ,@transitive-captures)))
((funcall :fun _ :params _*)
`(funcall ,@(mapcar (lambda (x) (transform x)) (cons fun params))))
((quote _)
expr)
- ((get-var :var $$)
- ;; chercher si var est dans (car local-env) ou bien dans global
- ;; si oui -> get-var
- ;; sinon, -> get-captured-var
- (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))))
+ ((get-var :name $$)
+ (if (member name (car globals))
+ expr
+ (let ((getter (list 'get-var name))
+ (assoc (assoc name (car getset))))
+ (unless (member name (car local-env))
+ (pushnew name (cdr local-env)))
+ (unless assoc
+ (error "squash-lisp-3-internal : Assertion failed ! ~w used as local but not in getset alist." name))
+ (push getter (cadr assoc))
+ getter)))
((setq :name $$ :value _)
- ;; comme ci-dessus
- (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)
+ (if (member name (car globals))
+ expr
+ (let ((setter (list 'setq name (transform value)))
+ (assoc (assoc name (car getset))))
+ (unless (member name (car local-env))
+ (pushnew name (cdr local-env)))
+ (unless assoc
+ (error "squash-lisp-3-internal : Assertion failed ! ~w used as local but not in getset alist." name))
+ (push setter (cddr assoc))
+ setter)))
((fdefinition (quote $$))
expr)
((symbol-value (quote $$))
expr)
- ((set :var (quote $$) :value _)
- `(set ,var ,(transform value)))
+ ((set (quote :var $$) :value _)
+ `(set ',var ,(transform value)))
(_
- (error "squash-lisp-3-internal : Assertion failed ! this should not be here : ~a" expr)))))
+ (error "squash-lisp-3-internal : Assertion failed ! this should not be here : ~w" 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)))))
-
+ `(top-level ,lsym ,globals (progn ,@(reverse (car tl))))))
-(defun squash-lisp-3-check-internal (expr)
+(defun squash-lisp-3-check-2 (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."
@@ -148,81 +152,121 @@ Attention : il y a quelques invariants qui ne sont pas présents dans cette vér
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))
+ (every #'squash-lisp-3-check-2 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)))
+ (and (squash-lisp-3-check-2 condition)
+ (squash-lisp-3-check-2 si-vrai)
+ (squash-lisp-3-check-2 si-faux)))
((unwind-protect :body _ :cleanup _)
- (and (squash-lisp-3-check-internal body)
- (squash-lisp-3-check-internal cleanup)))
+ (and (squash-lisp-3-check-2 body)
+ (squash-lisp-3-check-2 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)))
+ (and (squash-lisp-3-check-2 object)
+ (squash-lisp-3-check-2 body)
+ (squash-lisp-3-check-2 catch-code)))
((unwind :object _)
- (squash-lisp-3-check-internal object))
+ (squash-lisp-3-check-2 object))
((unwind-for-tagbody :object _ :post-unwind-code _)
- (and (squash-lisp-3-check-internal object)
- (squash-lisp-3-check-internal post-unwind-code)))
+ (and (squash-lisp-3-check-2 object)
+ (squash-lisp-3-check-2 post-unwind-code)))
((jump-label :name $$)
t)
((jump :dest $$)
t)
;; ((let ($$*) :body _)
- ;; (squash-lisp-3-check-internal body))
+ ;; (squash-lisp-3-check-2 body))
;; ((lambda (&rest $$) :unused _ :body (let ($$*) _*))
- ;; (squash-lisp-3-check-internal body))
+ ;; (squash-lisp-3-check-2 body))
((funcall :fun _ :params _*)
- (every #'squash-lisp-3-check-internal (cons fun params)))
+ (every #'squash-lisp-3-check-2 (cons fun params)))
((quote _)
t)
((get-var $$)
t)
((setq :name $$ :value _)
- (squash-lisp-3-check-internal value))
+ (squash-lisp-3-check-2 value))
((fdefinition (quote $$))
t)
((symbol-value (quote $$))
t)
((set (quote $$) :value _)
- (squash-lisp-3-check-internal value))
+ (squash-lisp-3-check-2 value))
+ ((make-closure $$ $$*)
+ t)
((make-captured-var $$)
t)
((get-captured-var $$)
t)
((set-captured-var $$ :value _)
- (squash-lisp-3-check-internal value))
+ (squash-lisp-3-check-2 value))
(_
- (warn "squash-lisp-3-check-internal: Assertion failed ! This should not be here : ~w" expr)
+ (warn "squash-lisp-3-check-2: Assertion failed ! This should not be here : ~w" expr)
+ nil)))
+
+(defun squash-lisp-3-check-1 (expr)
+ (cond-match
+ expr
+ ((set (quote $$) (lambda ($$ &rest $$) (get-var $$) (get-var $$) (let ($$*) :body _)))
+ (squash-lisp-3-check-2 body))
+ (_
+ (warn "~&squash-lisp-3-check : 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)
+ ((top-level $$ (($$*) . ($$*)) (progn :body _*))
+ (every #'squash-lisp-3-check-1 body))
+ (_ (warn "~&squash-lisp-3-check : this should not be here :~&~w" expr)
nil)))
(defun nice-squash-lisp-3-check (expr)
- (match (top-level $$ (progn
- (set $$ (lambda (&rest $$) (get-var $$)
- (let ($$*) (? squash-lisp-3-check-internal)*)))*))
+ (match (top-level $$ (($$*) . ($$*)) (progn (set '$$ (lambda ($$ &rest $$) (get-var $$) (get-var $$) (let ($$*) (? squash-lisp-3-check-2))))*))
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)))
+(defun squash-lisp-3-wrap (expr)
+ `(macrolet ((unwind-catch (object body catch-code)
+ (let ((bname (make-symbol "BLOCK")))
+ `(block ,bname
+ (catch ,object (return-from ,bname ,body))
+ ,catch-code)))
+ (tagbody-unwind-catch (object body catch-code)
+ catch-code ;; unused variable
+ ;; 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)
+ object ;; unused variable
+ post-unwind-code)
+ (top-level (main globals body)
+ globals
+ `(progn
+ ,body
+ (funcall ,main nil)))
+ (jump (dest)
+ `(go ,dest))
+ (get-var (x)
+ x)
+ (make-closure (fun &rest vars)
+ (let ((args-sym (make-symbol "AR")))
+ `(lambda (&rest ,args-sym)
+ (apply ,fun (list ,@vars) ,args-sym))))
+ (make-captured-var (x)
+ `(setq ,x (cons nil nil)))
+ (get-captured-var (x)
+ `(car ,x))
+ (set-captured-var (x v)
+ `(setf (car ,x) ,v)))
+ ,expr))
+
(require 'test-unitaire "test-unitaire")
(erase-tests squash-lisp-3)
