squash-lisp-1.lisp (28984B)
1 (require 'mini-meval "mini-meval") ;; slice-up-lambda-list, macro-expansion, eval-when 2 (require 'match "match") 3 (require 'util "match") ;; derived-symbol, assoc-or, assoc-or-push 4 5 ;; À la fin du fichier se trouvent des notes sur la compilation d'unwind & co. 6 7 ;; TODO !!! Utiliser une pile descendante, 8 ;; TODO !!! donc adapter les calculs pour unwind, 9 ;; TODO !!! sinon on n'aura pas la compatibilité x86 10 11 12 13 ;; TODO : transformer les if (cond?) en simple-tagbody 14 ;; TODO : mini-meval + squash-lisp-1 : les defmacro doivent définir une macro-fonction, pour qu'on puisse utiliser macroexpand dans le 15 ;; source passé en paramètre. donc (defmacro foo (params) body*) -> (setf (fdefinition 'foo) (lambda (params) (block foo body*))) 16 17 (defun simple-splice-up-tagbody (body) 18 "Découpe le body d'un tagbody en une liste associative ordonnée toute simple : 19 (tagbody a b (foo bar) c (baz) (quux) d) => '((a) (b (foo bar)) (c (baz) (quux)) (d))" 20 (let ((all-res nil) (res (list (make-symbol "START")))) 21 (tagbody 22 start 23 (when (endp body) 24 (push (reverse res) all-res) 25 (go end)) 26 (when (and (car body) (or (symbolp (car body)) (numberp (car body)))) 27 (push (reverse res) all-res) 28 (setq res (list (car body))) 29 (setq body (cdr body)) 30 (go start)) 31 (push (car body) res) 32 (setq body (cdr body)) 33 (go start) 34 end) 35 (reverse all-res))) 36 37 (defun squash-lisp-1 (expr &optional (at-toplevel t) (etat (list nil nil nil)) env-var env-fun (globals (cons nil nil))) 38 "Transformation 1 : 39 40 Supprime les macros, eval-when, tagbody/go, throw/catch, block/return-from, 41 transforme les appels de fonction en funcall, les constantes en quote 42 et simplifie pas mal d'autres choses. 43 44 Transformation 2 : 45 46 Transforme les let, let*, flet, labels, lambda en super-let et simple-lambda, 47 détecte les variables et fonctions globales et stocke leurs noms dans le 48 paramètre globals, qui est une paire (noms-variables . noms-fonctions), et 49 rend tous les noms locaux de fonction (flet/labels) et de 50 variables (let/let*/lambda) uniques, mais pas les globaux. 51 52 `super-let' est lui-même transformé dans la foulée en let simplifié qui ne 53 fait que déclarer les noms de variables, mais n'affecte pas de valeur 54 lui-même (les affectations sont faites avec des setq) 55 56 `at-toplevel' permet de déterminer si une expression est considérée comme 57 étant au top-level (pour les defmacro, eval-when, etc). 58 59 `etat' est l'état du compilateur (macro-expansion, eval-when avec 60 compile-time) env-var et env-fun et globals sont les environnements du code 61 compilé, utilisés pour rendre uniques tous les symboles." 62 (macrolet ((transform (expr &optional at-toplevel (etat 'etat)) `(squash-lisp-1 ,expr ,at-toplevel ,etat env-var env-fun globals))) 63 (cond-match 64 expr 65 ;; - Si on rencontre une macro définie dans l'environnement de compiler-meval, 66 ;; 1) On demande à compiler-meval d'expanser la macro sur un niveau. 67 ;; 2) On re-lance la transformation (eval-when / defmacro / appel de macro / ...) sur le résultat s'il y a a eu expansion. 68 ((:name $$ :params _*) 69 (let ((definition (assoc-etat name 'macro etat))) 70 (if definition 71 (transform (apply (cdr definition) params) at-toplevel) 72 (else)))) 73 74 ;; - Si on rencontre EVAL-WHEN, 75 ;; - Au top-level, 76 ;; - Pour chaque form du body, 77 ;; - Si la situation contient :compile-toplevel, le form est évalué dans compiler-meval. 78 ;; - Si la situation contient :load-toplevel, le form est compilé (après évaluation dans compiler-meval s'il y a lieu). 79 ;; - Lorsqu'un eval-when au top-level contient des eval-when directement sous lui, ils sont traités comme s'ils étaient directement au top-level. 80 ;; - Ailleurs 81 ;; - Si la situation contient :load-toplevel, le form est compilé 82 ((eval-when :situations ($*) :body _*) 83 (when (and at-toplevel (member :compile-toplevel situations)) 84 (mini-meval `(progn ,@body) etat)) 85 (if (member :load-toplevel situations) 86 (transform body at-toplevel) 87 (transform 'nil))) ;; on renvoie nil 88 89 ;; - Si on rencontre un defmacro (au toplevel ou ailleurs). 90 ;; - On demande à compiler-meval de l'exécuter. 91 ((defmacro :name $ :lambda-list @ :body _*) 92 (mini-meval expr etat) 93 (transform `',name)) ;; on renvoie le nom 94 95 ;; - Si on rencontre un macrolet 96 ;; - On fait une copie de l'état de compiler-meval 97 ;; - On lui demande d'exécuter les définitions 98 ;; - On évalue le body avec ce nouvel état 99 ;; - On continue avec l'ancien état 100 ((macrolet :definitions ((:name $ :lambda-list @ :mbody _*)*) :body _*) 101 (let ((get-etat (make-symbol "GET-ETAT"))) 102 (transform 103 `(progn ,@body) 104 at-toplevel 105 (mini-meval `(macrolet ,definitions ,get-etat) (push-local etat 'trapdoor 'squash-trapdoor get-etat))))) 106 107 ;; - Si on gère le symbol-macrolet 108 ;; - Le fonctionnement est le même que pour le macrolet 109 ;; - Lorsqu'on rencontre un symbole, on regarde s'il a une définition de type symbol-macrolet 110 ((symbol-macrolet . _) 111 (error "squash-lisp-1 : Symbol-macrolet n'est pas implémenté.")) 112 113 ((progn :body _*) 114 (cons 'progn (mapcar (lambda (form) (transform form at-toplevel)) body))) 115 116 ((if :condition _ :si-vrai _ :si-faux _?) 117 `(if ,(transform condition) 118 ,(transform si-vrai) 119 ,(transform (car si-faux)))) 120 121 ;; Lorsqu'on rentre dans un block, on met sur la pile un marqueur spécial avec un pointeur vers un objet créé à l'exécution. 122 ((block :block-name $$ :body _*) 123 (let ((retval-sym (make-symbol "RETVAL")) 124 (block-id-sym (make-symbol "BLOCK-ID"))) 125 (transform 126 `(let ((,retval-sym nil) 127 ;; Il y a un peu de redondance, car block-id-sym 128 ;; stocké dans le let et dans le unwind-catch 129 (,block-id-sym (cons nil nil))) 130 (unwind-catch ,block-id-sym 131 (progn ,@body) 132 ,retval-sym)) 133 nil 134 (push-local etat block-name 'squash-block-catch (cons block-id-sym retval-sym))))) 135 136 ;; Les return-from <nom> qui sont accessibles lexicalement sont remplacés par un (unwind <l'objet>) 137 ;; Unwind remonte la pile jusqu'à trouver le marqueur spécial, tout en exécutant les unwind-protect éventuels. 138 ;; Si unwind ne trouve pas le marqueur et arrive en haut de la pile, il signale une erreur et termine le programme. 139 ;; Sinon, l'exécution reprend après le block. 140 ((return-from :block-name $$ :value _) 141 (let ((association (assoc-etat block-name 'squash-block-catch etat))) 142 (unless association (error "Squash-Lisp-1 : Can't return from block ~w, it is inexistant or not lexically apparent." block-name)) 143 (transform `(progn (setq ,(cddr association) ,value) 144 (unwind ,(cadr association)))))) 145 146 ;; Le traitement de tagbody/go est similaire pour sortir d'un tag, puis on jmp directement sur le tag de destination (vu qu'il est au même niveau). 147 ((tagbody :body _*) 148 (let ((spliced-body (simple-splice-up-tagbody body)) 149 (res nil) 150 (unwind-catch-marker-sym (make-symbol "UNWIND-CATCH-MARKER-SYM")) 151 (new-etat etat) 152 (unique-label-sym nil) 153 (tagbody-id-sym (make-symbol "TAGBODY-ID"))) 154 (dolist (zone spliced-body) 155 (setq unique-label-sym (make-symbol (format nil "~a" (car zone)))) 156 (setq new-etat (push-local new-etat (car zone) 'squash-tagbody-catch (cons unwind-catch-marker-sym unique-label-sym))) 157 (setf (car zone) unique-label-sym)) 158 (transform 159 `(let ((,tagbody-id-sym (cons nil nil))) 160 (tagbody-unwind-catch ,tagbody-id-sym 161 (progn 162 ,@(progn (dolist (zone spliced-body) 163 (push `(jump-label ,(car zone)) res) 164 (push `(progn ,@(cdr zone)) res)) 165 ;; (cdr (reverse …)) pour zapper le tout premier (jump-label …) 166 (cdr (reverse res)))) 167 nil) 168 nil) 169 nil 170 new-etat))) 171 172 ((go :target (? or symbolp numberp)) 173 (let ((association (assoc-etat target 'squash-tagbody-catch etat))) 174 (unless association (error "Squash-Lisp-1 : Can't go to label ~w, it is inexistant or not lexically apparent." target)) 175 (transform `(progn (unwind-for-tagbody ,(cadr association) 176 (jump ,(cddr association))))))) 177 178 ;; Le traitement de catch/throw est similaire, sauf que le pointeur est simplement un pointeur vers l'objet utilisé pour le catch / throw. 179 ((catch :tag _ :body _*) 180 (transform `(unwind-catch ,tag (progn ,@body) singleton-catch-retval))) 181 182 ((throw :tag _ :result _) 183 (transform `(progn (setq singleton-catch-retval ,result) 184 (unwind ,tag)))) 185 186 ;; Simplification du unwind-protect 187 ((unwind-protect :body _ :a-cleanup _ :other-cleanups _+) 188 `(unwind-protect ,(transform body) 189 ,(transform `(progn ,a-cleanup ,@other-cleanups)))) 190 191 ((unwind-protect :body _ :a-cleanup _) 192 `(unwind-protect ,(transform body) 193 ,(transform a-cleanup))) 194 195 ((:type (? (member x '(unwind-catch tagbody-unwind-catch))) :object _ :body _ :catch-code _) 196 `(,type ,(transform object) 197 ,(transform body) 198 ,(transform catch-code))) 199 200 ((unwind :object _) 201 `(unwind ,(transform object))) 202 203 ((unwind-for-tagbody :object _ :post-unwind-code _) 204 `(unwind-for-tagbody ,(transform object) ,(transform post-unwind-code))) 205 206 ((jump-label :name $$) 207 expr) 208 209 ((jump :dest $$) 210 expr) 211 212 ;; Transformation des (let[*] (var1 var2 var3) …) en (let[*] ((var1 nil) (var2 nil) (var3 nil)) …) 213 ((:type (? or (eq x 'let) (eq x 'let*)) :bindings (? and consp (find-if #'symbolp x)) :body . _) 214 (transform `(,type ,(mapcar (lambda (b) (if (consp b) b `(,b nil))) bindings) ,@body))) 215 216 ((super-let :name ($$*) :stuff _*) 217 (setq name (mapcar (lambda (x) (cons x (derived-symbol x))) name)) 218 (labels ((transform-super-let (expr) 219 `(progn 220 ,@(loop 221 for (type . clause) in expr 222 when (eq type 'set) 223 collect `(setq ,(cdr (assoc (car clause) name)) ,(transform (cadr clause))) 224 else when (eq type 'use-var) 225 do (push (assoc (car clause) name) env-var) 226 else when (eq type 'use-fun) 227 do (push (assoc (car clause) name) env-fun) 228 else when (eq type 'if) 229 collect `(if ,(transform (car clause)) 230 ,(transform-super-let (cadr clause)) 231 ,(transform-super-let (caddr clause))) 232 else when (eq type 'progn) 233 collect `(progn ,@(mapcar (lambda (x) (transform x)) clause)) 234 else do (error "transform-super-let : internal error : ~a not expected here" type))))) 235 ;; Note : ce <let> ne sera pas re-transformé (sinon boucle infinie). 236 `(let ,(mapcar #'cdr name) 237 ,(transform-super-let stuff)))) 238 239 ((let ((:name $$ :value _)*) :body _*) 240 (transform 241 `(super-let ,name 242 ,@(mapcar (lambda (n v) `(set ,n ,v)) name value) 243 ,@(mapcar (lambda (n) `(use-var ,n)) name) 244 (progn ,@body)))) 245 246 (((? (eq x 'let*)) ((:name $$ :value _)*) :body _*) 247 (transform 248 `(super-let ,name 249 ,@(loop 250 for n in name 251 for v in value 252 collect `(set ,n ,v) 253 collect `(use-var ,n)) 254 (progn ,@body)))) 255 256 ((flet ((:name $$ :params @ :fbody _*)*) :body _*) 257 (transform 258 `(super-let ,name 259 ,@(mapcar (lambda (n params fbody) `(set ,n (lambda ,params (progn ,@fbody)))) name params fbody) 260 ,@(mapcar (lambda (n) `(use-fun ,n)) name) 261 (progn ,@body)))) 262 263 ((labels ((:name $$ :params @ :fbody _*)*) :body _*) 264 (transform 265 `(super-let ,name 266 ,@(mapcar (lambda (n) `(use-fun ,n)) name) 267 ,@(mapcar (lambda (n params fbody) `(set ,n (lambda ,params (progn ,@fbody)))) name params fbody) 268 (progn ,@body)))) 269 270 ;; TODO : defun 271 ;; TODO : defvar 272 ;; => TODO : global-setq 273 ;; => TODO : global-setfun 274 ;; => TODO : proclaim 275 276 ;; TODO: simplifier la lambda-list. 277 ((lambda :params _ :body _*) 278 (let* ((sliced-lambda-list (slice-up-lambda-list params)) 279 (whole-sym (derived-symbol "LAMBDA-PARAMETERS")) 280 (temp-key-sym (derived-symbol "TEMP-KEY-SYM")) 281 (fixed (cdr (assoc 'fixed sliced-lambda-list))) 282 (optional (cdr (assoc 'optional sliced-lambda-list))) 283 (rest (cdr (assoc 'rest sliced-lambda-list))) 284 (key (cdr (assoc 'key sliced-lambda-list))) 285 (other (cdr (assoc 'other sliced-lambda-list))) 286 (aux (cdr (assoc 'aux sliced-lambda-list)))) 287 (push (cons whole-sym whole-sym) env-var) 288 `(named-lambda ,(derived-symbol "ANONYMOUS-LAMBDA") (&rest ,whole-sym) 289 ,(transform whole-sym) ;; pour pas qu'il soit unused si aucun paramètre. 290 ,(transform 291 `(super-let (,@fixed 292 ,@(mapcar #'car optional) 293 ,@(remove nil (mapcar #'third optional)) 294 ,@rest 295 ,@(mapcar #'car key) 296 ,@(remove nil (mapcar #'fourth key)) 297 ,@(mapcar #'car aux) 298 ,@(if (and key (not other)) `(,temp-key-sym) nil)) 299 ,@(loop 300 for param in fixed 301 collect `(set ,param (car ,whole-sym)) 302 collect `(use-var ,param) 303 collect `(progn (setq ,whole-sym (cdr ,whole-sym)))) 304 ,@(loop 305 for (param default predicate) in optional 306 collect `(if ,whole-sym 307 ((set ,param (car ,whole-sym)) 308 (progn (setq ,whole-sym (cdr ,whole-sym))) 309 (use-var ,param) 310 ,@(if predicate `((set ,predicate t) (use-var ,predicate)) nil)) 311 ((set ,param ,default) 312 (use-var ,param) 313 ,@(if predicate `((set ,predicate nil) (use-var ,predicate)) nil)))) 314 ,@(if rest 315 `((set ,(car rest) ,whole-sym) 316 (use-var ,(car rest))) 317 nil) 318 ,@(if key 319 `(progn (if (evenp (length ,whole-sym)) nil (error "Odd number of arguments, but function has &key."))) 320 nil) 321 ,@(if key 322 (loop 323 for (keyword param default predicate) in key 324 ;; TODO : quand on a trouvé, pouvoir faire set et use-var (support de simple-tagbody & jump-label super-let) 325 collect (let ((search-key (make-symbol "SEARCH-KEY"))) 326 `((progn (simple-tagbody 327 (jump-label ,search-key) 328 (if ,temp-key-sym 329 (if (eq (car ,search-key) ,keyword) 330 ;; trouvé 331 nil 332 ;; chercher encore 333 (progn 334 (setq ,temp-key-sym (cddr ,search-key)) 335 (jump ,search-key))) 336 ;; pas trouvé 337 nil))) 338 (if ,temp-key-sym 339 ((set ,param (car ,temp-key-sym)) 340 (use-var ,param) 341 ,@(if predicate `((set predicate t) (use-var ,predicate)) nil)) 342 ((set ,param ,default) 343 (use-var ,param) 344 ,@(if predicate `((set predicate nil) (use-var ,predicate)) nil)))))) 345 nil) 346 ;; TODO : not implemented yet : vérifier s'il y a des key non autorisées. 347 ,@(loop 348 for (param val) in aux 349 collect `(set ,param ,val) 350 collect `(use-var ,param)) 351 (progn ,@body)))))) 352 353 ((function :fun (lambda . _)) 354 (transform fun)) 355 356 ((function :fun $$) 357 (if-assoc fun env-fun 358 `(get-var ,(cdr assoc)) 359 (progn 360 (pushnew fun (cdr globals)) 361 `(fdefinition ',fun)))) 362 363 ((funcall :fun _ :params _*) 364 `(funcall ,(transform fun) ,@(mapcar (lambda (x) (transform x)) params))) 365 366 ;; TODO : apply 367 ;; => TODO : définir la fonction funcall : (funcall #'funcall #'cons 1 2) 368 ;; => TODO : définir la fonction apply : (funcall #'apply #'cons '(1 2)) 369 370 ((? or numberp stringp) 371 `(quote ,expr)) 372 373 ((setq :name $$ :value _) 374 (if-assoc name env-var 375 `(setq ,(cdr assoc) ,(transform value)) 376 (progn 377 (pushnew name (car globals)) 378 `(set ',name ,(transform value))))) 379 380 ((quote _) 381 expr) 382 383 ((fdefinition (quote $$)) 384 expr) 385 386 ((symbol-value (quote $$)) 387 expr) 388 389 ((set (quote $$)) 390 expr) 391 392 ;; TODO : nil et t devraient être des defconst 393 ;; Doit être avant les symboles 394 (nil 395 ''nil) 396 397 ($$ 398 (if-assoc expr env-var 399 `(get-var ,(cdr assoc)) 400 (progn 401 (pushnew expr (car globals)) 402 `(symbol-value ',expr)))) 403 404 ;; Appels de fonction 405 ;; Doivent être après tout le monde. 406 ((:fun $$ :params _*) 407 (transform `(funcall (function ,fun) ,@params))) 408 409 ((:lambda (lambda . _) :params _*) 410 (transform `(funcall ,lambda ,@params))) 411 412 (((function :lambda (lambda . _)) :params . _) 413 (transform `(funcall ,lambda ,@params))) 414 415 (((function :name $$) :params _*) 416 (transform `(funcall (function ,name) ,@params))) 417 418 (_ 419 (error "squash-lisp-1: Not implemented yet : ~w" expr))))) 420 421 (defun squash-lisp-1-wrap (expr) 422 `(macrolet ((unwind-catch (object body catch-code) 423 (let ((bname (make-symbol "block"))) 424 `(block ,bname 425 (catch ,object (return-from ,bname ,body)) 426 ,catch-code))) 427 (tagbody-unwind-catch (object body catch-code) 428 catch-code ;; unused variable 429 ;; les (progn object) et (progn x) sert à permettre l'expansion des macros sur x 430 ;; (il est possible qu'elles ne soient pas expansées à la racine du tagbody) 431 `(tagbody (progn ,object) ,@(mapcar (lambda (x) (if (eq (car x) 'jump-label) (cadr x) (progn x))) (cdr body)))) 432 (simple-tagbody (&rest body) 433 `(tagbody ,@(mapcar (lambda (x) (if (eq (car x) 'jump-label) (cadr x) (progn x))) body))) 434 (unwind (object) 435 `(throw ,object nil)) 436 (unwind-for-tagbody (object post-unwind-code) 437 object ;; unused variable 438 post-unwind-code) 439 (named-lambda (name params &rest body) 440 name ;; unused variable 441 `(lambda ,params ,@body)) 442 ;;Les macros ne sont pas expansées à la racine d'un tagbody, donc on expanse à la main 443 ;; les jump-label lorsqu'on rencontre un tagbody-unwind-catch. 444 ;;(jump-label (name) 445 ;; name) 446 (jump (dest) 447 `(go ,dest)) 448 (get-var (x) 449 x)) 450 ,expr)) 451 452 (defun squash-lisp-1-check (expr) 453 "Vérifie si expr est bien un résultat valable de squash-lisp-1. 454 Permet aussi d'avoir une «grammaire» du simple-lisp niveau 1. 455 Attention : il y a quelques invariants qui ne sont pas présents dans cette vérification." 456 (cond-match 457 expr 458 ;; simple-tagbody est équivalent à un progn, mais nécessaire pour les macrolet. 459 (((? (member x '(progn simple-tagbody))) :body _*) 460 (every #'squash-lisp-1-check body)) 461 ((if :condition _ :si-vrai _ :si-faux _) 462 (and (squash-lisp-1-check condition) 463 (squash-lisp-1-check si-vrai) 464 (squash-lisp-1-check si-faux))) 465 ((unwind-protect :body _ :cleanup _) 466 (and (squash-lisp-1-check body) 467 (squash-lisp-1-check cleanup))) 468 ;; tagbody-unwind-catch est équivalent à unwind-catch, mais nécessaire pour les macrolet. 469 (((? (member x '(unwind-catch tagbody-unwind-catch))) :object _ :body (progn _*) :catch-code _) 470 (and (squash-lisp-1-check object) 471 (squash-lisp-1-check body) 472 (squash-lisp-1-check catch-code))) 473 ((unwind :object _) 474 (squash-lisp-1-check object)) 475 ((unwind-for-tagbody :object _ :post-unwind-code _) 476 (and (squash-lisp-1-check object) 477 (squash-lisp-1-check post-unwind-code))) 478 ((jump-label :name $$) 479 t) 480 ((jump :dest $$) 481 t) 482 ((let ($$*) :body _) 483 (squash-lisp-1-check body)) 484 ((named-lambda :name $$ (&rest $$) :unused _ :body (let ($$*) _*)) 485 (squash-lisp-1-check body)) 486 ((funcall :fun _ :params _*) 487 (every #'squash-lisp-1-check (cons fun params))) 488 ((quote _) 489 t) 490 ((get-var $$) 491 t) 492 ((setq :name $$ :value _) 493 (squash-lisp-1-check value)) 494 ((fdefinition (quote $$)) 495 t) 496 ((symbol-value (quote $$)) 497 t) 498 ((set (quote $$) :value _) 499 (squash-lisp-1-check value)) 500 (_ 501 (warn "squash-lisp-1-check: Assertion failed ! This should not be here : ~w" expr) 502 nil))) 503 504 (require 'test-unitaire "test-unitaire") 505 (erase-tests squash-lisp-1) 506 (deftest (squash-lisp-1 wrap unwind) 507 (eval (squash-lisp-1-wrap 508 '(let ((foo nil)) 509 (unwind-catch 'foo 510 (progn (push 1 foo) 511 (unwind 'foo) 512 (push 2 foo)) 513 (push 3 foo)) 514 foo))) 515 '(3 1)) 516 517 #| 518 Notes sur l'implémentation d'unwind. 519 Tous les lets qui aparaissent dans un appel de fonction sont regrouppés en un seul. Donc à un appel de fonction correspond un "gros" segment de pile. 520 Après la mise en place de ce segment de pile, le code est exécuté. 521 522 TODO / NOTE pour la suite : on peut se passer des marker-* si on peut s'assurer qu'entre un end-frame et le begin-frame qui suit, il n'y a QUE des unwind-protect, unwind-catch etc. 523 Donc uniquement des adresses de portions de code généré par le compilateur, pas de "vrais" objets, donc on est sûr qu'il n'y aura pas de confusion entre un "vrai" objet 524 et une cible mise en place par unwind-catch. 525 526 Lorsqu'on rencontre une structure de contrôle comme la suivante : 527 (unwind-catch object body catch-code) 528 529 Elle est compilée ainsi : 530 531 push @catch-code 532 [compile object] 533 push r0 534 push @marker-unwind-destination 535 [compile body] 536 pop r2 537 pop r2 538 pop r2 539 jmp @after-catch-code 540 @catch-code 541 [compile catch-code] 542 @after-catch-code 543 544 De plus, un (unwind-protect body protect-code) est compilé ainsi : 545 push @protect-code 546 push @marker-unwind-protect 547 [compile body] 548 pop r2 549 pop r2 550 jmp @after-protect-code 551 @protect-code 552 [compile protect-code] 553 jmp @start-unwind 554 @after-protect-code 555 556 (unwind-for-tagbody object post-unwind-code) est compilé ainsi : 557 [compile object] 558 jsr @find-unwind-destination 559 mov [immediate]@post-unwind-code @singleton-post-unwind-code 560 add 3 sp ;; On "re-push" l'adresse de la cible, l'objet et le marqueur, mettre 2 au lieu de 3 si on n'a pas de marqueur. 561 mov sp @singleton-unwind-destination 562 mov r1 sp ;; On remonte en haut de la pile 563 jmp @start-unwind 564 @post-unwind-code 565 [compile post-unwind-code] ;; DOIT contenir un jump ! 566 halt ;; Sinon, on quite "brutalement" 567 568 Et enfin, (unwind object) est compilé ainsi : 569 [compile object] 570 jsr @find-unwind-destination 571 mov sp @singleton-unwind-destination 572 mov r1 sp ;; On remonte en haut de la pile 573 jmp @start-unwind 574 575 Et une fonction (lambda nb-let-vars body) est compilée ainsi 576 <jsr @function> => push ip; jmp @function 577 578 @function 579 mov sp, r0 ;; begin-frame : Va avec le marker-end-frame 580 push bp 581 mov sp, bp ;; sp -> bp 582 add [nb-let-vars], sp 583 push r0 ;; Permet à unwind de sauter directement jusqu'au begin-frame. 584 push @marker-end-frame ;; On peut l'ommetre pour accélérer les appels de fonction et/ou 585 ;; quand il n'y a pas de marker-unwind-* à la suite. 586 ;; IMPORTANT : effacer tout le segment de pile _SI_ on n'utilise pas begin/end-frame 587 ;; (car sinon il peut y avoir des destinations / protect d'unwind qui traînent encore). 588 [body] 589 sub sp, [nb-let-vars + 2] ;; ERREUR ! 590 pop bp 591 592 Les "fonctions" find-unwind-destination et start-unwind : 593 594 db 0 ;; 0 = (type-number placeholder) ;; devrait être autre chose, pointeur par ex 595 @singleton-unwind-destination 596 db4 0 597 db 0 ;; 0 = (type-number placeholder) ;; devrait être autre chose, pointeur par ex 598 @singleton-post-unwind-code 599 db4 0 600 @marker-unwind-destination 601 db 0 602 db 0 ;; Toujours au moins deux octets (ou au moins 5 ? j'ai oublié…). 603 @marker-unwind-protect 604 db 0 605 db 0 ;; Toujours au moins deux octets (ou au moins 5 ? j'ai oublié…). 606 @marker-end-frame 607 db 0 608 db 0 ;; Toujours au moins deux octets (ou au moins 5 ? j'ai oublié…). 609 610 ;; fud == find-unwind-destination 611 @find-unwind-destination 612 mov sp r1 613 @fud-loop 614 cmp sp 2 ;; ??? ;; Ne pas passer en-dessous de 0. 615 jpe @unwind-not-found-error ;; Ne pas passer en-dessous de 0. 616 pop r2 617 cmp r2 @marker-end-frame 618 jeq @fud-skip-frame 619 cmp r2 @marker-unwind-destination 620 jne @fud-loop 621 pop r2 622 cmp r2 r0 623 pop r2 ;; Récupérer l'adresse de retour 624 mov @nil *sp ;; écraser l'adresse de retour avec @nil pour désactiver la cible. 625 jne @fud-loop 626 ;; fud-found 627 cmp r2 @nil ;; Cible désactivée ? 628 jeq @fud-loop 629 mov r2 @singleton-post-unwind-code 630 ret 631 632 @fud-skip-frame 633 pop r2 634 mov r2 sp 635 jmp @fud-loop 636 637 @unwind-not-found-error 638 ;; error : cant unwind to this object, the return point doesn't exist anymore. 639 ;; TODO : mettre un code d'erreur dans r2 (par exemple) 640 halt 641 642 @start-unwind 643 ;; su == start-unwind 644 @su-loop 645 cmp sp *@singleton-unwind-destination 646 jeq *@singleton-post-unwind-code ;; Fin de l'unwind, tout le monde descend ! 647 pop r0 648 cmp r0 @marker-end-frame 649 jeq @su-skip-frame 650 cmp r0 @marker-unwind-protect 651 jne @su-loop 652 pop r0 653 jmp r0 654 655 @su-skip-frame 656 pop r0 657 mov r0 sp 658 jmp @su-loop 659 660 On a donc une pile de cette forme (les vieilles données sont en haut) : 661 ** [old bp] ;; adresse = 987 662 == BP == 663 [variable foo] 664 [variable bar] 665 [variable ...] 666 [begin-frame à l'adresse 987] 667 ** [end-frame] 668 [protect-code à l'adresse 1234] 669 ** [unwind-protect] 670 [code unwind-catch à l'adresse 1111] 671 [objet] 672 ** [unwind-catch] 673 [protect-code à l'adresse 2222] 674 ** [unwind-protect] 675 [protect-code à l'adresse 3333] 676 ** [unwind-protect] 677 [code unwind-catch à l'adresse 4444] 678 [objet] 679 ** [unwind-catch] 680 [protect-code à l'adresse 5555] 681 ** [unwind-protect] 682 == SP == 683 684 |# 685 686 (provide 'squash-lisp-1)