From ffb72508319fedfb3827adc47e6ef98b7d8b2736 Mon Sep 17 00:00:00 2001 From: Jan Moringen Date: Mon, 17 Jul 2017 01:21:06 +0200 Subject: [PATCH] Better lambda list checking in DEFMETHOD --- src/compiler/info-functions.lisp | 8 +++---- src/compiler/ir1tran-lambda.lisp | 2 +- src/pcl/boot.lisp | 47 +++++++++++++++++++++++++--------------- tests/clos.impure.lisp | 26 ++++++++++++++++++++++ 4 files changed, 60 insertions(+), 23 deletions(-) diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp index 2aef27a1a..e8b59a8be 100644 --- a/src/compiler/info-functions.lisp +++ b/src/compiler/info-functions.lisp @@ -19,11 +19,11 @@ ;;;; internal utilities defined in terms of INFO -(defun check-variable-name (name &optional (context "local variable")) +(defun check-variable-name (name &key (context "local variable") (signal-via #'compiler-error)) (unless (legal-variable-name-p name) - (compiler-error "~@<~S is ~:[not a symbol~;a keyword~] and cannot ~ - be used as a ~A.~@:>" - name (keywordp name) context)) + (funcall signal-via "~@<~S is ~:[not a symbol~;a keyword~] and ~ + cannot be used as a ~A.~@:>" + name (keywordp name) context)) name) ;;; Check that NAME is a valid function name, returning the name if diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index ad5e71a85..010689b27 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -46,7 +46,7 @@ (allow-special t) (allow-symbol-macro t) (signal-via #'compiler-error)) - (check-variable-name name) + (check-variable-name name :signal-via signal-via) (flet ((lose (kind) (funcall signal-via #+xc-host "~@<~/sb!impl:print-symbol-with-prefix/ names a ~ diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 6336a7676..2cc92ceca 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -2910,29 +2910,40 @@ bootstrapping. () (:default-initargs :references (list '(:ansi-cl :section (3 4 3))))) +(defun specialized-lambda-list-error (format-control &rest format-arguments) + (error 'specialized-lambda-list-error + :format-control format-control + :format-arguments format-arguments)) + ;; Return 3 values: ;; - the bound variables, without defaults, supplied-p vars, or &AUX vars. ;; - the lambda list without specializers. ;; - just the specializers (defun parse-specialized-lambda-list (arglist) - (multiple-value-bind (llks specialized optional rest key aux) - (parse-lambda-list - arglist - :context 'defmethod - :accept (lambda-list-keyword-mask - '(&optional &rest &key &allow-other-keys &aux)) - :silent t ; never signal &OPTIONAL + &KEY style-warning - :condition-class 'specialized-lambda-list-error) - (let ((required (mapcar (lambda (x) (if (listp x) (car x) x)) specialized))) - (values (append required - (mapcar #'parse-optional-arg-spec optional) - rest - ;; Preserve keyword-names when given as (:KEYWORD var) - (mapcar (lambda (x) (if (typep x '(cons cons)) - (car x) - (parse-key-arg-spec x))) key)) - (make-lambda-list llks nil required optional rest key aux) - (mapcar (lambda (x) (if (listp x) (cadr x) t)) specialized))))) + (binding* (((llks specialized optional rest key aux) + (parse-lambda-list + arglist + :context 'defmethod + :accept (lambda-list-keyword-mask + '(&optional &rest &key &allow-other-keys &aux)) + :silent t ; never signal &OPTIONAL + &KEY style-warning + :condition-class 'specialized-lambda-list-error)) + (required (mapcar (lambda (x) (if (listp x) (car x) x)) specialized)) + (specializers (mapcar (lambda (x) (if (listp x) (cadr x) t)) specialized))) + (check-lambda-list-names + llks required optional rest key aux nil nil + :context "a method lambda list" :signal-via #'specialized-lambda-list-error) + (values (append required + (mapcar #'parse-optional-arg-spec optional) + rest + ;; Preserve keyword-names when given as (:KEYWORD var) + (mapcar (lambda (x) + (if (typep x '(cons cons)) + (car x) + (parse-key-arg-spec x))) + key)) + (make-lambda-list llks nil required optional rest key aux) + specializers))) (setq **boot-state** 'early) diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index baeca63c4..189a6509b 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -168,6 +168,32 @@ t t "Required argument is not a symbol: (ARG T)") (test-case '(arg)))) +(with-test (:name (defmethod :lambda-list)) + (flet ((test-case (lambda-list messages) + (multiple-value-bind + (fun failure-p warnings style-warnings notes errors) + (checked-compile `(lambda () (defmethod ,(gensym) ,lambda-list)) + :allow-failure t) + (declare (ignore fun warnings style-warnings notes)) + (assert failure-p) + (assert (= (length messages) (length errors))) + (loop for message in messages + for error in errors + do (assert (search message (princ-to-string error))))))) + (mapc + (lambda (spec) (apply #'test-case spec)) + '(;; Invalid specialized required argument + (((x t t)) ("arg is not a non-NIL symbol or a list of two elements: (X T T)")) + ;; Repeated names and keywords + (((x t) (x t)) ("The variable X occurs more than once")) + (((x t) &rest x) ("The variable X occurs more than once")) + ((&optional x x) ("The variable X occurs more than once")) + ((&key x ((:y x))) ("The variable X occurs more than once")) + ((&key x ((:x y))) ("The keyword :X occurs more than once")) + ;; Illegal variable names + (((:pi t)) (":PI is a keyword and cannot be used")) + (((pi t)) ("COMMON-LISP:PI names a defined constant")))))) + ;;; Explicit :metaclass option with structure-class and ;;; standard-class. -- 2.11.4.GIT