www

commit a3876957b801058a07ab5d7a9e062988acdf184e
parent c729c7d2a924692c9797319f027113e09ded42f3
Author: Georges Dupéron <jahvascriptmaniac+github@free.fr>
Date:   Tue, 30 Nov 2010 18:51:19 +0100

Ratés sur l'implémentation des tagbodu/go throw/catch block/return-from .

Diffstat:
M
implementation/mini-meval.lisp
 | 
12
++++++++++--
M
implementation/squash-lisp.lisp
 | 
21
++++++++++++---------

2 files changed, 22 insertions(+), 11 deletions(-)
diff --git 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
@@ -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)