From 650f162090e21b336cb842c8519e4215d7283ff3 Mon Sep 17 00:00:00 2001 From: gerd <gerd> Date: Sun, 30 Mar 2003 00:48:10 +0000 Subject: [PATCH] Make classes FIND-CLASSable early, for MOP programming, and for compatibility with other Lisps. * pcl/std-class.lisp (update-class): (setf find-class) here. (shared-initialize) <:after std-class>: Call update-class after setting the class predicate. Make ENSURE-CLASS-USING-CLASS AMOP compliant. * pcl/std-class.lisp (ensure-class, ensure-class-using-class) (ensure-class-using-class): Exchange first and second arg for AMOP compliance. * pcl/generic-functions.lisp (ensure-non-standard-class): Likewise. * pcl/braid.lisp (ensure-non-standard-class): Likewise. --- pcl/braid.lisp | 23 ++++++++++++----------- pcl/cache.lisp | 4 ++-- pcl/generic-functions.lisp | 4 ++-- pcl/std-class.lisp | 11 ++++++----- 4 files changed, 22 insertions(+), 20 deletions(-) diff --git a/pcl/braid.lisp b/pcl/braid.lisp index c071710c9..e8287ada5 100644 --- a/pcl/braid.lisp +++ b/pcl/braid.lisp @@ -25,7 +25,7 @@ ;;; ************************************************************************* (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.30 2003/03/26 17:15:22 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.31 2003/03/30 00:48:10 gerd Exp $") ;;; ;;; Bootstrapping the meta-braid. @@ -511,11 +511,11 @@ (supers (mapcar #'kernel:%class-name kernel-supers))) (if slotsp (ensure-class-using-class - name nil :metaclass metaclass :name name + nil name :metaclass metaclass :name name :direct-superclasses supers :direct-slots slots) (ensure-class-using-class - name nil :metaclass metaclass :name name + nil name :metaclass metaclass :name name :direct-superclasses supers)))) (slot-initargs-from-structure-slotd (slotd) `(:name ,(structure-slotd-name slotd) @@ -579,20 +579,21 @@ ;;; class in the lisp type system. ;;; (defun update-lisp-class-layout (class layout) - (let ((lclass (kernel:layout-class layout))) - (unless (eq (kernel:%class-layout lclass) layout) - (setf (kernel:layout-inherits layout) - (kernel:order-layout-inherits - (map 'simple-vector #'class-wrapper - (reverse (rest (class-precedence-list class)))))) + (let ((kernel-class (kernel:layout-class layout))) + (unless (eq (kernel:%class-layout kernel-class) layout) + (let ((cpl (class-precedence-list class))) + (setf (kernel:layout-inherits layout) + (kernel:order-layout-inherits + (map 'simple-vector #'class-wrapper + (reverse (rest cpl)))))) (kernel:register-layout layout :invalidate t) ;; ;; Subclasses of formerly forward-referenced-class may be unknown ;; to lisp:find-class and also anonymous. This functionality moved ;; here from (setf find-class). (let ((name (class-name class))) - (setf (kernel::find-class name) lclass - (kernel:%class-name lclass) name))))) + (setf (kernel::find-class name) kernel-class + (kernel:%class-name kernel-class) name))))) (defun common-lisp::sxhash-instance (instance) (get-hash instance)) diff --git a/pcl/cache.lisp b/pcl/cache.lisp index 2c6bd8d2b..ef544c135 100644 --- a/pcl/cache.lisp +++ b/pcl/cache.lisp @@ -25,7 +25,7 @@ ;;; ************************************************************************* (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.25 2003/03/26 17:15:22 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.26 2003/03/30 00:48:10 gerd Exp $") ;;; ;;; The basics of the PCL wrapper cache mechanism. @@ -410,7 +410,7 @@ (:obsolete (obsolete-instance-trap owrapper (second state) instance)))))) -(declaim (inline check-obsolete-instance)) +;(declaim (inline check-obsolete-instance)) (defun check-obsolete-instance (instance) (when (invalid-wrapper-p (kernel:layout-of instance)) (check-wrapper-validity instance))) diff --git a/pcl/generic-functions.lisp b/pcl/generic-functions.lisp index 7fdd4c913..fc0f8c375 100644 --- a/pcl/generic-functions.lisp +++ b/pcl/generic-functions.lisp @@ -1,7 +1,7 @@ ;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*- (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/generic-functions.lisp,v 1.20 2003/03/26 17:15:22 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/generic-functions.lisp,v 1.21 2003/03/30 00:48:10 gerd Exp $") ;;; (in-package :pcl) @@ -721,7 +721,7 @@ ; (structure-class) ; (funcallable-standard-class) -(defgeneric ensure-class-using-class (name class &rest args &key &allow-other-keys)) +(defgeneric ensure-class-using-class (class name &rest args &key &allow-other-keys)) ; (t null) ; (t pcl-class) diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index bb66bfaf4..482dc3db7 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.46 2003/03/28 16:07:42 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.47 2003/03/30 00:48:10 gerd Exp $") (in-package :pcl) @@ -353,9 +353,9 @@ (setf (gdefinition 'load-defclass) #'real-load-defclass) (defun ensure-class (name &rest all) - (apply #'ensure-class-using-class name (find-class name nil) all)) + (apply #'ensure-class-using-class (find-class name nil) name all)) -(defmethod ensure-class-using-class (name (class null) &rest args &key) +(defmethod ensure-class-using-class ((class null) name &rest args &key) (multiple-value-bind (meta initargs) (ensure-class-values class args) (inform-type-system-about-class (class-prototype meta) name) @@ -364,7 +364,7 @@ (inform-type-system-about-class class name) class)) -(defmethod ensure-class-using-class (name (class pcl-class) &rest args &key) +(defmethod ensure-class-using-class ((class pcl-class) name &rest args &key) (multiple-value-bind (meta initargs) (ensure-class-values class args) (unless (eq (class-of class) meta) @@ -512,8 +512,8 @@ (setf (slot-value class 'predicate-name) (make-class-predicate-name (class-name class)))))) (add-direct-subclasses class direct-superclasses) - (update-class class nil) (make-class-predicate class predicate-name) + (update-class class nil) (add-slot-accessors class direct-slots)) (defmethod shared-initialize :before ((class class) slot-names &key name) @@ -734,6 +734,7 @@ (when (or finalizep (class-finalized-p class) (not (class-has-a-forward-referenced-superclass-p class))) + (setf (find-class (class-name class)) class) (update-cpl class (compute-class-precedence-list class)) (update-slots class (compute-slots class)) (update-gfs-of-class class) -- GitLab