www

commit 9b2433d3c1f8bd05a0121ce0d56653626846d51a
parent 86d1f77faa5699234e9702ea1c86c3fbbd575c6d
Author: Georges Dupéron <jahvascriptmaniac+github@free.fr>
Date:   Sun,  9 Jan 2011 19:29:00 +0100

Adaptation de la syntaxe reconue par squash-lisp-2 pour qu'elle corresponde avec celle de squash-lisp-1.

Diffstat:
M
lisp/squash-lisp-2.lisp
 | 
16
++++++++--------

1 file changed, 8 insertions(+), 8 deletions(-)
diff --git a/lisp/squash-lisp-2.lisp b/lisp/squash-lisp-2.lisp
@@ -16,15 +16,15 @@
    ((unwind-protect :body _ :cleanup _)
     `(unwind-protect ,(squash-lisp-2 body env-var env-fun globals)
        ,(squash-lisp-2 cleanup env-var env-fun globals)))
-   ((unwind-catch :object _ :body _ :catch-code _)
-    `(unwind-catch ,(squash-lisp-2 object env-var env-fun globals)
-                   ,(squash-lisp-2 body env-var env-fun globals)
-                   ,(squash-lisp-2 catch-code env-var env-fun globals)))
+   ((:type (? (member x '(unwind-catch tagbody-unwind-catch))) :object _ :body _ :catch-code _)
+    `(,type ,(squash-lisp-2 object env-var env-fun globals)
+            ,(squash-lisp-2 body env-var env-fun globals)
+            ,(squash-lisp-2 catch-code env-var env-fun globals)))
    ((unwind :object _)
     `(unwind ,(squash-lisp-2 object env-var env-fun globals)))
-   ((half-unwind :object _ :post-unwind-code _)
-    `(half-unwind ,(squash-lisp-2 object env-var env-fun globals)
-                  ,(squash-lisp-2 post-unwind-code env-var env-fun globals)))
+   ((unwind-for-tagbody :object _ :post-unwind-code _)
+    `(unwind-for-tagbody ,(squash-lisp-2 object env-var env-fun globals)
+                         ,(squash-lisp-2 post-unwind-code env-var env-fun globals)))
    ((jump-label :name $$)
     expr)
    ((jump :dest $$)
@@ -54,7 +54,7 @@
                                       `(setq ,(cdr n) ,(squash-lisp-2 v env-var env-fun globals)))
                                     name value)
                           ,(squash-lisp-2 body env-var new-env-fun globals))))) ;; env-var -> env-fun
-   ((simple-flet ((:name $$ :value _)*) :body _)
+   ((simple-labels ((:name $$ :value _)*) :body _)
     (setq name (mapcar (lambda (x) (cons x (derived-symbol x))) name))
     (let ((new-env-fun (append name env-fun))) ;; new-env-var -> new-env-fun   +   env-var -> env-fun
       `(simple-let ,(mapcar #'cdr name)