Commit e5d83363 authored by Marius Gerbershagen's avatar Marius Gerbershagen
Browse files

Merge branch 'fix-direct-superclasses' into 'develop'

direct-superclasses: the default value of the slot is nil per AMOP

See merge request embeddable-common-lisp/ecl!239
parents 178e0362 e881e5fa
......@@ -59,7 +59,7 @@
(defparameter +class-slots+
`(,@+specializer-slots+
(name :initarg :name :initform nil :accessor class-id)
(direct-superclasses :initarg :direct-superclasses
(direct-superclasses :initarg :direct-superclasses :initform nil
:accessor class-direct-superclasses)
(direct-subclasses :initform nil :accessor class-direct-subclasses)
(slots :accessor class-slots)
......
......@@ -239,24 +239,29 @@
(remove child (class-direct-subclasses parent))))
(defun check-direct-superclasses (class supplied-superclasses)
(if supplied-superclasses
(loop for superclass in supplied-superclasses
;; Until we process streams.lsp there are some invalid combinations
;; using built-in-class, which here we simply ignore.
unless (or (validate-superclass class superclass)
(not (eq *clos-booted* T)))
do (error "Class ~A is not a valid superclass for ~A" superclass class))
(setf supplied-superclasses
(list (find-class (typecase class
(STANDARD-CLASS 'STANDARD-OBJECT)
(STRUCTURE-CLASS 'STRUCTURE-OBJECT)
(FUNCALLABLE-STANDARD-CLASS 'FUNCALLABLE-STANDARD-OBJECT)
(otherwise (error "No :DIRECT-SUPERCLASS ~
argument was supplied for metaclass ~S." (class-of class))))))))
;; FIXME!!! Here should come the invocation of VALIDATE-SUPERCLASS!
;; FIXME!!! We should check that structures and standard objects are
;; not mixed, and that STANDARD-CLASS, or STANDARD-GENERIC-FUNCTION,
;; etc, are the first classes.
(unless supplied-superclasses
(setf supplied-superclasses
(typecase class
(standard-class
(list (find-class 'standard-object)))
(structure-class
(list (find-class 'structure-object)))
(funcallable-standard-class
(list (find-class 'funcallable-standard-object)))
(forward-referenced-class
nil)
(otherwise
(error "No :DIRECT-SUPERCLASS argument was supplied for the ~
metaclass ~S." (class-of class))))))
;; Until we process streams.lsp there are some invalid combinations using
;; built-in-class, which here we simply ignore.
(when (eq *clos-booted* T)
(loop for superclass in supplied-superclasses
unless (validate-superclass class superclass)
do (error "Class ~A is not a valid superclass for ~A" superclass class)))
;; FIXME!!! We should check that structures and standard objects are not
;; mixed, and that STANDARD-CLASS, or STANDARD-GENERIC-FUNCTION, etc, are
;; the first classes.
supplied-superclasses)
(defmethod validate-superclass ((class class) (superclass class))
......
......@@ -58,6 +58,8 @@
(= 3
(eval '(progn
(defclass foo-metaclass (standard-class) ())
(defmethod mop:validate-superclass ((c1 foo-metaclass) (c2 standard-class))
t)
(defclass faa () ((a :initform 2 :initarg :a)) (:metaclass foo-metaclass))
(prog1 (slot-value (make-instance 'faa :a 3) 'a)
(cl-test::delete-class 'foo-metaclass 'faa)))))))
......@@ -136,6 +138,8 @@
(eval '(let ((*aux* 5))
(declare (special *aux*))
(defclass foo-metaclass (standard-class) ())
(defmethod mop:validate-superclass ((c1 foo-metaclass) (c2 standard-class))
t)
(defmethod shared-initialize ((class foo-metaclass) slot-names
&rest initargs &key option)
(prog1 (call-next-method)
......@@ -261,6 +265,8 @@ the metaclass")
(eval '(let ((*aux* 5))
(declare (special *aux*))
(defclass foo-metaclass (standard-class) ())
(defmethod mop:validate-superclass ((c1 foo-metaclass) (c2 standard-class))
t)
(defmethod shared-initialize ((class foo-metaclass) slot-names
&rest initargs &key ((cl-user::option option)))
(prog1 (call-next-method)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment