X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefclass.lisp;h=1309b5d2787e165285efb988d8d4f078d6819791;hb=872175cd9cb5b4966a36d4bd92421cc407a0355b;hp=4a66e981ac0426e6cd35c41d57d5fa9542f32292;hpb=26b8ddda97fcfa2e2c0eae3bd2fdb19717c5fa40;p=sbcl.git

diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp
index 4a66e98..1309b5d 100644
--- a/src/pcl/defclass.lisp
+++ b/src/pcl/defclass.lisp
@@ -44,18 +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
-(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))
+;;; installed by the file std-class.lisp
+(defmacro defclass (name %direct-superclasses %direct-slots &rest %options)
+  (setq 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))
@@ -85,6 +78,7 @@
 	      (mapcar #'(lambda (option)
 			  (canonicalize-defclass-option name option))
 		      options))
+	    ;; FIXME: What does this flag mean?
 	    (defstruct-p (and (eq *boot-state* 'complete)
 			      (let ((mclass (find-class metaclass nil)))
 				(and mclass
@@ -92,43 +86,68 @@
 				      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)))))))
 	  (if defstruct-p
 	      (progn
-		(eval defclass-form) ; Define the class now, so that..
-		`(progn	      ; ..the defstruct can be compiled.
-		   ,(class-defstruct-form (find-class name))
-		   ,defclass-form))
-	      (progn
-		(when (eq *boot-state* 'complete)
-		  (inform-type-system-about-std-class name))
-		defclass-form)))))))
+		;; FIXME: The ANSI way to do this is with EVAL-WHEN
+		;; forms, not by side-effects at macroexpansion time.
+		;; But I (WHN 2001-09-02) am not even sure how to
+		;; reach this code path with ANSI (or art-of-the-MOP)
+		;; code, so I haven't tried to update it, since for
+		;; all I know maybe it could just be deleted instead.
+                (eval defclass-form) ; Define the class now, so that..
+                `(progn       ; ..the defstruct can be compiled.
+                   ,(class-defstruct-form (find-class name))
+                   ,defclass-form))
+	      `(progn
+		 ;; By telling the type system at compile time about
+		 ;; the existence of a class named NAME, we can avoid
+		 ;; various bogus warnings about "type isn't defined yet".
+		 ,(when (and
+			 ;; But it's not so important to get rid of
+			 ;; "not defined yet" warnings during
+			 ;; bootstrapping, and machinery like
+			 ;; INFORM-TYPE-SYSTEM-ABOUT-STD-CLASS
+			 ;; mightn't be defined yet. So punt then.
+			 (eq *boot-state* 'complete)
+			 ;; And although we know enough about
+			 ;; STANDARD-CLASS, and ANSI imposes enough
+			 ;; restrictions on the user overloading its
+			 ;; methods, that (1) we can shortcut the
+			 ;; method dispatch and do an ordinary
+			 ;; function call, and (2) be sure we're getting
+			 ;; it right even when we do it at compile
+			 ;; time; we don't in general know how to do
+			 ;; that for other classes. So punt then too.
+			 (eq metaclass 'standard-class))
+		    `(eval-when (:compile-toplevel :load-toplevel :execute)
+		       (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