0.7.10.15:

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

diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp
index ca00f44..d6a13e3 100644 (file)
--- a/src/code/parse-defmacro.lisp
+++ b/src/code/parse-defmacro.lisp
@@ -121,7 +121,9 @@
                      (defmacro-error "&ENVIRONMENT" error-kind name))))
              ((or (eq var '&rest)
                   (eq var '&body))
-              (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
+              (cond (restp
+                     (defmacro-error (symbol-name var) error-kind name))
+                    ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
                      (setq rest-of-args (cdr rest-of-args))
                      (setq restp t)
                      (push-let-binding (car rest-of-args) path nil))
@@ -140,8 +142,10 @@
              ((eq var '&aux)
               (setq now-processing :auxs))
              ((listp var)
-              (cond ; (since it's too early to use CASE)
-                ((eq now-processing :required)
+              (case now-processing
+                ((:required)
+                 (when restp
+                   (defmacro-error "required argument after &REST/&BODY" error-kind name))  
                  (let ((sub-list-name (gensym "SUBLIST-")))
                    (push-sub-list-binding sub-list-name `(car ,path) var
                                           name error-kind error-fun)
@@ -150,7 +154,7 @@
                  (setq path `(cdr ,path)
                        minimum (1+ minimum)
                        maximum (1+ maximum)))
-                ((eq now-processing :optionals)
+                ((:optionals)
                  (destructuring-bind (varname &optional initform supplied-p)
                      var
                    (push-optional-binding varname initform supplied-p
@@ -158,7 +162,7 @@
                                           name error-kind error-fun))
                  (setq path `(cdr ,path)
                        maximum (1+ maximum)))
-                ((eq now-processing :keywords)
+                ((:keywords)
                  (let* ((keyword-given (consp (car var)))
                         (variable (if keyword-given
                                       (cadar var)
@@ -169,33 +173,33 @@
                         (supplied-p (caddr var)))
                    (push-optional-binding variable (cadr var) supplied-p
                                           `(keyword-supplied-p ',keyword
-                                                               ,rest-name)
+                                            ,rest-name)
                                           `(lookup-keyword ',keyword
-                                                           ,rest-name)
+                                            ,rest-name)
                                           name error-kind error-fun)
                    (push keyword keys)))
-                ((eq now-processing :auxs)
+                ((:auxs)
                  (push-let-binding (car var) (cadr var) nil))))
              ((symbolp var)
-              (cond ; (too early in bootstrapping to use CASE)
-               ;; FIXME: ^ This "too early in bootstrapping" is no
-               ;; longer an issue in current SBCL bootstrapping.
-                ((eq now-processing :required)
+              (case now-processing
+                ((:required)
+                 (when restp
+                   (defmacro-error "required argument after &REST/&BODY" error-kind name))
                  (push-let-binding var `(car ,path) nil)
                  (setq minimum (1+ minimum)
                        maximum (1+ maximum)
                        path `(cdr ,path)))
-                ((eq now-processing :optionals)
+                ((:optionals)
                  (push-let-binding var `(car ,path) nil `(not (null ,path)))
                  (setq path `(cdr ,path)
                        maximum (1+ maximum)))
-                ((eq now-processing :keywords)
+                ((:keywords)
                  (let ((key (keywordicate var)))
                    (push-let-binding var
                                      `(lookup-keyword ,key ,rest-name)
                                      nil)
                    (push key keys)))
-                ((eq now-processing :auxs)
+                ((:auxs)
                  (push-let-binding var nil nil))))
              (t
               (error "non-symbol in lambda-list: ~S" var)))))
@@ -204,24 +208,25 @@
          ;; there actually is a maximum number of arguments
          ;; (expecting MAXIMUM=NIL when there is no maximum)
          (explicit-maximum (and (not restp) maximum)))
-      (push `(unless ,(if restp
-                         ;; (If RESTP, then the argument list might be
-                         ;; dotted, in which case ordinary LENGTH won't
-                         ;; work.)
-                         `(list-of-length-at-least-p ,path-0 ,minimum)
-                         `(proper-list-of-length-p ,path-0 ,minimum ,maximum))
-              ,(if (eq error-fun 'error)
-                   `(arg-count-error ',error-kind ',name ,path-0
-                                     ',lambda-list ,minimum
-                                     ,explicit-maximum)
-                   `(,error-fun 'arg-count-error
-                                :kind ',error-kind
-                                ,@(when name `(:name ',name))
-                                :args ,path-0
-                                :lambda-list ',lambda-list
-                                :minimum ,minimum
-                                :maximum ,explicit-maximum)))
-           *arg-tests*)
+      (unless (and restp (zerop minimum))
+        (push `(unless ,(if restp
+                            ;; (If RESTP, then the argument list might be
+                            ;; dotted, in which case ordinary LENGTH won't
+                            ;; work.)
+                            `(list-of-length-at-least-p ,path-0 ,minimum)
+                            `(proper-list-of-length-p ,path-0 ,minimum ,maximum))
+                 ,(if (eq error-fun 'error)
+                      `(arg-count-error ',error-kind ',name ,path-0
+                                        ',lambda-list ,minimum
+                                        ,explicit-maximum)
+                      `(,error-fun 'arg-count-error
+                                   :kind ',error-kind
+                                   ,@(when name `(:name ',name))
+                                   :args ,path-0
+                                   :lambda-list ',lambda-list
+                                   :minimum ,minimum
+                                   :maximum ,explicit-maximum)))
+              *arg-tests*))
       (when keys
        (let ((problem (gensym "KEY-PROBLEM-"))
              (info (gensym "INFO-")))
@@ -239,6 +244,18 @@
                *arg-tests*)))
       (values env-arg-used minimum explicit-maximum))))
 
+;;; We save space in macro definitions by calling this function.
+(defun arg-count-error (error-kind name args lambda-list minimum maximum)
+  (let (#-sb-xc-host
+       (sb!debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame))))
+    (error 'arg-count-error
+          :kind error-kind
+          :name name
+          :args args
+          :lambda-list lambda-list
+          :minimum minimum
+          :maximum maximum)))
+
 (defun push-sub-list-binding (variable path object name error-kind error-fun)
   (let ((var (gensym "TEMP-")))
     (push `(,variable