From c7638557b3c7b34267daba188d345f5d284f4ac3 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Tue, 3 Sep 2002 02:29:44 +0000 Subject: [PATCH] 0.7.7.12: fixing insufficient-DEFGENERIC-checking problem in my 0.7.7.10 code (pointed out by APD on sbcl-devel)... ...added APD test case to tests/clos.impure.lisp ...added AUXP value to PARSE-LAMBDA-LIST return values everywhere ...made CHECK-GF-LAMBDA-LIST check AUXP instead of just checking that AUX list is empty --- src/code/defstruct.lisp | 4 ++-- src/code/late-type.lisp | 5 +++-- src/compiler/ir1tran.lisp | 3 ++- src/compiler/parse-lambda-list.lisp | 23 +++++++++++++---------- src/pcl/boot.lisp | 7 ++++--- tests/clos.impure.lisp | 2 ++ version.lisp-expr | 2 +- 7 files changed, 27 insertions(+), 19 deletions(-) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index a0839b3..984fa3a 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -1210,7 +1210,7 @@ ;;; Given a structure and a BOA constructor spec, call CREATOR with ;;; the appropriate args to make a constructor. (defun create-boa-constructor (defstruct boa creator) - (multiple-value-bind (req opt restp rest keyp keys allowp aux) + (multiple-value-bind (req opt restp rest keyp keys allowp auxp aux) (parse-lambda-list (second boa)) (collect ((arglist) (vars) @@ -1281,7 +1281,7 @@ (when allowp (arglist '&allow-other-keys)) - (when aux + (when auxp (arglist '&aux) (dolist (arg aux) (let* ((arg (if (consp arg) arg (list arg))) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index e60d1bc..f8c6561 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -250,9 +250,10 @@ ;;; used for both FUNCTION and VALUES types. (declaim (ftype (function (list args-type) (values)) parse-args-types)) (defun parse-args-types (lambda-list result) - (multiple-value-bind (required optional restp rest keyp keys allowp aux) + (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux) (parse-lambda-list-like-thing lambda-list) - (when aux + (declare (ignore aux)) ; since we require AUXP=NIL + (when auxp (error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list)) (setf (args-type-required result) (mapcar #'specifier-type required)) (setf (args-type-optional result) (mapcar #'specifier-type optional)) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 495ac5d..b5ad3de 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -1233,9 +1233,10 @@ (declaim (ftype (function (list) (values list boolean boolean list list)) make-lambda-vars)) (defun make-lambda-vars (list) - (multiple-value-bind (required optional restp rest keyp keys allowp aux + (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux morep more-context more-count) (parse-lambda-list list) + (declare (ignore auxp)) ; since we just iterate over AUX regardless (collect ((vars) (names-so-far) (aux-vars) diff --git a/src/compiler/parse-lambda-list.lisp b/src/compiler/parse-lambda-list.lisp index 998d2cb..a8e1283 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,10 +22,11 @@ ;;; 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. ;;; ;;; The top level lambda list syntax is checked for validity, but the ;;; arg specifiers are just passed through untouched. If something is @@ -33,7 +34,7 @@ ;;; recovery point. (declaim (ftype (function (list) (values list list boolean t boolean list boolean - list boolean t t)) + boolean list boolean t t)) parse-lambda-list-like-thing parse-lambda-list)) (defun parse-lambda-list-like-thing (list) @@ -47,6 +48,7 @@ (more-context nil) (more-count nil) (keyp nil) + (auxp nil) (allowp nil) (state :required)) (declare (type (member :allow-other-keys :aux @@ -92,7 +94,8 @@ (&aux (when (member state '(:rest :more-context :more-count)) (compiler-error "misplaced &AUX in lambda list: ~S" list)) - (setq state :aux)) + (setq auxp t + state :aux)) ;; FIXME: I don't think ANSI says this is an error. (It ;; should certainly be good for a STYLE-WARNING, ;; though.) @@ -120,7 +123,7 @@ (when (eq state :rest) (compiler-error "&REST without rest variable")) - (values (required) (optional) restp rest keyp (keys) allowp (aux) + (values (required) (optional) restp rest keyp (keys) allowp auxp (aux) morep more-context more-count)))) ;;; like PARSE-LAMBDA-LIST-LIKE-THING, except our LAMBDA-LIST argument @@ -131,7 +134,7 @@ (defun parse-lambda-list (lambda-list) ;; Classify parameters without checking their validity individually. - (multiple-value-bind (required optional restp rest keyp keys allowp aux + (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux morep more-context more-count) (parse-lambda-list-like-thing lambda-list) @@ -170,7 +173,7 @@ i)))))) ;; Voila. - (values required optional restp rest keyp keys allowp aux + (values required optional restp rest keyp keys allowp auxp aux morep more-context more-count))) (/show0 "parse-lambda-list.lisp end of file") diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index f4dc2ce..69f7e17 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -241,12 +241,13 @@ bootstrapping. (error "invalid argument ~S in the generic function lambda list ~S" arg lambda-list)))) - (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 lambda-list) (declare (ignore required)) ; since they're no different in a gf ll (declare (ignore restp rest)) ; since they're no different in a gf ll (declare (ignore allowp)) ; since &ALLOW-OTHER-KEYS is fine either way + (declare (ignore aux)) ; since we require AUXP=NIL (declare (ignore more-context more-count)) ; safely ignored unless MOREP ;; no defaults allowed for &OPTIONAL arguments (dolist (i optional) @@ -264,7 +265,7 @@ bootstrapping. (null (cddar i)))) (null (cdr i))))))) ;; no &AUX allowed - (when aux + (when auxp (error "&AUX is not allowed in a generic function lambda list: ~S" lambda-list)) ;; Oh, *puhlease*... not specifically as per section 3.4.2 of diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index eb3c5d4..60815d0 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -121,6 +121,8 @@ ;; forbidden &AUX (dislike '(defgeneric gf-for-ll-test-13 (x y z &optional a &aux g h))) (like '(defgeneric gf-for-ll-test-14 (x y z &optional a))) + (dislike '(defgeneric gf-for-ll-test-bare-aux-1 (x &aux))) + (like '(defgeneric gf-for-ll-test-bare-aux-2 (x))) ;; also can't use bogoDEFMETHODish type-qualifier-ish decorations ;; on required arguments (dislike '(defgeneric gf-for-11-test-15 ((arg t)))) diff --git a/version.lisp-expr b/version.lisp-expr index bdc8447..b0794e4 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.7.11" +"0.7.7.12" -- 1.7.10.4