From: Christophe R. <cr...@us...> - 2002-11-19 19:02:18
|
Update of /cvsroot/sbcl/sbcl/src/pcl In directory sc8-pr-cvs1:/tmp/cvs-serv31455/src/pcl Modified Files: defcombin.lisp std-class.lisp Log Message: 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 Index: defcombin.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/defcombin.lisp,v retrieving revision 1.16 retrieving revision 1.17 diff -u -d -r1.16 -r1.17 --- defcombin.lisp 19 Nov 2002 16:00:21 -0000 1.16 +++ defcombin.lisp 19 Nov 2002 19:02:15 -0000 1.17 @@ -385,8 +385,8 @@ ;; name of a &WHOLE parameter, if any. (when (member '&whole (rest args-lambda-list)) (error 'simple-program-error - :format-control "~@<The value of the :ARGUMENTS option of~ - DEFINE-METHOD-COMBINATION is~2I~_~S,~I~_but &WHOLE may~ + :format-control "~@<The value of the :ARGUMENTS option of ~ + DEFINE-METHOD-COMBINATION is~2I~_~S,~I~_but &WHOLE may ~ only appear first in the lambda list.~:>" :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))))) Index: std-class.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v retrieving revision 1.34 retrieving revision 1.35 diff -u -d -r1.34 -r1.35 --- std-class.lisp 14 Nov 2002 11:31:52 -0000 1.34 +++ std-class.lisp 19 Nov 2002 19:02:15 -0000 1.35 @@ -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 "~@<There is more than one direct slot ~ + with name ~S.~:>" + :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 "~@<Duplicate slot option ~S for ~ + slot named ~S.~:>" + :format-arguments (list option slot-name))) + ((and (eq option :readers) + (notevery #'symbolp value)) + (error 'simple-program-error + :format-control "~@<Slot reader names for slot ~ + named ~S must be symbols.~:>" + :format-arguments (list slot-name))) + ((and (eq option :initargs) + (notevery #'symbolp value)) + (error 'simple-program-error + :format-control "~@<Slot initarg names for slot ~ + named ~S must be symbols.~:>" + :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 "~@<Duplicate initialization argument ~ + name ~S in :DEFAULT-INITARGS.~:>" :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 "~@<More than one :METACLASS ~ + option specified.~:>"))) + (:direct-default-initargs + (when (> (incf default-initargs) 1) + (error 'simple-program-error + :format-control "~@<More than one :DEFAULT-INITARGS ~ + option specified.~:>")))))) + (remf initargs :metaclass) (loop (unless (remf initargs :direct-superclasses) (return))) (loop (unless (remf initargs :direct-slots) (return))) (values meta |