From ea652c139bb060d821f3010b3b106bdbcec983aa Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Tue, 19 Nov 2002 19:02:15 +0000 Subject: [PATCH] 0.7.9.58: Some more error-checking at DEFCLASS ... duplicate :METACLASS, :DEFAULT-INITARGS options ... :READER and :INITARG options to slots must be symbols Fix up error messages ... add some spaces to previous commit ... CLASS is not what you think it is in ENSURE-CLASS-VALUES --- src/pcl/defcombin.lisp | 6 ++-- src/pcl/std-class.lisp | 76 ++++++++++++++++++++++++++++++++++-------------- tests/clos.impure.lisp | 16 ++++++++-- version.lisp-expr | 2 +- 4 files changed, 72 insertions(+), 28 deletions(-) diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index 7975e13..e312ba9 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -385,8 +385,8 @@ ;; name of a &WHOLE parameter, if any. (when (member '&whole (rest args-lambda-list)) (error 'simple-program-error - :format-control "~@" :format-arguments (list args-lambda-list))) (loop with state = 'required @@ -472,4 +472,4 @@ (t list)))) (return (nconc (frob required nr nreq) (frob optional no nopt) - values))))) \ No newline at end of file + values))))) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index a34f739..adb1282 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -382,34 +382,66 @@ ;; However, after playing around a little, I couldn't find that ;; way, so I've left it as is, but if someone does come up with a ;; better way... -- CSR, 2002-09-08 - (loop for (slot . more) on (getf initargs :direct-slots) - for slot-name = (getf slot :name) - if (some (lambda (s) (eq slot-name (getf s :name))) more) - ;; FIXME: It's quite possible that we ought to define an - ;; SB-INT:PROGRAM-ERROR function to signal these and other - ;; errors throughout the code base that are required to be - ;; of type PROGRAM-ERROR. - do (error 'simple-program-error - :format-control "More than one direct slot with name ~S." - :format-arguments (list slot-name)) - else - do (loop for (option value . more) on slot by #'cddr - when (and (member option - '(:allocation :type + (do ((direct-slots (getf initargs :direct-slots) (cdr direct-slots))) + ((endp direct-slots) nil) + (destructuring-bind (slot &rest more) direct-slots + (let ((slot-name (getf slot :name))) + (when (some (lambda (s) (eq slot-name (getf s :name))) more) + ;; FIXME: It's quite possible that we ought to define an + ;; SB-INT:PROGRAM-ERROR function to signal these and other + ;; errors throughout the codebase that are required to be + ;; of type PROGRAM-ERROR. + (error 'simple-program-error + :format-control "~@" + :format-arguments (list slot-name))) + (do ((stuff slot (cddr stuff))) + ((endp stuff) nil) + (destructuring-bind (option value &rest more) stuff + (cond + ((and (member option '(:allocation :type :initform :documentation)) - (not (eq unsupplied - (getf more option unsupplied)))) - do (error 'simple-program-error - :format-control "Duplicate slot option ~S for slot ~S." - :format-arguments (list option slot-name)))) + (not (eq unsupplied + (getf more option unsupplied)))) + (error 'simple-program-error + :format-control "~@" + :format-arguments (list option slot-name))) + ((and (eq option :readers) + (notevery #'symbolp value)) + (error 'simple-program-error + :format-control "~@" + :format-arguments (list slot-name))) + ((and (eq option :initargs) + (notevery #'symbolp value)) + (error 'simple-program-error + :format-control "~@" + :format-arguments (list slot-name))))))))) (loop for (initarg . more) on (getf initargs :direct-default-initargs) for name = (car initarg) when (some (lambda (a) (eq (car a) name)) more) do (error 'simple-program-error - :format-control "Duplicate initialization argument ~ - name ~S in :default-initargs of class ~A." + :format-control "~@" :format-arguments (list name class))) - (loop (unless (remf initargs :metaclass) (return))) + (let ((metaclass 0) + (default-initargs 0)) + (do ((args initargs (cddr args))) + ((endp args) nil) + (case (car args) + (:metaclass + (when (> (incf metaclass) 1) + (error 'simple-program-error + :format-control "~@"))) + (:direct-default-initargs + (when (> (incf default-initargs) 1) + (error 'simple-program-error + :format-control "~@")))))) + (remf initargs :metaclass) (loop (unless (remf initargs :direct-superclasses) (return))) (loop (unless (remf initargs :direct-slots) (return))) (values meta diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 7b80f6b..03a3ee0 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -293,12 +293,24 @@ (assert-program-error (defclass foo004 () ((a :silly t)))) ;; and some more, found by Wolfhard Buss and fixed for cmucl by Gerd - ;; Moellmann in 0.7.8.x: + ;; Moellmann in sbcl-0.7.8.x: (assert-program-error (progn (defmethod odd-key-args-checking (&key (key 42)) key) (odd-key-args-checking 3))) (assert (= (odd-key-args-checking) 42)) - (assert (eq (odd-key-args-checking :key t) t))) + (assert (eq (odd-key-args-checking :key t) t)) + ;; yet some more, fixed in sbcl-0.7.9.xx + (assert-program-error (defclass foo005 () + (:metaclass sb-pcl::funcallable-standard-class) + (:metaclass 1))) + (assert-program-error (defclass foo006 () + ((a :reader (setf a))))) + (assert-program-error (defclass foo007 () + ((a :initarg 1)))) + (assert-program-error (defclass foo008 () + (a :initarg :a) + (:default-initargs :a 1) + (:default-initargs :a 2)))) ;;; DOCUMENTATION's argument-precedence-order wasn't being faithfully ;;; preserved through the bootstrap process until sbcl-0.7.8.39. diff --git a/version.lisp-expr b/version.lisp-expr index 1dcebb6..0f13d33 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.9.57" +"0.7.9.58" -- 1.7.10.4