squash-lisp-3.lisp (13284B)
1 (require 'match "match") 2 3 (defun squash-lisp-3-internal (expr globals &optional (local-env (cons nil nil)) (getset (cons nil nil)) (top-level (cons nil nil))) 4 "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*. 5 6 On fusionne tous les `let' d'une `lambda' en les remontant dans un `let' unique à la racine de la `lamdba'. 7 8 [Abandonné, fait dans la compilation] On fusionne tous les `tagbody' d'une `lambda' en les remontant dans un `tagbody' unique à la 9 racine de la `lambda' ? + transformation des if en tagbody. 10 11 On sort toutes les lambdas (fonctions anonymes), on les nomme avec un symbole unique, et on les met au top-level. 12 13 local-env : car = variables locales, cdr = variables capturées." 14 (macrolet ((transform (expr &optional (local-env 'local-env)) `(squash-lisp-3-internal ,expr globals ,local-env getset top-level))) 15 (cond-match 16 expr 17 ;; simple-tagbody est équivalent à un progn, mais nécessaire pour les macrolet. 18 ((:type (? (member x '(progn simple-tagbody))) :body _*) 19 (let ((res (list 'progn)) 20 (is-tagbody (eq type 'simple-tagbody))) 21 (labels ((squash-progn (body) 22 (dolist (e body) 23 (if (and (consp e) (eq 'progn (car e))) 24 (squash-progn (cdr e)) 25 (if (and (consp e) (eq 'simple-tagbody (car e))) 26 (progn (setq is-tagbody t) 27 (squash-progn (cdr e))) 28 (push e res)))))) 29 (squash-progn (mapcar (lambda (x) (transform x)) body))) 30 ;; TODO : ici : filtrer les expressions de `res' qui sont sans effet de bord, sauf la dernière. 31 (setq res (reverse res)) 32 (setq res (append (remove ''nil (butlast res) :test #'equal) (last res))) 33 (setq res (if (cdr res) ;; res != '(progn) 34 (if (cddr res) ;; res != '(progn single-expr) 35 res 36 (cadr res)) 37 '(quote nil))) 38 (when is-tagbody (setf (car res) 'simple-tagbody)) 39 res)) 40 ((if :condition _ :si-vrai _ :si-faux _) 41 `(if ,(transform condition) 42 ,(transform si-vrai) 43 ,(transform si-faux))) 44 ((unwind-protect :body _ :cleanup _) 45 `(unwind-protect ,(transform body) 46 ,(transform cleanup))) 47 ;; tagbody-unwind-catch est équivalent à unwind-catch, mais nécessaire pour les macrolet. 48 ((:type (? (member x '(unwind-catch tagbody-unwind-catch))) :object _ :body (progn _*) :catch-code _) 49 `(,type ,(transform object) 50 ,(transform body) 51 ,(transform catch-code))) 52 ((unwind :object _) 53 `(unwind ,(transform object))) 54 ((unwind-for-tagbody :object _ :post-unwind-code _) 55 `(unwind-for-tagbody ,(transform object) 56 ,(transform post-unwind-code))) 57 ((jump-label :name $$) 58 expr) 59 ((jump :dest $$) 60 expr) 61 ((let :vars ($$*) :body _) 62 (setf (car local-env) (append vars (car local-env))) 63 (dolist (v vars) 64 (when (assoc v (car getset)) 65 (error "squash-lisp-3-internal : Assertion failed ! Duplicate definition of ~w" v)) 66 (push (cons v (cons nil nil)) (car getset))) 67 (transform body)) 68 ((named-lambda :name $$ :params (&rest :params-sym $$) :unused _ :body (let ($$*) _*)) 69 (let* ((closure-sym (derived-symbol "CLOSURE")) 70 (new-local-env (progn (push (cons params-sym (cons nil nil)) (car getset)) 71 (push (cons closure-sym (cons nil nil)) (car getset)) 72 (cons (list closure-sym params-sym) nil))) 73 (tbody (transform body new-local-env)) 74 (transitive-captures nil) 75 (here-captures nil)) 76 ;; on "nomme" la lambda, et ce nom est global 77 (push name (car globals)) 78 ;; on transforme les get-var de variables capturées en get-captured-var 79 (dolist (cap (cdr new-local-env)) 80 (unless (or (member cap here-captures) (member cap transitive-captures)) 81 (if (member cap (car new-local-env)) 82 (let ((gs (assoc cap (car getset)))) 83 (unless gs (error "squash-lisp-3-internal : Assertion failed ! ~w is captured, but not in getset." cap)) 84 (dolist (getter (cadr gs)) 85 (setf (car getter) 'get-captured-var)) 86 (dolist (setter (cddr gs)) 87 (setf (car setter) 'set-captured-var)) 88 (push cap here-captures)) 89 (progn 90 (push cap (cdr local-env)) 91 (push cap transitive-captures))))) 92 ;; on construit la lambda au top-level 93 (push `(set ',name (lambda (,closure-sym &rest ,params-sym) (get-var ,closure-sym) ,unused 94 (let (,@(remove closure-sym (remove params-sym (car new-local-env))) 95 ,@transitive-captures) 96 (progn 97 ,@(mapcar (lambda (x) `(make-captured-var ,x)) here-captures) 98 ,@(loop for x in transitive-captures 99 collect `(setq ,x (funcall (fdefinition 'car) (get-var ,closure-sym))) 100 collect `(setq ,closure-sym (funcall (fdefinition 'cdr) (get-var ,closure-sym)))) 101 ,tbody)))) 102 (car top-level)) 103 ;; on remplace toute la lambda par un accès à sa définition au top-level 104 `(make-closure ,name ,@transitive-captures))) 105 ((funcall :fun _ :params _*) 106 `(funcall ,@(mapcar (lambda (x) (transform x)) (cons fun params)))) 107 ((quote _) 108 expr) 109 ((get-var :name $$) 110 (if (member name (car globals)) 111 expr 112 (let ((getter (list 'get-var name)) 113 (assoc (assoc name (car getset)))) 114 (unless (member name (car local-env)) 115 (pushnew name (cdr local-env))) 116 (unless assoc 117 (error "squash-lisp-3-internal : Assertion failed ! ~w used as local but not in getset alist." name)) 118 (push getter (cadr assoc)) 119 getter))) 120 ((setq :name $$ :value _) 121 (if (member name (car globals)) 122 expr 123 (let ((setter (list 'setq name (transform value))) 124 (assoc (assoc name (car getset)))) 125 (unless (member name (car local-env)) 126 (pushnew name (cdr local-env))) 127 (unless assoc 128 (error "squash-lisp-3-internal : Assertion failed ! ~w used as local but not in getset alist." name)) 129 (push setter (cddr assoc)) 130 setter))) 131 ((fdefinition (quote $$)) 132 expr) 133 ((symbol-value (quote $$)) 134 expr) 135 ((set (quote :var $$) :value _) 136 `(set ',var ,(transform value))) 137 (_ 138 (error "squash-lisp-3-internal : Assertion failed ! this should not be here : ~w" expr))))) 139 140 (defun squash-lisp-3 (expr globals) 141 (let* ((tl (cons nil nil)) 142 (lsym (make-symbol "MAIN")) 143 (psym (make-symbol "NO-PARAMETERS"))) 144 (squash-lisp-3-internal `(named-lambda ,lsym (&rest ,psym) (get-var ,psym) (let () ,expr)) globals (cons nil nil) (cons nil nil) tl) 145 `(top-level ,lsym ,globals (progn ,@(reverse (car tl)))))) 146 147 (defun squash-lisp-3-check-2 (expr) 148 "Vérifie si expr est bien un résultat valable de squash-lisp-1. 149 Permet aussi d'avoir une «grammaire» du simple-lisp niveau 1. 150 Attention : il y a quelques invariants qui ne sont pas présents dans cette vérification." 151 (cond-match 152 expr 153 ;; simple-tagbody est équivalent à un progn, mais nécessaire pour les macrolet. 154 (((? (member x '(progn simple-tagbody))) :body _*) 155 (every #'squash-lisp-3-check-2 body)) 156 ((if :condition _ :si-vrai _ :si-faux _) 157 (and (squash-lisp-3-check-2 condition) 158 (squash-lisp-3-check-2 si-vrai) 159 (squash-lisp-3-check-2 si-faux))) 160 ((unwind-protect :body _ :cleanup _) 161 (and (squash-lisp-3-check-2 body) 162 (squash-lisp-3-check-2 cleanup))) 163 ;; tagbody-unwind-catch est équivalent à unwind-catch, mais nécessaire pour les macrolet. 164 (((? (member x '(unwind-catch tagbody-unwind-catch))) :object _ :body (progn _*) :catch-code _) 165 (and (squash-lisp-3-check-2 object) 166 (squash-lisp-3-check-2 body) 167 (squash-lisp-3-check-2 catch-code))) 168 ((unwind :object _) 169 (squash-lisp-3-check-2 object)) 170 ((unwind-for-tagbody :object _ :post-unwind-code _) 171 (and (squash-lisp-3-check-2 object) 172 (squash-lisp-3-check-2 post-unwind-code))) 173 ((jump-label :name $$) 174 t) 175 ((jump :dest $$) 176 t) 177 ;; ((let ($$*) :body _) 178 ;; (squash-lisp-3-check-2 body)) 179 ;; ((lambda (&rest $$) :unused _ :body (let ($$*) _*)) 180 ;; (squash-lisp-3-check-2 body)) 181 ((funcall :fun _ :params _*) 182 (every #'squash-lisp-3-check-2 (cons fun params))) 183 ((quote _) 184 t) 185 ((get-var $$) 186 t) 187 ((setq :name $$ :value _) 188 (squash-lisp-3-check-2 value)) 189 ((fdefinition (quote $$)) 190 t) 191 ((symbol-value (quote $$)) 192 t) 193 ((set (quote $$) :value _) 194 (squash-lisp-3-check-2 value)) 195 ((make-closure $$ $$*) 196 t) 197 ((make-captured-var $$) 198 t) 199 ((get-captured-var $$) 200 t) 201 ((set-captured-var $$ :value _) 202 (squash-lisp-3-check-2 value)) 203 (_ 204 (warn "squash-lisp-3-check-2: Assertion failed ! This should not be here : ~w" expr) 205 nil))) 206 207 (defun squash-lisp-3-check-1 (expr) 208 (cond-match 209 expr 210 ((set (quote $$) (lambda ($$ &rest $$) (get-var $$) (get-var $$) (let ($$*) :body _))) 211 (squash-lisp-3-check-2 body)) 212 (_ 213 (warn "~&squash-lisp-3-check : this should not be here :~&~w" expr) 214 nil))) 215 216 (defun squash-lisp-3-check (expr) 217 (cond-match expr 218 ((top-level $$ (($$*) . ($$*)) (progn :body _*)) 219 (every #'squash-lisp-3-check-1 body)) 220 (_ (warn "~&squash-lisp-3-check : this should not be here :~&~w" expr) 221 nil))) 222 223 (defun nice-squash-lisp-3-check (expr) 224 (match (top-level $$ (($$*) . ($$*)) (progn (set '$$ (lambda ($$ &rest $$) (get-var $$) (get-var $$) (let ($$*) (? squash-lisp-3-check-2))))*)) 225 expr)) 226 227 (defun squash-lisp-1+3 (expr &optional (etat (list nil nil nil))) 228 (let ((globals (cons nil nil))) 229 (squash-lisp-3 (squash-lisp-1 expr t etat nil nil globals) globals))) 230 231 (defun squash-lisp-3-wrap (expr) 232 `(macrolet ((unwind-catch (object body catch-code) 233 (let ((bname (make-symbol "BLOCK"))) 234 `(block ,bname 235 (catch ,object (return-from ,bname ,body)) 236 ,catch-code))) 237 (tagbody-unwind-catch (object body catch-code) 238 catch-code ;; unused variable 239 ;; les (progn object) et (progn x) sert à permettre l'expansion des macros sur x 240 ;; (il est possible qu'elles ne soient pas expansées à la racine du tagbody) 241 `(tagbody (progn ,object) ,@(mapcar (lambda (x) (if (eq (car x) 'jump-label) (cadr x) (progn x))) (cdr body)))) 242 (simple-tagbody (&rest body) 243 `(tagbody ,@(mapcar (lambda (x) (if (eq (car x) 'jump-label) (cadr x) (progn x))) body))) 244 (unwind (object) 245 `(throw ,object nil)) 246 (unwind-for-tagbody (object post-unwind-code) 247 object ;; unused variable 248 post-unwind-code) 249 (top-level (main globals body) 250 globals 251 `(progn 252 ,body 253 (funcall ,main nil))) 254 (jump (dest) 255 `(go ,dest)) 256 (get-var (x) 257 x) 258 (make-closure (fun &rest vars) 259 (let ((args-sym (make-symbol "AR"))) 260 `(lambda (&rest ,args-sym) 261 (apply ,fun (list ,@vars) ,args-sym)))) 262 (make-captured-var (x) 263 `(setq ,x (cons nil nil))) 264 (get-captured-var (x) 265 `(car ,x)) 266 (set-captured-var (x v) 267 `(setf (car ,x) ,v))) 268 ,expr)) 269 270 (require 'test-unitaire "test-unitaire") 271 (erase-tests squash-lisp-3) 272 273 (deftest (squash-lisp-3 internal progn) 274 (squash-lisp-3-internal '(progn 275 (progn (progn) (progn)) 276 (progn) 277 (progn (progn) (progn) (progn))) 278 '(nil . nil)) 279 ''nil) 280 281 (deftest (squash-lisp-3 internal progn) 282 (squash-lisp-3-internal '(progn) '(nil . nil)) 283 ''nil) 284 285 (deftest (squash-lisp-3 internal progn) 286 (squash-lisp-3-internal '(progn (symbol-value 'a)) '((a) . nil)) 287 '(symbol-value 'a)) 288 289 (deftest (squash-lisp-3 internal progn) 290 (squash-lisp-3-internal '(progn 291 (progn (progn (symbol-value 'a)) (progn)) 292 (progn) 293 (progn (progn) (progn) (progn))) 294 '((a) . nil)) 295 '(progn (symbol-value 'a) 'nil)) 296 297 ;(run-tests squash-lisp-3)