diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index 4b4edd200112b47ef630c705c47d228847245ff8..add1d32d2a14aecc525002c0e9e667bcb90ee248 100644 --- a/pcl/std-class.lisp +++ b/pcl/std-class.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.30 2002/06/05 23:17:47 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.31 2002/08/19 16:43:15 pmai Exp $") ;;; (in-package :pcl) @@ -371,15 +371,48 @@ *the-class-standard-class*) (t (class-of class))))) - (flet ((fix-super (s) - (cond ((classp s) s) - ((not (legal-class-name-p s)) - (error "~S is not a class or a legal class name." s)) - (t - (or (find-class s nil) - (setf (find-class s) - (make-instance 'forward-referenced-class - :name s))))))) + (labels ((program-error (format-control &rest args) + (error 'kernel:simple-program-error + :format-control format-control + :format-arguments args)) + (fix-super (s) + (cond ((classp s) s) + ((not (legal-class-name-p s)) + (program-error "~S is not a class or a legal ~ + class name." s)) + (t + (or (find-class s nil) + (setf (find-class s) + (make-instance 'forward-referenced-class + :name s))))))) + ;; + ;; CLHS: signal PROGRAM-ERROR, if + ;; (a) there are any duplicate slot names + ;; (b) any of the slot options :ALLOCATION, :INITFORM, :TYPE, or + ;; :DOCUMENTATION appears more than one in a single slot description. + (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) do + (program-error "More than one direct slot with name ~S." + slot-name) + else do + (loop for (option value . more) on slot by #'cddr + when (and (member option '(:allocation :type :initform + :documentation)) + (not (eq unsupplied + (getf more option unsupplied)))) do + (program-error "Duplicate slot option ~S for slot ~S." + option slot-name))) + ;; + ;; CLHS: signal PROGRAM-ERROR, if an initialization argument name + ;; appears more than once in :DEFAULT-INITARGS class option. + (loop for (initarg . more) on (getf initargs :direct-default-initargs) + for name = (car initarg) + when (some (lambda (a) (eq (car a) name)) more) do + (program-error "Duplicate initialization argument ~ + name ~S in :default-initargs of class ~A." + name class)) + ;; (loop (unless (remf initargs :metaclass) (return))) (loop (unless (remf initargs :direct-superclasses) (return))) (values meta