diff --git a/implementation/mini-meval.lisp b/implementation/mini-meval.lisp index 0866051..d832898 100644 --- a/implementation/mini-meval.lisp +++ b/implementation/mini-meval.lisp @@ -1,6 +1,10 @@ (require 'match "match") (require 'util "util") +;; TODO : Quand l'ancienne valeur d'une variable spéciale est sauvegardée par un let, si il y a un throw pendant ce temps-là, elle n'est pas restaurée. +;; CLTL 7.11 : Intervening dynamic bindings of special variables and catch tags are undone. +;; TODO : Les variables spéciales ne sont probablement pas correctement capturées par un lambda. + (defmacro etat-local (etat) `(car ,etat)) @@ -260,7 +264,7 @@ (defun splice-up-tagbody-1 (todo-body body result) (if (endp todo-body) (acons nil body result) - (if (symbolp (car todo-body)) + (if (or (symbolp (car todo-body)) (numberp (car todo-body))) (splice-up-tagbody-1 (cdr todo-body) body (acons (car todo-body) body result)) @@ -717,7 +721,11 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau 1) (deftest (mini-meval tagbody) - (mini-meval '(tagbody foo 1 bar 2 baz 3)) + (mini-meval '(let ((x 0)) (tagbody foo (setq x 1) (go 42) bar (setq x 2) 42) x)) + 1) + +(deftest (mini-meval tagbody) + (mini-meval '(tagbody foo (list 1) 42 (list 2) baz (list 3))) nil) (deftest (mini-meval block) diff --git a/implementation/squash-lisp.lisp b/implementation/squash-lisp.lisp index f71be1f..22d6059 100644 --- a/implementation/squash-lisp.lisp +++ b/implementation/squash-lisp.lisp @@ -11,7 +11,7 @@ (when (endp body) (push (reverse res) all-res) (go end)) - (when (and (car body) (symbolp (car body))) + (when (and (car body) (or (symbolp (car body)) (numberp (car body)))) (push (reverse res) all-res) (setq res (list (car body))) (setq body (cdr body)) @@ -118,26 +118,29 @@ (the-body nil) (unwind-catch-marker-sym (make-symbol "UNWIND-CATCH-MARKER-SYM")) (new-etat etat) - (unique-label-sym nil) + (unique-label-sym nil)) (dolist (zone spliced-body) (setq unique-label-sym (make-symbol (format nil "~a" (car zone)))) (setq new-etat (push-local new-etat (car zone) 'squash-tagbody-catch (cons unwind-catch-marker-sym unique-label-sym))) (setf (car zone) unique-label-sym)) ;; Définition de (unwind-catch name &rest body) : ;; `(let ((,name (make-unwind-marker))) ,body) - `(unwind-catch ,unwind-catch-marker-sym - ,@(progn (dolist (zone spliced-body) - (setq the-body ,@) - (push `(tagbody-label (car zone)) res) - (push (squash-lisp `(progn (cdr zone)) new-etat) res)) - `(simple-tagbody ,@(cdr (reverse res)))))))) ;; cdr pour zapper le tout premier (tagbody-label) - + `(let ((,unwind-catch-marker-sym (make-unwind-marker))) + (unwind-catch ,unwind-catch-marker-sym + ,@(progn (dolist (zone spliced-body) + (setq the-body ,@) + (push `(tagbody-label (car zone)) res) + (push (squash-lisp `(progn (cdr zone)) new-etat) res)) + `(simple-tagbody ,@(cdr (reverse res))))))))) ;; cdr pour zapper le tout premier (tagbody-label) + ((go :target $$) (let ((association (assoc-etat target 'squash-tagbody-catch etat))) (unless association (error "Squash-Lisp : Can't go to label ~w, it is inexistant or not lexically apparent." target)) `(progn (unwind ,(cadr association)) (simple-go ,(cddr association))))) ;; Le traitement de catch/throw est similaire, sauf que le pointeur est simplement un pointeur vers l'objet utilisé pour le catch / throw. + ((catch :tag tag :body _*) + ;; Les constantes sont renvoyées telles qu'elles ((? or numberp stringp)