From 9f684145a95d4abbde75422edb8b217dfad3375b Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Tue, 30 Nov 2004 11:21:42 +0000 Subject: [PATCH] 0.8.17.4: Stricter lambda list parsing * 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 | 2 ++ src/code/parse-defmacro.lisp | 46 +++++++++++++++++++++++++---------- src/compiler/ir1tran.lisp | 1 + src/compiler/main.lisp | 1 + src/compiler/parse-lambda-list.lisp | 2 ++ tests/lambda-list.pure.lisp | 34 ++++++++++++++++++++++++++ version.lisp-expr | 2 +- 7 files changed, 74 insertions(+), 14 deletions(-) create mode 100644 tests/lambda-list.pure.lisp diff --git a/NEWS b/NEWS index a86e5ba..f411ace 100644 --- 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 diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp index d963671..b783de5 100644 --- a/src/code/parse-defmacro.lisp +++ b/src/code/parse-defmacro.lisp @@ -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 @@ -126,7 +128,7 @@ (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) @@ -192,36 +194,54 @@ (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) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 45b1de9..a7355de 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -749,6 +749,7 @@ (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*))))) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index efb342c..aabf3da 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -846,6 +846,7 @@ (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)) diff --git a/src/compiler/parse-lambda-list.lisp b/src/compiler/parse-lambda-list.lisp index 31d7f5c..6109cbd 100644 --- a/src/compiler/parse-lambda-list.lisp +++ b/src/compiler/parse-lambda-list.lisp @@ -100,6 +100,8 @@ (&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 index 0000000..3f202d7 --- /dev/null +++ b/tests/lambda-list.pure.lisp @@ -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))) diff --git a/version.lisp-expr b/version.lisp-expr index 7a1910a..2bd7e11 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -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" -- 1.7.10.4