X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefclass.lisp;h=bcfb77b1bc3f9662d45430fd4e44da9d28ca57cd;hb=5251267b300cb967cbf547e838037a616064bd58;hp=022f979846c2871e6d4a97bfe6003268ec3fed78;hpb=475c832b081651e66ad9446d4852c62086f5e740;p=sbcl.git

diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp
index 022f979..bcfb77b 100644
--- a/src/pcl/defclass.lisp
+++ b/src/pcl/defclass.lisp
@@ -44,15 +44,11 @@
 ;;;
 ;;; 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 defclass.lisp
+;;; installed by the file std-class.lisp
 (defmacro defclass (name direct-superclasses direct-slots &rest options)
   (expand-defclass name direct-superclasses direct-slots options))
 
 (defun expand-defclass (name supers slots options)
-  ;; FIXME: We should probably just ensure that the relevant
-  ;; DEFVAR/DEFPARAMETERs occur before this definition, rather 
-  ;; than locally declaring them SPECIAL.
-  (declare (special *boot-state* *the-class-structure-class*))
   (setq supers  (copy-tree supers)
 	slots   (copy-tree slots)
 	options (copy-tree options))
@@ -88,26 +84,37 @@
 	    (defstruct-p (and (eq *boot-state* 'complete)
 			      (let ((mclass (find-class metaclass nil)))
 				(and mclass
-				     (*subtypep mclass
-						*the-class-structure-class*))))))
+				     (*subtypep
+				      mclass
+				      *the-class-structure-class*))))))
 	(let ((defclass-form
-                (eval-when (:load-toplevel :execute)
-                  `(progn
-                    ,@(mapcar #'(lambda (x)
-                                  `(declaim (ftype (function (t) t) ,x)))
-                              *readers*)
-                    ,@(mapcar #'(lambda (x)
-                                  `(declaim (ftype (function (t t) t) ,x)))
-                              *writers*)
-                    (let ,(mapcar #'cdr *initfunctions*)
-                      (load-defclass ',name
-                                     ',metaclass
-                                     ',supers
-                                     (list ,@canonical-slots)
-                                     (list ,@(apply #'append
-                                                    (when defstruct-p
-                                                      '(:from-defclass-p t))
-                                                    other-initargs))))))))
+		`(progn
+		   ,@(mapcar (lambda (x)
+			       `(declaim (ftype (function (t) t) ,x)))
+			     *readers*)
+		   ,@(mapcar (lambda (x)
+			       `(declaim (ftype (function (t t) t) ,x)))
+			     *writers*)
+		   (let ,(mapcar #'cdr *initfunctions*)
+		     (load-defclass ',name
+				    ',metaclass
+				    ',supers
+				    (list ,@canonical-slots)
+				    (list ,@(apply #'append
+						   (when defstruct-p
+						     '(:from-defclass-p t))
+						   other-initargs)))))))
+	  ;; FIXME: The way that we do things like (EVAL DEFCLASS-FORM)
+	  ;; here is un-ANSI-Common-Lisp-y and leads to problems
+	  ;; (like DEFUN for the type predicate being called more than
+	  ;; once when we do DEFCLASS at the interpreter prompt),
+	  ;; causing bogus style warnings. It would be better to
+	  ;; rewrite this so that the macroexpansion looks like e.g.
+	  ;; (PROGN
+	  ;;   (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
+	  ;;     (FROB1 ..))
+	  ;;   (EVAL-WHEN (:LOAD-TOPLEVEL :EXECUTE)
+	  ;;     (FROB2 ..)))
 	  (if defstruct-p
 	      (progn
 		(eval defclass-form) ; Define the class now, so that..
@@ -116,18 +123,34 @@
 		   ,defclass-form))
 	      (progn
 		(when (eq *boot-state* 'complete)
+		  ;; FIXME: MNA (on sbcl-devel 2001-05-30) reported
+		  ;; (if I understand correctly -- WHN) that this call
+		  ;; is directly responsible for defining
+		  ;; class-predicates which always return
+		  ;; CONSTANTLY-NIL in the compile-time environment,
+		  ;; and is indirectly responsible for bogus warnings
+		  ;; about redefinitions when making definitions in
+		  ;; the interpreter. I didn't like his fix (deleting
+		  ;; the call) since I think the type system *should*
+		  ;; be informed about class definitions here. And I'm
+		  ;; not eager to look too deeply into this sort of
+		  ;; done-too-many-times-in-the-interpreter problem
+		  ;; right now, since it should be easier to make a
+		  ;; clean fix when EVAL-WHEN is made more ANSI (as
+		  ;; per the IR1 section in the BUGS file). But
+		  ;; at some point this should be cleaned up.
 		  (inform-type-system-about-std-class name))
 		defclass-form)))))))
 
 (defun make-initfunction (initform)
   (declare (special *initfunctions*))
-  (cond ((or (eq initform 't)
+  (cond ((or (eq initform t)
 	     (equal initform ''t))
 	 '(function constantly-t))
-	((or (eq initform 'nil)
+	((or (eq initform nil)
 	     (equal initform ''nil))
 	 '(function constantly-nil))
-	((or (eql initform '0)
+	((or (eql initform 0)
 	     (equal initform ''0))
 	 '(function constantly-0))
 	(t
@@ -281,8 +304,8 @@
 	(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 the bootstrap~%~
-			object system."
+		 (error "~@<The defclass option ~S is not supported by ~
+			the bootstrap object system.~:@>"
 			initarg)))
 	      (setq default-initargs
 		    (nconc default-initargs (reverse (pop others)))))))
@@ -308,7 +331,8 @@
 ;;; standard slots must be computed the same way in this file as it is
 ;;; by the full object system later.
 (defmacro !bootstrap-get-slot (type object slot-name)
-  `(instance-ref (get-slots ,object) (!bootstrap-slot-index ,type ,slot-name)))
+  `(clos-slots-ref (get-slots ,object)
+		   (!bootstrap-slot-index ,type ,slot-name)))
 (defun !bootstrap-set-slot (type object slot-name new-value)
   (setf (!bootstrap-get-slot type object slot-name) new-value))