From 6ae28ef0c5931bb37fff21586886e7b63d78cbbd Mon Sep 17 00:00:00 2001
From: Stelian Ionescu <sionescu@common-lisp.net>
Date: Fri, 15 Aug 2008 20:27:25 +0200
Subject: [PATCH] Add LAMBDA*.

Signed-off-by: Stelian Ionescu <sionescu@common-lisp.net>
---
 base/pkgdcl.lisp      |  2 +-
 base/return-star.lisp | 37 +++++++++++++++++++++----------------
 2 files changed, 22 insertions(+), 17 deletions(-)

diff --git a/base/pkgdcl.lisp b/base/pkgdcl.lisp
index bfe9b20..ac65d35 100644
--- a/base/pkgdcl.lisp
+++ b/base/pkgdcl.lisp
@@ -9,7 +9,7 @@
   (:use #:common-lisp :alexandria)
   (:shadow #:defun #:defmethod
            #:defmacro #:define-compiler-macro)
-  (:export #:return* #:defun #:defmethod
+  (:export #:return* #:lambda* #:defun #:defmethod
            #:defmacro #:define-compiler-macro))
 
 (flet ((gather-external-symbols (&rest packages)
diff --git a/base/return-star.lisp b/base/return-star.lisp
index 2da6965..b810a14 100644
--- a/base/return-star.lisp
+++ b/base/return-star.lisp
@@ -7,7 +7,7 @@
 
 (cl:defmacro defun (name args &body body)
   `(,(find-right-symbol :defun :series)
-     ,name ,args ,@(wrap-body-for-return-star body)))
+     ,name ,args ,@(wrap-body-for-return-star body name)))
 
 (cl:defmacro defmethod (name method-qualifier args &body body)
   (cond
@@ -16,18 +16,22 @@
      (setf body (cons args body)
            args method-qualifier)
      `(,(find-right-symbol :defmethod)
-        ,name ,args ,@(wrap-body-for-return-star body)))
+        ,name ,args ,@(wrap-body-for-return-star body name)))
     (t
      `(,(find-right-symbol :defmethod) ,name
-        ,method-qualifier ,args ,@(wrap-body-for-return-star body)))))
+        ,method-qualifier ,args ,@(wrap-body-for-return-star body name)))))
+
+(cl:defmacro lambda* (args &body body)
+  `(,(find-right-symbol :lambda)
+     ,args ,@(wrap-body-for-return-star body)))
 
 (cl:defmacro defmacro (name args &body body)
   `(,(find-right-symbol :defmacro)
-     ,name ,args ,@(wrap-body-for-return-star body)))
+     ,name ,args ,@(wrap-body-for-return-star body name)))
 
 (cl:defmacro define-compiler-macro (name args &body body)
   `(,(find-right-symbol :define-compiler-macro)
-     ,name ,args ,@(wrap-body-for-return-star body)))
+     ,name ,args ,@(wrap-body-for-return-star body name)))
 
 (cl:defun find-right-symbol (name &rest packages)
   (multiple-value-bind (symbol foundp)
@@ -48,16 +52,17 @@
                   :test #'string-equal)
       (return pkg))))
 
-(cl:defun wrap-body-for-return-star (body)
+(cl:defun wrap-body-for-return-star (body &optional block-name)
   (multiple-value-bind (body declarations docstring)
       (parse-body body :documentation t)
-    (with-gensyms (return-star-block)
-      (remove-if
-       #'null
-       `(,docstring
-         ,@declarations
-         (block ,return-star-block
-           (macrolet
-               ((return* (value)
-                  `(return-from ,',return-star-block ,value)))
-             ,@body)))))))
+    (remove-if
+     #'null
+     `(,docstring
+       ,@declarations
+       ,(if block-name
+            `(macrolet ((return* (value) `(return-from ,',block-name ,value)))
+               ,@body)
+            (with-gensyms (block-name)
+              `(block ,block-name
+                 (macrolet ((return* (value) `(return-from ,',block-name ,value)))
+                   ,@body))))))))
-- 
2.11.4.GIT