0.8.2.34:

[sbcl.git] / src / code / parse-defmacro.lisp

diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp
index edd9323..55121c9 100644 (file)
--- a/src/code/parse-defmacro.lisp
+++ b/src/code/parse-defmacro.lisp
@@ -19,6 +19,7 @@
 (declaim (type list *system-lets*))
 (defvar *user-lets* nil) ; LET bindings that the user has explicitly supplied
 (declaim (type list *user-lets*))
+(defvar *env-var* nil) ; &ENVIRONMENT variable name
 
 ;; the default default for unsupplied &OPTIONAL and &KEY args
 (defvar *default-default* nil)
@@ -36,26 +37,33 @@
                                   (doc-string-allowed t)
                                   ((:environment env-arg-name))
                                   ((:default-default *default-default*))
-                                  (error-fun 'error))
+                                  (error-fun 'error)
+                                   (wrap-block t))
   (multiple-value-bind (forms declarations documentation)
       (parse-body body doc-string-allowed)
     (let ((*arg-tests* ())
          (*user-lets* ())
          (*system-lets* ())
-         (*ignorable-vars* ()))
+         (*ignorable-vars* ())
+          (*env-var* nil))
       (multiple-value-bind (env-arg-used minimum maximum)
          (parse-defmacro-lambda-list lambda-list arg-list-name name
                                      error-kind error-fun (not anonymousp)
-                                     nil env-arg-name)
-       (values `(let* ,(nreverse *system-lets*)
+                                     nil)
+       (values `(let* (,@(when env-arg-used
+                            `((,*env-var* ,env-arg-name)))
+                        ,@(nreverse *system-lets*))
                   ,@(when *ignorable-vars*
                       `((declare (ignorable ,@*ignorable-vars*))))
                   ,@*arg-tests*
                   (let* ,(nreverse *user-lets*)
                     ,@declarations
-                    ,@forms))
+                     ,@(if wrap-block
+                           `((block ,(fun-name-block-name name)
+                               ,@forms))
+                           forms)))
                `(,@(when (and env-arg-name (not env-arg-used))
-                     `((declare (ignore ,env-arg-name)))))
+                      `((declare (ignore ,env-arg-name)))))
                documentation
                minimum
                maximum)))))
@@ -71,8 +79,7 @@
                                   error-fun
                                   &optional
                                   toplevel
-                                  env-illegal
-                                  env-arg-name)
+                                  env-illegal)
   (let* (;; PATH is a sort of pointer into the part of the lambda list we're
         ;; considering at this point in the code. PATH-0 is the root of the
         ;; lambda list, which is the initial value of PATH.
@@ -84,6 +91,7 @@
         (maximum 0)
         (minimum 0)
         (keys ())
+        (key-seen nil)
         ;; ANSI specifies that dotted lists are "treated exactly as if the
         ;; parameter name that ends the list had appeared preceded by &rest."
         ;; We force this behavior by transforming dotted lists into ordinary
@@ -102,7 +110,7 @@
        ((null rest-of-args))
       (macrolet ((process-sublist (var sublist-name path)
                    (once-only ((var var))
-                     `(if (consp ,var)
+                     `(if (listp ,var)
                           (let ((sub-list-name (gensym ,sublist-name)))
                             (push-sub-list-binding sub-list-name ,path ,var
                                                    name error-kind error-fun)
@@ -161,10 +169,13 @@
                        (error "&ENVIRONMENT is not valid with ~S." error-kind))
                       ((not toplevel)
                        (error "&ENVIRONMENT is only valid at top level of ~
-                             lambda-list.")))
+                             lambda-list."))
+                      (env-arg-used
+                       (error "Repeated &ENVIRONMENT.")))
                 (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
                        (setq rest-of-args (cdr rest-of-args))
-                       (push-let-binding (car rest-of-args) env-arg-name nil)
+                       (check-defmacro-arg (car rest-of-args))
+                       (setq *env-var* (car rest-of-args))
                        (setq env-arg-used t))
                       (t
                        (defmacro-error "&ENVIRONMENT" error-kind name))))
@@ -182,6 +193,7 @@
                 (setq rest-name (gensym "KEYWORDS-"))
                 (push rest-name *ignorable-vars*)
                 (setq restp t)
+               (setq key-seen t)
                 (push-let-binding rest-name path t))
                (&allow-other-keys
                 (setq allow-other-keys-p t))
@@ -236,7 +248,7 @@
                                    :minimum ,minimum
                                    :maximum ,explicit-maximum)))
               *arg-tests*))
-      (when keys
+      (when key-seen
        (let ((problem (gensym "KEY-PROBLEM-"))
              (info (gensym "INFO-")))
          (push `(multiple-value-bind (,problem ,info)
@@ -266,6 +278,7 @@
           :maximum maximum)))
 
 (defun push-sub-list-binding (variable path object name error-kind error-fun)
+  (check-defmacro-arg variable)
   (let ((var (gensym "TEMP-")))
     (push `(,variable
            (let ((,var ,path))
@@ -280,6 +293,7 @@
 
 (defun push-let-binding (variable path systemp &optional condition
                                  (init-form *default-default*))
+  (check-defmacro-arg variable)
   (let ((let-form (if condition
                      `(,variable (if ,condition ,path ,init-form))
                      `(,variable ,path))))
@@ -308,6 +322,12 @@
   (error "illegal or ill-formed ~A argument in ~A~@[ ~S~]"
         problem kind name))
 
+(defun check-defmacro-arg (arg)
+  (when (or (and *env-var* (eq arg *env-var*))
+            (member arg *system-lets* :key #'car)
+            (member arg *user-lets* :key #'car))
+    (error "variable ~S occurs more than once" arg)))
+
 ;;; Determine whether KEY-LIST is a valid list of keyword/value pairs.
 ;;; Do not signal the error directly, 'cause we don't know how it
 ;;; should be signaled.