Skip to content
Snippets Groups Projects
Commit 78721c4d authored by pmai's avatar pmai
Browse files

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.
parent 0a88576b
No related branches found
No related tags found
No related merge requests found
......@@ -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
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment