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

diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp
index edaa3e6..1309b5d 100644
--- a/src/pcl/defclass.lisp
+++ b/src/pcl/defclass.lisp
@@ -22,42 +22,7 @@
 ;;;; specification.
 
 (in-package "SB-PCL")
-
-(sb-int:file-comment
-  "$Header$")
 
-;;; MAKE-TOP-LEVEL-FORM is used by all PCL macros that appear `at top-level'.
-;;;
-;;; The original motiviation for this function was to deal with the bug in
-;;; the Genera compiler that prevents lambda expressions in top-level forms
-;;; other than DEFUN from being compiled.
-;;;
-;;; Now this function is used to grab other functionality as well. This
-;;; includes:
-;;;   - Preventing the grouping of top-level forms. For example, a
-;;;     DEFCLASS followed by a DEFMETHOD may not want to be grouped
-;;;     into the same top-level form.
-;;;   - Telling the programming environment what the pretty version
-;;;     of the name of this form is. This is used by WARN.
-;;;
-;;; FIXME: It's not clear that this adds value any more. Couldn't
-;;; we just use EVAL-WHEN?
-(defun make-top-level-form (name times form)
-  (flet ((definition-name ()
-	   (if (and (listp name)
-		    (memq (car name)
-			  '(defmethod defclass class
-			    method method-combination)))
-	       (format nil "~A~{ ~S~}"
-		       (capitalize-words (car name) ()) (cdr name))
-	       (format nil "~S" name))))
-    ;; FIXME: It appears that we're just consing up a string and then
-    ;; throwing it away?!
-    (definition-name)
-    (if (or (member 'compile times)
-	    (member ':compile-toplevel times))
-	`(eval-when ,times ,form)
-	form)))
 
 (defun make-progn (&rest forms)
   (let ((progn-form nil))
@@ -71,24 +36,19 @@
       (collect-forms forms)
       (cons 'progn progn-form))))
 
-;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is fixed.
-;;; DEFCLASS always expands into a call to LOAD-DEFCLASS. Until the meta-
-;;; braid is set up, LOAD-DEFCLASS has a special definition which simply
-;;; collects all class definitions up, when the metabraid is initialized it
-;;; is done from those class definitions.
+;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is
+;;; fixed. DEFCLASS always expands into a call to LOAD-DEFCLASS. Until
+;;; the meta-braid is set up, LOAD-DEFCLASS has a special definition
+;;; which simply collects all class definitions up, when the metabraid
+;;; is initialized it is done from those class definitions.
 ;;;
-;;; 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)
-  (declare (indentation 2 4 3 1))
-  (expand-defclass name direct-superclasses direct-slots options))
-
-(defun expand-defclass (name supers slots options)
-  (declare (special *defclass-times* *boot-state* *the-class-structure-class*))
-  (setq supers  (copy-tree supers)
-	slots   (copy-tree slots)
-	options (copy-tree options))
+;;; 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)
+  (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))
@@ -107,10 +67,9 @@
 	    (return t))))
 
     (let ((*initfunctions* ())
-	  (*accessors* ())		;Truly a crock, but we got
-	  (*readers* ())		;to have it to live nicely.
-	  (*writers* ()))
-      (declare (special *initfunctions* *accessors* *readers* *writers*))
+	  (*readers* ())		;Truly a crock, but we got
+	  (*writers* ()))               ;to have it to live nicely.
+      (declare (special *initfunctions* *readers* *writers*))
       (let ((canonical-slots
 	      (mapcar #'(lambda (spec)
 			  (canonicalize-slot-specification name spec))
@@ -119,57 +78,78 @@
 	      (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
-				     (*subtypep mclass
-						*the-class-structure-class*))))))
-	(do-standard-defsetfs-for-defclass *accessors*)
+				     (*subtypep
+				      mclass
+				      *the-class-structure-class*))))))
 	(let ((defclass-form
-		 (make-top-level-form `(defclass ,name)
-		   (if defstruct-p '(:load-toplevel :execute) *defclass-times*)
-		   `(progn
-		      ,@(mapcar #'(lambda (x)
-				    `(declaim (ftype (function (t) t) ,x)))
-				*readers*)
-		      ,@(mapcar #'(lambda (x)
-				    #-setf (when (consp x)
-					     (setq x (get-setf-function-name (cadr 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))
-				       ',*accessors*))))))
+		`(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 (and (eq *boot-state* 'complete)
-			   (not (member 'compile *defclass-times*)))
-		  (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 true))
-	((or (eq initform 'nil)
+	 '(function constantly-t))
+	((or (eq initform nil)
 	     (equal initform ''nil))
-	 '(function false))
-	((or (eql initform '0)
+	 '(function constantly-nil))
+	((or (eql initform 0)
 	     (equal initform ''0))
-	 '(function zero))
+	 '(function constantly-0))
 	(t
 	 (let ((entry (assoc initform *initfunctions* :test #'equal)))
 	   (unless entry
@@ -180,7 +160,7 @@
 	   (cadr entry)))))
 
 (defun canonicalize-slot-specification (class-name spec)
-  (declare (special *accessors* *readers* *writers*))
+  (declare (special *readers* *writers*))
   (cond ((and (symbolp spec)
 	      (not (keywordp spec))
 	      (not (memq spec '(t nil))))
@@ -202,8 +182,7 @@
 		(initform (getf spec :initform unsupplied)))
 	   (doplist (key val) spec
 	     (case key
-	       (:accessor (push val *accessors*)
-			  (push val readers)
+	       (:accessor (push val readers)
 			  (push `(setf ,val) writers))
 	       (:reader   (push val readers))
 	       (:writer   (push val writers))
@@ -322,72 +301,72 @@
 	(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)))))))
     (reverse default-initargs)))
 
-(defun bootstrap-slot-index (class-name slot-name)
+(defun !bootstrap-slot-index (class-name slot-name)
   (or (position slot-name (early-class-slots class-name))
       (error "~S not found" slot-name)))
 
-;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change the
-;;; values of slots during bootstrapping. During bootstrapping, there are only
-;;; two kinds of objects whose slots we need to access, CLASSes and
-;;; SLOT-DEFINITIONs. The first argument to these functions tells whether the
-;;; object is a CLASS or a SLOT-DEFINITION.
+;;; !BOOTSTRAP-GET-SLOT and !BOOTSTRAP-SET-SLOT are used to access and
+;;; change the values of slots during bootstrapping. During
+;;; bootstrapping, there are only two kinds of objects whose slots we
+;;; need to access, CLASSes and SLOT-DEFINITIONs. The first argument
+;;; to these functions tells whether the object is a CLASS or a
+;;; SLOT-DEFINITION.
 ;;;
-;;; Note that the way this works it stores the slot in the same place in
-;;; memory that the full object system will expect to find it later. This
-;;; is critical to the bootstrapping process, the whole changeover to the
-;;; full object system is predicated on this.
+;;; Note that the way this works it stores the slot in the same place
+;;; in memory that the full object system will expect to find it
+;;; later. This is critical to the bootstrapping process, the whole
+;;; changeover to the full object system is predicated on this.
 ;;;
-;;; One important point is that the layout of standard classes and 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)))
-(defun bootstrap-set-slot (type object slot-name new-value)
-  (setf (bootstrap-get-slot type object slot-name) new-value))
+;;; One important point is that the layout of standard classes and
+;;; 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)
+  `(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))
 
 (defun early-class-name (class)
-  (bootstrap-get-slot 'class class 'name))
+  (!bootstrap-get-slot 'class class 'name))
 
 (defun early-class-precedence-list (class)
-  (bootstrap-get-slot 'pcl-class class 'class-precedence-list))
+  (!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))
+  (!bootstrap-get-slot 'slot-class class 'slots))
 
 (defun early-slot-definition-name (slotd)
-  (bootstrap-get-slot 'standard-effective-slot-definition slotd 'name))
+  (!bootstrap-get-slot 'standard-effective-slot-definition slotd 'name))
 
 (defun early-slot-definition-location (slotd)
-  (bootstrap-get-slot 'standard-effective-slot-definition slotd 'location))
+  (!bootstrap-get-slot 'standard-effective-slot-definition slotd 'location))
 
 (defun early-accessor-method-slot-name (method)
-  (bootstrap-get-slot 'standard-accessor-method method 'slot-name))
+  (!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)))
-;;; FIXME: Can we then delete EARLY-CLASS-NAME-OF?
+(unintern 'early-class-name-of)
 
 (defun early-class-direct-subclasses (class)
-  (bootstrap-get-slot 'class class 'direct-subclasses))
+  (!bootstrap-get-slot 'class class 'direct-subclasses))
 
 (declaim (notinline load-defclass))
-(defun load-defclass
-       (name metaclass supers canonical-slots canonical-options accessor-names)
+(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))
-  (do-standard-defsetfs-for-defclass accessor-names)
   (when (eq metaclass 'standard-class)
     (inform-type-system-about-std-class name))
   (let ((ecd