0.8.17.4: Stricter lambda list parsing
authorNikodemus Siivola <nikodemus@random-state.net>
Tue, 30 Nov 2004 11:21:42 +0000 (11:21 +0000)
committerNikodemus Siivola <nikodemus@random-state.net>
Tue, 30 Nov 2004 11:21:42 +0000 (11:21 +0000)
           * Order of &AUX vs. &KEY/&REST in destructuring
              lambda lists, check for multiple &optional, etc.
           * Resignal errors from macroexpansion before converting
              to COMPILED-PROGRAM-ERROR so that user code that
              wants to handle them can.

NEWS
src/code/parse-defmacro.lisp
src/compiler/ir1tran.lisp
src/compiler/main.lisp
src/compiler/parse-lambda-list.lisp
tests/lambda-list.pure.lisp [new file with mode: 0644]
version.lisp-expr

diff --git a/NEWS b/NEWS
index a86e5ba..f411ace 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -3,6 +3,8 @@ changes in sbcl-0.8.18 relative to sbcl-0.8.17:
     LOAD-SHARED-OBJECT now causes the new definitions to take effect.
   * fixed bug #331: structure-class instances corresponding to
     DEFSTRUCT forms are now created eagerly.
+  * bug fix: lambda-list parsing is now stricter vrt. order and number
+    of lambda-list keywords.
 
 changes in sbcl-0.8.17 relative to sbcl-0.8.16:
   * new feature: a build-time option (controlled by the :SB-UNICODE
index d963671..b783de5 100644 (file)
@@ -92,6 +92,8 @@
         (minimum 0)
         (keys ())
         (key-seen nil)
+         (aux-seen nil)
+         (optional-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
              (case now-processing
                ((:required)
                 (when restp
-                  (defmacro-error "required argument after &REST/&BODY"
+                  (defmacro-error (format nil "required argument after ~A" restp)
                       context name))
                 (process-sublist var "SUBLIST-" `(car ,path))
                 (setq path `(cdr ,path)
                 (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
                        (setq rest-of-args (cdr rest-of-args))
                        (check-defmacro-arg (car rest-of-args))
-                       (setq *env-var* (car rest-of-args))
-                       (setq env-arg-used t))
+                       (setq *env-var* (car rest-of-args)
+                             env-arg-used t))
                       (t
                        (defmacro-error "&ENVIRONMENT" context name))))
                ((&rest &body)
-                (cond ((and (not restp) (cdr rest-of-args))
-                       (setq rest-of-args (cdr rest-of-args))
-                       (setq restp t)
+                (cond ((or key-seen aux-seen)
+                       (error "~A after ~A in ~A" var (or key-seen aux-seen) context))
+                      ((and (not restp) (cdr rest-of-args))
+                       (setq rest-of-args (cdr rest-of-args)
+                             restp var)
                        (process-sublist (car rest-of-args) "REST-LIST-" path))
                       (t
                        (defmacro-error (symbol-name var) context name))))
                (&optional
-                (setq now-processing :optionals))
+                (when (or key-seen aux-seen restp)
+                  (error "~A after ~A in ~A lambda-list." var (or key-seen aux-seen restp) context))
+                (when optional-seen
+                  (error "Multiple ~A in ~A lambda list." var context))
+                (setq now-processing :optionals
+                      optional-seen var))
                (&key
-                (setq now-processing :keywords)
-                (setq rest-name (gensym "KEYWORDS-"))
+                (when aux-seen
+                  (error "~A after ~A in ~A lambda-list." '&key '&aux context))
+                (when key-seen
+                  (error "Multiple ~A in ~A lambda-list." '&key context))
+                (setf now-processing :keywords
+                      rest-name (gensym "KEYWORDS-")
+                      restp var
+                      key-seen var)
                 (push rest-name *ignorable-vars*)
-                (setq restp t)
-               (setq key-seen t)
                 (push-let-binding rest-name path t))
                (&allow-other-keys
+                (unless (eq now-processing :keywords)
+                  (error "~A outside ~A section of lambda-list in ~A." var '&key context))
+                (when allow-other-keys-p
+                  (error "Multiple ~A in ~A lambda-list." var context))
                 (setq allow-other-keys-p t))
                (&aux
-                (setq now-processing :auxs))
+                (when aux-seen
+                  (error "Multiple ~A in ~A lambda-list." '&aux context))
+                (setq now-processing :auxs
+                      aux-seen var))
                ;; FIXME: Other lambda list keywords.
                (t
                 (case now-processing
                   ((:required)
                    (when restp
-                     (defmacro-error "required argument after &REST/&BODY"
+                     (defmacro-error (format nil "required argument after ~A" restp)
                          context name))
                    (push-let-binding var `(car ,path) nil)
                    (setq minimum (1+ minimum)
index 45b1de9..a7355de 100644 (file)
                                      (wherestring) hint c)
                                (muffle-warning-or-die)))
                      (error (lambda (c)
+                              (signal c)
                               (compiler-error "~@<~A~:@_~A~@:_~A~:>"
                                               (wherestring) hint c))))
         (funcall sb!xc:*macroexpand-hook* fun form *lexenv*)))))
index efb342c..aabf3da 100644 (file)
 (defun preprocessor-macroexpand-1 (form)
   (handler-case (sb!xc:macroexpand-1 form *lexenv*)
     (error (condition)
+      (signal condition)
       (compiler-error "(during macroexpansion of ~A)~%~A"
                      (let ((*print-level* 1)
                            (*print-length* 2))
index 31d7f5c..6109cbd 100644 (file)
               (&aux
                (when (member state '(:rest :more-context :more-count))
                  (compiler-error "misplaced &AUX in lambda list: ~S" list))
+               (when auxp
+                 (compiler-error "multiple &AUX in lambda list: ~S" list))
                (setq auxp t
                     state :aux))
               (t (bug "unknown LAMBDA-LIST-KEYWORD in lambda list: ~S." arg)))
diff --git a/tests/lambda-list.pure.lisp b/tests/lambda-list.pure.lisp
new file mode 100644 (file)
index 0000000..3f202d7
--- /dev/null
@@ -0,0 +1,34 @@
+;;;; lambda-list parsing tests with no side-effects
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;; 
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(macrolet ((error-p (ll)
+             `(progn
+                (multiple-value-bind (result error) (ignore-errors (handler-bind ((error #'error))
+                                                                     (eval `(lambda ,',ll 'ok))))
+                  (unless (and (not result) error)
+                    (error "No error from lambda ~S." ',ll)))
+                (multiple-value-bind (result error) (ignore-errors (handler-bind ((error #'error))
+                                                                     (eval `(lambda (x) (destructuring-bind ,',ll x 'ok)))))
+                  (unless (and (not result) error)
+                    (error "No error from d-b ~S." ',ll))))))
+  (error-p (&aux (foo 1) &aux (bar 2)))
+  (error-p (&aux (foo 1) &key bar))
+  (error-p (&aux (foo 1) &optional bar))
+  (error-p (&aux (foo 1) &rest bar))
+  (error-p (&key foo &allow-other-keys &allow-other-keys))
+  (error-p (&key foo &key bar))
+  (error-p (&key foo &optional bar))
+  (error-p (&key foo &rest bar))
+  (error-p (&optional foo &optional bar))
+  (error-p (&rest foo &rest bar))
+  (error-p (&rest foo &optional bar)))
index 7a1910a..2bd7e11 100644 (file)
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.17.3"
+"0.8.17.4"