X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fparse-lambda-list.lisp;h=d98953b0fcf825eafcfdea505c526ca7bcd7211c;hb=d59fb3b0953c8d14427b60f949a0e567a8b79fe0;hp=998d2cbc06f41a7070a98468647bb89cc73fd187;hpb=56f96e77ade913d6363a3068c94e60f44ae9b3e7;p=sbcl.git diff --git a/src/compiler/parse-lambda-list.lisp b/src/compiler/parse-lambda-list.lisp index 998d2cb..d98953b 100644 --- a/src/compiler/parse-lambda-list.lisp +++ b/src/compiler/parse-lambda-list.lisp @@ -14,7 +14,7 @@ ;;; Break something like a lambda list (but not necessarily actually a ;;; lambda list, e.g. the representation of argument types which is ;;; used within an FTYPE specification) into its component parts. We -;;; return eleven values: +;;; return twelve values: ;;; 1. a list of the required args; ;;; 2. a list of the &OPTIONAL arg specs; ;;; 3. true if a &REST arg was specified; @@ -22,20 +22,26 @@ ;;; 5. true if &KEY args are present; ;;; 6. a list of the &KEY arg specs; ;;; 7. true if &ALLOW-OTHER-KEYS was specified.; -;;; 8. a list of the &AUX specifiers; -;;; 9. true if a &MORE arg was specified; -;;; 10. the &MORE context var; -;;; 11. the &MORE count var. +;;; 8. true if any &AUX is present (new in SBCL vs. CMU CL); +;;; 9. a list of the &AUX specifiers; +;;; 10. true if a &MORE arg was specified; +;;; 11. the &MORE context var; +;;; 12. the &MORE count var; +;;; 13. true if any lambda list keyword is present (only for +;;; PARSE-LAMBDA-LIST-LIKE-THING). ;;; ;;; The top level lambda list syntax is checked for validity, but the ;;; arg specifiers are just passed through untouched. If something is ;;; wrong, we use COMPILER-ERROR, aborting compilation to the last ;;; recovery point. -(declaim (ftype (function (list) - (values list list boolean t boolean list boolean - list boolean t t)) - parse-lambda-list-like-thing - parse-lambda-list)) +(declaim (ftype (sfunction (list) + (values list list boolean t boolean list boolean + boolean list boolean t t boolean)) + parse-lambda-list-like-thing)) +(declaim (ftype (sfunction (list) + (values list list boolean t boolean list boolean + boolean list boolean t t)) + parse-lambda-list)) (defun parse-lambda-list-like-thing (list) (collect ((required) (optional) @@ -47,6 +53,7 @@ (more-context nil) (more-count nil) (keyp nil) + (auxp nil) (allowp nil) (state :required)) (declare (type (member :allow-other-keys :aux @@ -57,10 +64,7 @@ :required :rest) state)) (dolist (arg list) - (if (and (symbolp arg) - (let ((name (symbol-name arg))) - (and (plusp (length name)) - (char= (char name 0) #\&)))) + (if (member arg sb!xc:lambda-list-keywords) (case arg (&optional (unless (eq state :required) @@ -80,6 +84,10 @@ (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)) (setq keyp t state :key)) (&allow-other-keys @@ -92,36 +100,43 @@ (&aux (when (member state '(:rest :more-context :more-count)) (compiler-error "misplaced &AUX in lambda list: ~S" list)) - (setq state :aux)) - ;; FIXME: I don't think ANSI says this is an error. (It - ;; should certainly be good for a STYLE-WARNING, - ;; though.) - (t - (compiler-error "unknown &KEYWORD 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))))) + (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 ~ + a keyword: ~S" + arg)))))) (when (eq state :rest) (compiler-error "&REST without rest variable")) - - (values (required) (optional) restp rest keyp (keys) allowp (aux) - morep more-context more-count)))) + + (values (required) (optional) restp rest keyp (keys) allowp auxp (aux) + morep more-context more-count + (neq state :required))))) ;;; like PARSE-LAMBDA-LIST-LIKE-THING, except our LAMBDA-LIST argument ;;; really *is* a lambda list, not just a "lambda-list-like thing", so @@ -131,46 +146,46 @@ (defun parse-lambda-list (lambda-list) ;; Classify parameters without checking their validity individually. - (multiple-value-bind (required optional restp rest keyp keys allowp aux - morep more-context more-count) + (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux + morep more-context more-count) (parse-lambda-list-like-thing lambda-list) ;; 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 aux - morep more-context more-count))) + (values required optional restp rest keyp keys allowp auxp aux + morep more-context more-count))) (/show0 "parse-lambda-list.lisp end of file")