From: Christophe R. <cr...@us...> - 2003-02-27 13:34:18
|
Update of /cvsroot/sbcl/sbcl/src/pcl In directory sc8-pr-cvs1:/tmp/cvs-serv3641/src/pcl Modified Files: Tag: pcl_build_1_branch defclass.lisp defs.lisp std-class.lisp Log Message: 0.7.12.pcl-build1.5 Move defclass and defs into cold build ... define COLD-DEFCLASS, and use it to make early classes ... simplify DEFCLASS and s/REAL-LOAD-DEFCLASS/LOAD-DEFCLASS ... only do FBOUNDP checks when we're in charge of what a function name is This is perhaps indicative of the way to go. We'll use COLD-DEFFOO to build up early classes/methods/generic functions, which will then be turned into late ones in early COLD-INIT, so that by the time ordinary top-level forms run we're all set up and ready to cope with LOAD-DEFCLASS requests. Hrm. I see in our cold-init sequence !CLASS-FINALIZE, which would seem to break this plan. Maybe !CLASS-FINALIZE will need to run earlier -- pre-genesis -- so that Lisp classes are actually finalized before they currently are? Or maybe it's a no-op anyway? Currently I believe that there are no classes in *FORWARD-REFERENCED-LAYOUTS* that don't have a layout. Index: defclass.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/defclass.lisp,v retrieving revision 1.25 retrieving revision 1.25.2.1 diff -u -d -r1.25 -r1.25.2.1 --- defclass.lisp 15 Feb 2003 11:16:34 -0000 1.25 +++ defclass.lisp 27 Feb 2003 13:34:14 -0000 1.25.2.1 @@ -21,7 +21,7 @@ ;;;; warranty about the software, its performance or its conformity to any ;;;; specification. -(in-package "SB-PCL") +(in-package "SB!PCL") ;;;; DEFCLASS macro and close personal friends @@ -31,6 +31,11 @@ ;;; (as for deftype) and be recognized as a valid class name for ;;; defmethod parameter specializers and for use as the :metaclass ;;; option of a subsequent defclass." +;;; +;;; FIXME: Perhaps by analogy with the macroexpansion of DEFUN, this +;;; should be named %COMPILER-DEFCLASS: after all, maybe we want to do +;;; more things than just say things about the class-type; maybe the +;;; function DECLAIMs want to be here, too? (defun preinform-compiler-about-class-type (name) ;; Unless the type system already has an actual type attached to ;; NAME (in which case (1) writing a placeholder value over that @@ -59,27 +64,35 @@ ;;; After the metabraid has been setup, and the protocol for defining ;;; classes has been defined, the real definition of LOAD-DEFCLASS is ;;; installed by the file std-class.lisp -(defmacro defclass (name %direct-superclasses %direct-slots &rest %options) +;;; +;;; The above was written to reflect the old, one pass, compilation +;;; strategy. Now we have a two-pass strategy, so LOAD-DEFCLASS is +;;; undefined until the final definition in std-class.lisp, and we +;;; have COLD-DEFCLASS for early classes. +(sb!xc:defmacro defclass (name %direct-superclasses %direct-slots + &rest %options) (let ((supers (copy-tree %direct-superclasses)) (slots (copy-tree %direct-slots)) (options (copy-tree %options))) (let ((metaclass 'standard-class)) (dolist (option options) (if (not (listp option)) - (error "~S is not a legal defclass option." option) - (when (eq (car option) :metaclass) - (unless (legal-class-name-p (cadr option)) - (error "The value of the :metaclass option (~S) is not a~%~ - legal class name." - (cadr option))) - (setq metaclass + (error 'simple-program-error + :format-control "~@<~S is not a legal DEFCLASS option.~@:>" + :format-arguments (list option)) + (when (eq (car option) :metaclass) + (unless (legal-class-name-p (cadr option)) + (error 'simple-program-error + :format-control "~@<The value of the :METACLASS option ~ + (~S) is not a legal class name.~@:>" + :format-arguments (list (cadr option)))) + (setq metaclass (case (cadr option) (cl:standard-class 'standard-class) (cl:structure-class 'structure-class) (t (cadr option)))) - (setf options (remove option options)) - (return t)))) - + (setf options (remove option options)) + (return t)))) (let ((*initfunctions-for-this-defclass* ()) (*readers-for-this-defclass* ()) ;Truly a crock, but we got (*writers-for-this-defclass* ()) ;to have it to live nicely. @@ -95,36 +108,37 @@ ;; DEFSTRUCT-P should be true if the class is defined ;; with a metaclass STRUCTURE-CLASS, so that a DEFSTRUCT ;; is compiled for the class. - (defstruct-p (and (eq *boot-state* 'complete) - (let ((mclass (find-class metaclass nil))) - (and mclass - (*subtypep - mclass - *the-class-structure-class*)))))) + (defstruct-p (let ((mclass (find-class metaclass nil))) + (and mclass + (*subtypep + mclass + *the-class-structure-class*))))) (let ((defclass-form `(progn - ,@(mapcar (lambda (x) - `(declaim (ftype (function (t) t) ,x))) - *readers-for-this-defclass*) - ,@(mapcar (lambda (x) - `(declaim (ftype (function (t t) t) ,x))) - *writers-for-this-defclass*) - ,@(mapcar (lambda (x) - `(declaim (ftype (function (t) t) - ,(slot-reader-name x) - ,(slot-boundp-name x)) - (ftype (function (t t) t) - ,(slot-writer-name x)))) - *slot-names-for-this-defclass*) - (let ,(mapcar #'cdr *initfunctions-for-this-defclass*) - (load-defclass ',name - ',metaclass - ',supers - (list ,@canonical-slots) - (list ,@(apply #'append - (when defstruct-p - '(:from-defclass-p t)) - other-initargs))))))) + ,@(mapcar (lambda (x) + `(declaim (ftype (function (t) t) ,x))) + *readers-for-this-defclass*) + ,@(mapcar (lambda (x) + `(declaim (ftype (function (t t) t) ,x))) + *writers-for-this-defclass*) + ,@(unless defstruct-p + (mapcar + (lambda (x) + `(declaim + (ftype (function (t) t) + ,(slot-reader-name x) ,(slot-boundp-name x)) + (ftype (function (t t) t) + ,(slot-writer-name x)))) + *slot-names-for-this-defclass*)) + (let ,(mapcar #'cdr *initfunctions-for-this-defclass*) + (load-defclass ',name + ',metaclass + ',supers + (list ,@canonical-slots) + (list ,@(apply #'append + (when defstruct-p + '(:from-defclass-p t)) + other-initargs))))))) (if defstruct-p (progn ;; FIXME: (YUK!) Why do we do this? Because in order @@ -192,14 +206,19 @@ (push spec *slot-names-for-this-defclass*) `'(:name ,spec)) ((not (consp spec)) - (error "~S is not a legal slot specification." spec)) + (error 'simple-program-error + :format-control "~@<~S is not a legal slot specification.~:@>" + :format-arguments (list spec))) ((null (cdr spec)) (push (car spec) *slot-names-for-this-defclass*) `'(:name ,(car spec))) ((null (cddr spec)) - (error "In DEFCLASS ~S, the slot specification ~S is obsolete.~%~ - Convert it to ~S" - class-name spec (list (car spec) :initform (cadr spec)))) + (error 'simple-program-error + :format-control "~@<In DEFCLASS ~S, the slot specification ~S ~ + is obsolete: convert it to ~S.~@:>" + :format-arguments + (list class-name spec + (list (car spec) :initform (cadr spec))))) (t (let* ((name (pop spec)) (readers ()) @@ -253,12 +272,16 @@ ;;; are actually defined. ;;; Each entry in *EARLY-CLASS-DEFINITIONS* is an EARLY-CLASS-DEFINITION. +;;; +;;; FIXME: rename *EARLY-CLASS-DEFINITIONS* to +;;; *COLD-CLASS-DEFINITIONS* (or maybe *!CLASS-DEFINITIONS*) (defparameter *early-class-definitions* ()) (defun early-class-definition (class-name) (or (find class-name *early-class-definitions* :key #'ecd-class-name) - (error "~S is not a class in *early-class-definitions*." class-name))) + (bug "~S is not a class in ~S." class-name '*early-class-definitions*))) +;;; FIXME: turn this into DEFSTRUCT :TYPE LIST :NAMED? (defun make-early-class-definition (name source metaclass superclass-names canonical-slots other-initargs) @@ -309,10 +332,10 @@ (let ((name1 (canonical-slot-name s1))) (dolist (s2 (cdr (memq s1 slots))) (when (eq name1 (canonical-slot-name s2)) - (error "More than one early class defines a slot with the~%~ - name ~S. This can't work because the bootstrap~%~ - object system doesn't know how to compute effective~%~ - slots." + (bug "~@<More than one early class defines a slot with the ~ + name ~S. This can't work because the bootstrap ~ + object system doesn't know how to compute effective ~ + slots.~@:>" name1))))) slots)) @@ -332,7 +355,7 @@ (loop (when (null others) (return nil)) (let ((initarg (pop others))) (unless (eq initarg :direct-default-initargs) - (error "~@<The defclass option ~S is not supported by ~ + (bug "~@<The defclass option ~S is not supported by ~ the bootstrap object system.~:@>" initarg))) (setq default-initargs @@ -341,7 +364,7 @@ (defun !bootstrap-slot-index (class-name slot-name) (or (position slot-name (early-class-slots class-name)) - (error "~S not found" slot-name))) + (bug "slot ~S not found in ~S." slot-name class-name))) ;;; !BOOTSTRAP-GET-SLOT and !BOOTSTRAP-SET-SLOT are used to access and ;;; change the values of slots during bootstrapping. During @@ -370,9 +393,6 @@ (defun early-class-precedence-list (class) (!bootstrap-get-slot 'pcl-class class 'class-precedence-list)) -(defun early-class-name-of (instance) - (early-class-name (class-of instance))) - (defun early-class-slotds (class) (!bootstrap-get-slot 'slot-class class 'slots)) @@ -385,29 +405,82 @@ (defun early-accessor-method-slot-name (method) (!bootstrap-get-slot 'standard-accessor-method method 'slot-name)) -(unless (fboundp 'class-name-of) - (setf (symbol-function 'class-name-of) - (symbol-function 'early-class-name-of))) -(unintern 'early-class-name-of) - (defun early-class-direct-subclasses (class) (!bootstrap-get-slot 'class class 'direct-subclasses)) -(declaim (notinline load-defclass)) -(defun load-defclass (name metaclass supers canonical-slots canonical-options) - (setq supers (copy-tree supers) - canonical-slots (copy-tree canonical-slots) - canonical-options (copy-tree canonical-options)) - (let ((ecd - (make-early-class-definition name - *load-pathname* - metaclass - supers - canonical-slots - canonical-options)) - (existing - (find name *early-class-definitions* :key #'ecd-class-name))) +;;; COLD-DEFCLASS is a macro that arranges for all the class in +;;; question to be born fully-formed at cold-init time. +;;; +;;; FIXMEs: Name, cut'n'paste code sharing with DEFCLASS, DEFSTRUCT-P +;;; (non-)handling, ... +(defmacro cold-defclass (name %direct-superclasses %direct-slots + &rest %options) + (let ((supers (copy-tree %direct-superclasses)) + (slots (copy-tree %direct-slots)) + (options (copy-tree %options))) + (let ((metaclass 'standard-class)) + (dolist (option options) + (aver (listp option)) + (when (eq (car option) :metaclass) + (aver (legal-class-name-p (cadr option))) + (setq metaclass + (case (cadr option) + (cl:standard-class 'standard-class) + (cl:structure-class 'structure-class) + (t (cadr option)))) + (setf options (remove option options)) + (return t))) + (let ((*initfunctions-for-this-defclass* ()) + (*readers-for-this-defclass* ()) ;Truly a crock, but we got + (*writers-for-this-defclass* ()) ;to have it to live nicely. + ;; FIXME: Actually, it would seem that + ;; canonicalize-slot-specification actually returns all + ;; the information necessary -- these variables are here + ;; simply so as to avoid grovelling the slot list twice. + ;; Given the extra complexity (and horizontal indent) that + ;; their presence produces, maybe they could be deleted? + (*slot-names-for-this-defclass* ())) + (let ((canonical-slots + (mapcar (lambda (spec) + (canonicalize-slot-specification name spec)) + slots)) + (other-initargs + (mapcar (lambda (option) + (canonicalize-defclass-option name option)) + options))) + (let ((defclass-form + `(progn + ,@(mapcar (lambda (x) + `(declaim (ftype (function (t) t) ,x))) + *readers-for-this-defclass*) + ,@(mapcar (lambda (x) + `(declaim (ftype (function (t t) t) ,x))) + *writers-for-this-defclass*) + #-sb-xc-host + ,@(mapcar (lambda (x) + `(declaim (ftype (function (t) t) + ,(slot-reader-name x) + ,(slot-boundp-name x)) + (ftype (function (t t) t) + ,(slot-writer-name x)))) + *slot-names-for-this-defclass*) + (let ,(mapcar #'cdr *initfunctions-for-this-defclass*) + (cold-load-defclass + ',name ',metaclass ',supers + (list ,@canonical-slots) + ;; direct rewrite of non-DEFSTRUCT-P code. + (list ,@(apply #'append nil other-initargs))))))) + `(progn + (eval-when (:compile-toplevel) + (preinform-compiler-about-class-type ',name)) + ,defclass-form))))))) + +(defun cold-load-defclass (name metaclass supers cslots coptions) + (let ((ecd (make-early-class-definition + name *load-pathname* metaclass (copy-tree supers) + (copy-tree cslots) (copy-tree coptions))) + (existing (find name *early-class-definitions* + :key #'ecd-class-name))) (setq *early-class-definitions* (cons ecd (remove existing *early-class-definitions*))) ecd)) - Index: defs.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/defs.lisp,v retrieving revision 1.26 retrieving revision 1.26.4.1 diff -u -d -r1.26 -r1.26.4.1 --- defs.lisp 31 Jan 2003 09:28:36 -0000 1.26 +++ defs.lisp 27 Feb 2003 13:34:15 -0000 1.26.4.1 @@ -21,7 +21,7 @@ ;;;; warranty about the software, its performance or its conformity to any ;;;; specification. -(in-package "SB-PCL") +(in-package "SB!PCL") ;;; (These are left over from the days when PCL was an add-on package ;;; for a pre-CLOS Common Lisp. They shouldn't happen in a normal @@ -63,7 +63,7 @@ ;;; definition without affecting the trace. (defun fdefine-carefully (name new-definition) (progn - (sb-c::note-name-defined name :function) + (sb!c::note-name-defined name :function) new-definition) (setf (fdefinition name) new-definition)) @@ -148,9 +148,9 @@ :object (coerce-to-class (car args)))) (class-eq (class-eq-specializer (coerce-to-class (car args)))) (eql (intern-eql-specializer (car args)))))) - ((and (null args) (typep type 'cl:class)) - (or (sb-kernel:class-pcl-class type) - (find-structure-class (cl:class-name type)))) + ((and (null args) (typep type 'sb!xc:class)) + (or (sb!kernel:class-pcl-class type) + (find-structure-class (sb!xc:class-name type)))) ((specializerp type) type))) ;;; interface @@ -216,7 +216,7 @@ ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type (cdr type)))) ((class class-eq) ; class-eq is impossible to do right - (sb-kernel:layout-class (class-wrapper (cadr type)))) + (sb!kernel:layout-class (class-wrapper (cadr type)))) (eql type) (t (if (null (cdr type)) (car type) @@ -227,7 +227,7 @@ ;;; SUBTYPEP in place of just returning (VALUES NIL NIL) can be very ;;; slow. *SUBTYPEP is used by PCL itself, and must be fast. ;;; -;;; FIXME: SB-KERNEL has fast-and-not-quite-precise type code for use +;;; FIXME: SB!KERNEL has fast-and-not-quite-precise type code for use ;;; in the compiler. Could we share some of it here? (defun *subtypep (type1 type2) (if (equal type1 type2) @@ -303,7 +303,7 @@ ;;; FIXME: This was the portable PCL way of setting up ;;; *BUILT-IN-CLASSES*, but in SBCL (as in CMU CL) it's almost ;;; entirely wasted motion, since it's immediately overwritten by a -;;; result mostly derived from SB-KERNEL::*BUILT-IN-CLASSES*. However, +;;; result mostly derived from SB!KERNEL::*BUILT-IN-CLASSES*. However, ;;; we can't just delete it, since the fifth element from each entry ;;; (a prototype of the class) is still in the final result. It would ;;; be nice to clean this up so that the other, never-used stuff is @@ -311,7 +311,7 @@ ;;; class, too. ;;; ;;; FIXME: This can probably be blown away after bootstrapping. -;;; And SB-KERNEL::*BUILT-IN-CLASSES*, too.. +;;; And SB!KERNEL::*BUILT-IN-CLASSES*, too.. #| (defvar *built-in-classes* ;; name supers subs cdr of cpl @@ -340,6 +340,7 @@ #()) (string (vector) () (vector array sequence t) "") + #+nil (bit-vector (vector) () (vector array sequence t) #*1) (character (t) () (t) @@ -352,22 +353,22 @@ nil))) |# -;;; Grovel over SB-KERNEL::*BUILT-IN-CLASSES* in order to set +;;; Grovel over SB!KERNEL::*BUILT-IN-CLASSES* in order to set ;;; SB-PCL:*BUILT-IN-CLASSES*. -(/show "about to set up SB-PCL::*BUILT-IN-CLASSES*") +(/show "about to set up SB!PCL::*BUILT-IN-CLASSES*") (defvar *built-in-classes* (labels ((direct-supers (class) - (/noshow "entering DIRECT-SUPERS" (sb-kernel::class-name class)) - (if (typep class 'cl:built-in-class) - (sb-kernel:built-in-class-direct-superclasses class) - (let ((inherits (sb-kernel:layout-inherits - (sb-kernel:class-layout class)))) + (/noshow "entering DIRECT-SUPERS" (sb!kernel::class-name class)) + (if (typep class 'sb!xc:built-in-class) + (sb!kernel:built-in-class-direct-superclasses class) + (let ((inherits (sb!kernel:layout-inherits + (sb!kernel:class-layout class)))) (/noshow inherits) (list (svref inherits (1- (length inherits))))))) (direct-subs (class) - (/noshow "entering DIRECT-SUBS" (sb-kernel::class-name class)) + (/noshow "entering DIRECT-SUBS" (sb!kernel::class-name class)) (collect ((res)) - (let ((subs (sb-kernel:class-subclasses class))) + (let ((subs (sb!kernel:class-subclasses class))) (/noshow subs) (when subs (dohash (sub v subs) @@ -385,9 +386,11 @@ (sequence . nil) (list . nil) (cons . (nil)) + #+nil (array . #2a((nil))) (vector . #()) (string . "") + #+nil ; fasl restrictions (bit-vector . #*1) (character . #\c) (symbol . symbol) @@ -402,96 +405,96 @@ (mapcar (lambda (kernel-bic-entry) (/noshow "setting up" kernel-bic-entry) (let* ((name (car kernel-bic-entry)) - (class (cl:find-class name))) + (class (sb!xc:find-class name))) (/noshow name class) `(,name - ,(mapcar #'cl:class-name (direct-supers class)) - ,(mapcar #'cl:class-name (direct-subs class)) + ,(mapcar #'sb!xc:class-name (direct-supers class)) + ,(mapcar #'sb!xc:class-name (direct-subs class)) ,(map 'list (lambda (x) - (cl:class-name (sb-kernel:layout-class x))) + (sb!xc:class-name (sb!kernel:layout-class x))) (reverse - (sb-kernel:layout-inherits - (sb-kernel:class-layout class)))) + (sb!kernel:layout-inherits + (sb!kernel:class-layout class)))) ,(prototype name)))) (remove-if (lambda (kernel-bic-entry) (member (first kernel-bic-entry) ;; I'm not sure why these are removed from ;; the list, but that's what the original ;; CMU CL code did. -- WHN 20000715 - '(t sb-kernel:instance - sb-kernel:funcallable-instance + '(t sb!kernel:instance + sb!kernel:funcallable-instance function stream))) - sb-kernel::*built-in-classes*)))) -(/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*") + sb!kernel::*built-in-classes*)))) +(/noshow "done setting up SB!PCL::*BUILT-IN-CLASSES*") ;;;; the classes that define the kernel of the metabraid -(defclass t () () +(cold-defclass t () () (:metaclass built-in-class)) -(defclass sb-kernel:instance (t) () +(cold-defclass sb!kernel:instance (t) () (:metaclass built-in-class)) -(defclass function (t) () +(cold-defclass function (t) () (:metaclass built-in-class)) -(defclass sb-kernel:funcallable-instance (function) () +(cold-defclass sb!kernel:funcallable-instance (function) () (:metaclass built-in-class)) -(defclass stream (sb-kernel:instance) () +(cold-defclass stream (sb!kernel:instance) () (:metaclass built-in-class)) -(defclass slot-object (t) () +(cold-defclass slot-object (t) () (:metaclass slot-class)) -(defclass structure-object (slot-object sb-kernel:instance) () +(cold-defclass structure-object (slot-object sb!kernel:instance) () (:metaclass structure-class)) (defstruct (dead-beef-structure-object (:constructor |STRUCTURE-OBJECT class constructor|) (:copier nil))) -(defclass std-object (slot-object) () +(cold-defclass std-object (slot-object) () (:metaclass std-class)) -(defclass standard-object (std-object sb-kernel:instance) ()) +(cold-defclass standard-object (std-object sb!kernel:instance) ()) -(defclass funcallable-standard-object (std-object - sb-kernel:funcallable-instance) +(cold-defclass funcallable-standard-object (std-object + sb!kernel:funcallable-instance) () (:metaclass funcallable-standard-class)) -(defclass specializer (standard-object) +(cold-defclass specializer (standard-object) ((type :initform nil :reader specializer-type))) -(defclass definition-source-mixin (std-object) +(cold-defclass definition-source-mixin (std-object) ((source :initform *load-pathname* :reader definition-source :initarg :definition-source)) (:metaclass std-class)) -(defclass plist-mixin (std-object) +(cold-defclass plist-mixin (std-object) ((plist :initform () :accessor object-plist)) (:metaclass std-class)) -(defclass documentation-mixin (plist-mixin) +(cold-defclass documentation-mixin (plist-mixin) () (:metaclass std-class)) -(defclass dependent-update-mixin (plist-mixin) +(cold-defclass dependent-update-mixin (plist-mixin) () (:metaclass std-class)) ;;; The class CLASS is a specified basic class. It is the common ;;; superclass of any kind of class. That is, any class that can be a ;;; metaclass must have the class CLASS in its class precedence list. -(defclass class (documentation-mixin +(cold-defclass class (documentation-mixin dependent-update-mixin definition-source-mixin specializer) @@ -519,7 +522,7 @@ ;;; The class PCL-CLASS is an implementation-specific common ;;; superclass of all specified subclasses of the class CLASS. -(defclass pcl-class (class) +(cold-defclass pcl-class (class) ((class-precedence-list :reader class-precedence-list) (can-precede-list @@ -535,7 +538,7 @@ :initform nil :reader class-prototype))) -(defclass slot-class (pcl-class) +(cold-defclass slot-class (pcl-class) ((direct-slots :initform () :accessor class-direct-slots) @@ -549,20 +552,20 @@ ;;; The class STD-CLASS is an implementation-specific common ;;; superclass of the classes STANDARD-CLASS and ;;; FUNCALLABLE-STANDARD-CLASS. -(defclass std-class (slot-class) +(cold-defclass std-class (slot-class) ()) -(defclass standard-class (std-class) +(cold-defclass standard-class (std-class) ()) -(defclass funcallable-standard-class (std-class) +(cold-defclass funcallable-standard-class (std-class) ()) -(defclass forward-referenced-class (pcl-class) ()) +(cold-defclass forward-referenced-class (pcl-class) ()) -(defclass built-in-class (pcl-class) ()) +(cold-defclass built-in-class (pcl-class) ()) -(defclass structure-class (slot-class) +(cold-defclass structure-class (slot-class) ((defstruct-form :initform () :accessor class-defstruct-form) @@ -573,22 +576,22 @@ :initform nil :initarg :from-defclass-p))) -(defclass specializer-with-object (specializer) ()) +(cold-defclass specializer-with-object (specializer) ()) -(defclass exact-class-specializer (specializer) ()) +(cold-defclass exact-class-specializer (specializer) ()) -(defclass class-eq-specializer (exact-class-specializer +(cold-defclass class-eq-specializer (exact-class-specializer specializer-with-object) ((object :initarg :class :reader specializer-class :reader specializer-object))) -(defclass class-prototype-specializer (specializer-with-object) +(cold-defclass class-prototype-specializer (specializer-with-object) ((object :initarg :class :reader specializer-class :reader specializer-object))) -(defclass eql-specializer (exact-class-specializer specializer-with-object) +(cold-defclass eql-specializer (exact-class-specializer specializer-with-object) ((object :initarg :object :reader specializer-object :reader eql-specializer-object))) @@ -601,7 +604,7 @@ ;;;; slot definitions -(defclass slot-definition (standard-object) +(cold-defclass slot-definition (standard-object) ((name :initform nil :initarg :name @@ -638,7 +641,7 @@ :initarg :class :accessor slot-definition-class))) -(defclass standard-slot-definition (slot-definition) +(cold-defclass standard-slot-definition (slot-definition) ((allocation :initform :instance :initarg :allocation @@ -648,7 +651,7 @@ :initarg :allocation-class :accessor slot-definition-allocation-class))) -(defclass structure-slot-definition (slot-definition) +(cold-defclass structure-slot-definition (slot-definition) ((defstruct-accessor-symbol :initform nil :initarg :defstruct-accessor-symbol @@ -662,10 +665,10 @@ :initarg :internal-writer-function :accessor slot-definition-internal-writer-function))) -(defclass direct-slot-definition (slot-definition) +(cold-defclass direct-slot-definition (slot-definition) ()) -(defclass effective-slot-definition (slot-definition) +(cold-defclass effective-slot-definition (slot-definition) ((reader-function ; (lambda (object) ...) :accessor slot-definition-reader-function) (writer-function ; (lambda (new-value object) ...) @@ -675,27 +678,27 @@ (accessor-flags :initform 0))) -(defclass standard-direct-slot-definition (standard-slot-definition +(cold-defclass standard-direct-slot-definition (standard-slot-definition direct-slot-definition) ()) -(defclass standard-effective-slot-definition (standard-slot-definition +(cold-defclass standard-effective-slot-definition (standard-slot-definition effective-slot-definition) ((location ; nil, a fixnum, a cons: (slot-name . value) :initform nil :accessor slot-definition-location))) -(defclass structure-direct-slot-definition (structure-slot-definition +(cold-defclass structure-direct-slot-definition (structure-slot-definition direct-slot-definition) ()) -(defclass structure-effective-slot-definition (structure-slot-definition +(cold-defclass structure-effective-slot-definition (structure-slot-definition effective-slot-definition) ()) -(defclass method (standard-object) ()) +(cold-defclass method (standard-object) ()) -(defclass standard-method (definition-source-mixin plist-mixin method) +(cold-defclass standard-method (definition-source-mixin plist-mixin method) ((generic-function :initform nil :accessor method-generic-function) @@ -724,7 +727,7 @@ ;;; :reader method-documentation) )) -(defclass standard-accessor-method (standard-method) +(cold-defclass standard-accessor-method (standard-method) ((slot-name :initform nil :initarg :slot-name :reader accessor-method-slot-name) @@ -732,13 +735,13 @@ :initarg :slot-definition :reader accessor-method-slot-definition))) -(defclass standard-reader-method (standard-accessor-method) ()) +(cold-defclass standard-reader-method (standard-accessor-method) ()) -(defclass standard-writer-method (standard-accessor-method) ()) +(cold-defclass standard-writer-method (standard-accessor-method) ()) -(defclass standard-boundp-method (standard-accessor-method) ()) +(cold-defclass standard-boundp-method (standard-accessor-method) ()) -(defclass generic-function (dependent-update-mixin +(cold-defclass generic-function (dependent-update-mixin definition-source-mixin documentation-mixin funcallable-standard-object) @@ -758,7 +761,7 @@ :accessor generic-function-initial-methods)) (:metaclass funcallable-standard-class)) -(defclass standard-generic-function (generic-function) +(cold-defclass standard-generic-function (generic-function) ((name :initform nil :initarg :name @@ -787,9 +790,9 @@ (:default-initargs :method-class *the-class-standard-method* :method-combination *standard-method-combination*)) -(defclass method-combination (standard-object) ()) +(cold-defclass method-combination (standard-object) ()) -(defclass standard-method-combination (definition-source-mixin +(cold-defclass standard-method-combination (definition-source-mixin method-combination) ((type :reader method-combination-type @@ -801,7 +804,7 @@ :reader method-combination-options :initarg :options))) -(defclass long-method-combination (standard-method-combination) +(cold-defclass long-method-combination (standard-method-combination) ((function :initarg :function :reader long-method-combination-function) Index: std-class.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v retrieving revision 1.37 retrieving revision 1.37.2.1 diff -u -d -r1.37 -r1.37.2.1 --- std-class.lisp 15 Feb 2003 11:16:35 -0000 1.37 +++ std-class.lisp 27 Feb 2003 13:34:15 -0000 1.37.2.1 @@ -315,7 +315,7 @@ (declare (ignore slot-names)) (setf (slot-value specl 'type) `(eql ,(specializer-object specl)))) -(defun real-load-defclass (name metaclass-name supers slots other) +(defun load-defclass (name metaclass-name supers slots other) (let ((res (apply #'ensure-class name :metaclass metaclass-name :direct-superclasses supers :direct-slots slots @@ -327,8 +327,6 @@ ;; does not yet exist. Maybe should return NIL in that case as RES ;; is not useful to the user? (and (class-wrapper res) (sb-kernel:layout-class (class-wrapper res))))) - -(setf (gdefinition 'load-defclass) #'real-load-defclass) (defun ensure-class (name &rest all) (apply #'ensure-class-using-class name (find-class name nil) all)) |