X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fparse-lambda-list.lisp;h=c906093316e8e8f58e4509a00163c7f4d2316f9d;hb=4ba392170e98744f0ef0b8e08a5d42b988f1d0c9;hp=6109cbd082d6f98a16df99d21cf82a57ae76f0d1;hpb=9f684145a95d4abbde75422edb8b217dfad3375b;p=sbcl.git diff --git a/src/compiler/parse-lambda-list.lisp b/src/compiler/parse-lambda-list.lisp index 6109cbd..c906093 100644 --- a/src/compiler/parse-lambda-list.lisp +++ b/src/compiler/parse-lambda-list.lisp @@ -34,15 +34,15 @@ ;;; arg specifiers are just passed through untouched. If something is ;;; wrong, we use COMPILER-ERROR, aborting compilation to the last ;;; recovery point. -(declaim (ftype (sfunction (list) +(declaim (ftype (sfunction (list &key (:silent boolean)) (values list list boolean t boolean list boolean boolean list boolean t t boolean)) - parse-lambda-list-like-thing)) -(declaim (ftype (sfunction (list) + parse-lambda-list-like-thing)) +(declaim (ftype (sfunction (list &key (:silent boolean)) (values list list boolean t boolean list boolean boolean list boolean t t)) - parse-lambda-list)) -(defun parse-lambda-list-like-thing (list) + parse-lambda-list)) +(defun parse-lambda-list-like-thing (list &key silent) (collect ((required) (optional) (keys) @@ -53,7 +53,7 @@ (more-context nil) (more-count nil) (keyp nil) - (auxp nil) + (auxp nil) (allowp nil) (state :required)) (declare (type (member :allow-other-keys :aux @@ -84,10 +84,11 @@ (unless (member state '(:required :optional :post-rest :post-more)) (compiler-error "misplaced &KEY in lambda list: ~S" list)) - #-sb-xc-host - (when (optional) - (compiler-style-warn - "&OPTIONAL and &KEY found in the same lambda list: ~S" list)) + #-sb-xc-host + (when (optional) + (unless silent + (compiler-style-warn + "&OPTIONAL and &KEY found in the same lambda list: ~S" list))) (setq keyp t state :key)) (&allow-other-keys @@ -103,34 +104,52 @@ (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))) - (progn - (when (symbolp arg) - (let ((name (symbol-name arg))) - (when (and (plusp (length name)) - (char= (char name 0) #\&)) - (style-warn - "suspicious variable in lambda list: ~S." arg)))) - (case state - (:required (required arg)) - (:optional (optional arg)) - (:rest - (setq restp t - rest arg - state :post-rest)) - (:more-context - (setq more-context arg - state :more-count)) - (:more-count - (setq more-count arg - state :post-more)) - (:key (keys arg)) - (:aux (aux arg)) - (t - (compiler-error "found garbage in lambda list when expecting ~ + state :aux)) + (t + ;; It could be argued that &WHOLE and friends would be + ;; just ordinary variables in an ordinary lambda-list, + ;; but since (1) that seem exceedingly to have been the + ;; programmers intent and (2) the spec can be + ;; interpreted as giving as licence to signal an + ;; error[*] that is what we do. + ;; + ;; [* All lambda list keywords used in the + ;; implementation appear in LAMBDA-LIST-KEYWORDS. Each + ;; member of a lambda list is either a parameter + ;; specifier ot a lambda list keyword. Ergo, symbols + ;; appearing in LAMBDA-LIST-KEYWORDS cannot be + ;; parameter specifiers.] + (compiler-error 'simple-program-error + :format-control "Bad lambda list keyword ~S in: ~S" + :format-arguments (list arg list)))) + (progn + (when (symbolp arg) + (let ((name (symbol-name arg))) + (when (and (plusp (length name)) + (char= (char name 0) #\&)) + ;; Should this be COMPILER-STYLE-WARN? + (unless silent + (style-warn + "suspicious variable in lambda list: ~S." arg))))) + (case state + (:required (required arg)) + (:optional (optional arg)) + (:rest + (setq restp t + rest arg + state :post-rest)) + (:more-context + (setq more-context arg + state :more-count)) + (:more-count + (setq more-count arg + state :post-more)) + (:key (keys arg)) + (:aux (aux arg)) + (t + (compiler-error "found garbage in lambda list when expecting ~ a keyword: ~S" - arg)))))) + arg)))))) (when (eq state :rest) (compiler-error "&REST without rest variable")) @@ -143,49 +162,48 @@ ;;; can barf on things which're illegal as arguments in lambda lists ;;; even if they could conceivably be legal in not-quite-a-lambda-list ;;; weirdosities -(defun parse-lambda-list (lambda-list) - +(defun parse-lambda-list (lambda-list &key silent) ;; Classify parameters without checking their validity individually. (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux - morep more-context more-count) - (parse-lambda-list-like-thing lambda-list) + morep more-context more-count) + (parse-lambda-list-like-thing lambda-list :silent silent) ;; Check validity of parameters. (flet ((need-symbol (x why) - (unless (symbolp x) - (compiler-error "~A is not a symbol: ~S" why x)))) + (unless (symbolp x) + (compiler-error "~A is not a symbol: ~S" why x)))) (dolist (i required) - (need-symbol i "Required argument")) + (need-symbol i "Required argument")) (dolist (i optional) - (typecase i - (symbol) - (cons - (destructuring-bind (var &optional init-form supplied-p) i - (declare (ignore init-form supplied-p)) - (need-symbol var "&OPTIONAL parameter name"))) - (t - (compiler-error "&OPTIONAL parameter is not a symbol or cons: ~S" - i)))) + (typecase i + (symbol) + (cons + (destructuring-bind (var &optional init-form supplied-p) i + (declare (ignore init-form supplied-p)) + (need-symbol var "&OPTIONAL parameter name"))) + (t + (compiler-error "&OPTIONAL parameter is not a symbol or cons: ~S" + i)))) (when restp - (need-symbol rest "&REST argument")) + (need-symbol rest "&REST argument")) (when keyp - (dolist (i keys) - (typecase i - (symbol) - (cons - (destructuring-bind (var-or-kv &optional init-form supplied-p) i - (declare (ignore init-form supplied-p)) - (if (consp var-or-kv) - (destructuring-bind (keyword-name var) var-or-kv - (declare (ignore keyword-name)) - (need-symbol var "&KEY parameter name")) - (need-symbol var-or-kv "&KEY parameter name")))) - (t - (compiler-error "&KEY parameter is not a symbol or cons: ~S" - i)))))) + (dolist (i keys) + (typecase i + (symbol) + (cons + (destructuring-bind (var-or-kv &optional init-form supplied-p) i + (declare (ignore init-form supplied-p)) + (if (consp var-or-kv) + (destructuring-bind (keyword-name var) var-or-kv + (declare (ignore keyword-name)) + (need-symbol var "&KEY parameter name")) + (need-symbol var-or-kv "&KEY parameter name")))) + (t + (compiler-error "&KEY parameter is not a symbol or cons: ~S" + i)))))) ;; Voila. (values required optional restp rest keyp keys allowp auxp aux - morep more-context more-count))) + morep more-context more-count))) (/show0 "parse-lambda-list.lisp end of file")