From 78721c4d8625b5d8063a0943cb466c4ecd1b2841 Mon Sep 17 00:00:00 2001 From: pmai <pmai> Date: Mon, 19 Aug 2002 16:43:15 +0000 Subject: [PATCH] Patch from Gerd Moellmann to bring error detection of defclass in line with ANSI requirements: o If there are any duplicate slot names, an error of type program-error is signaled. o If an initialization argument name appears more than once in :default-initargs class option, an error of type program-error is signaled. o If any of the following slot options appears more than once in a single slot description, an error of type program-error is signaled: :allocation, :initform, :type, :documentation. --- pcl/std-class.lisp | 53 +++++++++++++++++++++++++++++++++++++--------- 1 file changed, 43 insertions(+), 10 deletions(-) diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index 4b4edd200..add1d32d2 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 -- GitLab