Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/pcl defclass.lisp,1.25,1.25.2.1 defs.lisp,1.26,1.26.4.1 std-class.lisp,1.37,1.37.2.1
|
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))
|