X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefclass.lisp;h=363c960e33e1b52ef119b85e144638f2eae9fc04;hb=cd99f20d910298cbf5c2000e3dc3595fb0c8418b;hp=c616ed68bb5874d45eceed5c1cfc375b8c94e69c;hpb=2217cdb364e8b48c187b085895bb2a5cbdbd9622;p=sbcl.git

diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp
index c616ed6..363c960 100644
--- a/src/pcl/defclass.lisp
+++ b/src/pcl/defclass.lisp
@@ -44,6 +44,28 @@
     (setf (info :type :kind name) :forthcoming-defclass-type))
   (values))
 
+(defun preinform-compiler-about-accessors (readers writers slots)
+  (flet ((inform (name type)
+           ;; FIXME: This matches what PROCLAIM FTYPE does, except
+           ;; that :WHERE-FROM is :DEFINED, not :DECLARED, and should
+           ;; probably be factored into a common function -- eg.
+           ;; (%proclaim-ftype name declared-or-defined).
+           (when (eq (info :function :where-from name) :assumed)
+             (proclaim-as-fun-name name)
+             (note-name-defined name :function)
+             (setf (info :function :where-from name) :defined
+                   (info :function :type name) type))))
+    (let ((rtype (specifier-type '(function (t) t)))
+          (wtype (specifier-type '(function (t t) t))))
+      (dolist (reader readers)
+        (inform reader rtype))
+      (dolist (writer writers)
+        (inform writer wtype))
+      (dolist (slot slots)
+        (inform (slot-reader-name slot) rtype)
+        (inform (slot-boundp-name slot) rtype)
+        (inform (slot-writer-name slot) wtype)))))
+
 ;;; state for the current DEFCLASS expansion
 (defvar *initfunctions-for-this-defclass*)
 (defvar *readers-for-this-defclass*)
@@ -59,7 +81,7 @@
 ;;; 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)
+(defmacro defclass (&environment env name %direct-superclasses %direct-slots &rest %options)
   (let ((supers  (copy-tree %direct-superclasses))
 	(slots   (copy-tree %direct-slots))
 	(options (copy-tree %options)))
@@ -72,11 +94,7 @@
 	      (error "The value of the :metaclass option (~S) is not a~%~
 		      legal class name."
 		     (cadr option)))
-	    (setq metaclass
-                    (case (cadr option)
-                      (cl:standard-class 'standard-class)
-                      (cl:structure-class 'structure-class)
-                      (t (cadr option))))
+	    (setq metaclass (cadr option))
 	    (setf options (remove option options))
 	    (return t))))
 
@@ -86,7 +104,7 @@
             (*slot-names-for-this-defclass* ()))
         (let ((canonical-slots
                 (mapcar (lambda (spec)
-			  (canonicalize-slot-specification name spec))
+			  (canonicalize-slot-specification name spec env))
                         slots))
               (other-initargs
                 (mapcar (lambda (option)
@@ -101,30 +119,19 @@
                                        (*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)))))))
+          (let* ((defclass-form
+                     `(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))
+                                        ',*readers-for-this-defclass*
+                                        ',*writers-for-this-defclass*
+                                        ',*slot-names-for-this-defclass*))))
             (if defstruct-p
 		(progn
 		  ;; FIXME: (YUK!) Why do we do this? Because in order
@@ -144,7 +151,8 @@
 				      (and (not (eq name 'structure-object))
 					   *the-class-structure-object*)))
 			 (defstruct-form (make-structure-class-defstruct-form
-					  name (class-direct-slots (find-class name)) include)))
+					  name (class-direct-slots (find-class name))
+					  include)))
 		    `(progn
 		      (eval-when (:compile-toplevel :load-toplevel :execute)
 			,defstruct-form) ; really compile the defstruct-form
@@ -162,8 +170,16 @@
 		   ;; full-blown class, so the "a class of this name is
 		   ;; coming" note we write here would be irrelevant.
 		   (eval-when (:compile-toplevel)
-		     (preinform-compiler-about-class-type ',name))
-		   ,defclass-form))))))))
+		     (%compiler-defclass ',name 
+                                         ',*readers-for-this-defclass*
+                                         ',*writers-for-this-defclass*
+                                         ',*slot-names-for-this-defclass*))
+		   (eval-when (:load-toplevel :execute)
+		     ,defclass-form)))))))))
+
+(defun %compiler-defclass (name readers writers slots)
+  (preinform-compiler-about-class-type name)
+  (preinform-compiler-about-accessors readers writers slots))
 
 (defun make-initfunction (initform)
   (cond ((or (eq initform t)
@@ -185,52 +201,72 @@
 	     (push entry *initfunctions-for-this-defclass*))
 	   (cadr entry)))))
 
-(defun canonicalize-slot-specification (class-name spec)
-  (cond ((and (symbolp spec)
-	      (not (keywordp spec))
-	      (not (memq spec '(t nil))))
-         (push spec *slot-names-for-this-defclass*)
-	 `'(:name ,spec))
-	((not (consp spec))
-	 (error "~S is not a legal slot specification." spec))
-	((null (cdr spec))
-         (push (car spec) *slot-names-for-this-defclass*)
+(defun canonicalize-slot-specification (class-name spec env)
+  (labels ((slot-name-illegal (reason)
+	     (error 'simple-program-error
+		    :format-control
+		    (format nil "~~@<in DEFCLASS ~~S, the slot name in the ~
+                                 specification ~~S is ~A.~~@:>" reason)
+		    :format-arguments (list class-name spec)))
+	   (check-slot-name-legality (name)
+	     (cond
+	       ((not (symbolp name))
+		(slot-name-illegal "not a symbol"))
+	       ((keywordp name)
+		(slot-name-illegal "a keyword"))
+	       ((constantp name env)
+		(slot-name-illegal "a constant")))))
+    (cond ((atom spec)
+	   (check-slot-name-legality spec)
+	   (push spec *slot-names-for-this-defclass*)
+	   `'(:name ,spec))
+	  ((null (cdr spec))
+	   (check-slot-name-legality (car 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))))
-	(t
-	 (let* ((name (pop spec))
-		(readers ())
-		(writers ())
-		(initargs ())
-		(unsupplied (list nil))
-		(initform (getf spec :initform unsupplied)))
-           (push name *slot-names-for-this-defclass*)
-	   (doplist (key val) spec
-	     (case key
-	       (:accessor (push val readers)
-			  (push `(setf ,val) writers))
-	       (:reader   (push val readers))
-	       (:writer   (push val writers))
-	       (:initarg  (push val initargs))))
-	   (loop (unless (remf spec :accessor) (return)))
-	   (loop (unless (remf spec :reader)   (return)))
-	   (loop (unless (remf spec :writer)   (return)))
-	   (loop (unless (remf spec :initarg)  (return)))
-	   (setq *writers-for-this-defclass*
-		 (append writers *writers-for-this-defclass*))
-	   (setq *readers-for-this-defclass*
-		 (append readers *readers-for-this-defclass*))
-	   (setq spec `(:name     ',name
-			:readers  ',readers
-			:writers  ',writers
-			:initargs ',initargs
-			',spec))
-	   (if (eq initform unsupplied)
-	       `(list* ,@spec)
-	       `(list* :initfunction ,(make-initfunction initform) ,@spec))))))
+	  ((null (cddr spec))
+	   (error 'simple-program-error
+		  :format-control
+		  "~@<in DEFCLASS ~S, the slot specification ~S is invalid; ~
+                   the probable intended meaning may be achieved by ~
+                   specifiying ~S instead.~>"
+		  :format-arguments
+		  (list class-name spec
+			`(,(car spec) :initform ,(cadr spec)))))
+	  (t
+	   (let* ((name (car spec))
+		  (spec (cdr spec))
+		  (readers ())
+		  (writers ())
+		  (initargs ())
+		  (unsupplied (list nil))
+		  (initform (getf spec :initform unsupplied)))
+	     (check-slot-name-legality name)
+	     (push name *slot-names-for-this-defclass*)
+	     (doplist (key val) spec
+	       (case key
+		 (:accessor (push val readers)
+			    (push `(setf ,val) writers))
+		 (:reader   (push val readers))
+		 (:writer   (push val writers))
+		 (:initarg  (push val initargs))))
+	     (loop (unless (remf spec :accessor) (return)))
+	     (loop (unless (remf spec :reader)   (return)))
+	     (loop (unless (remf spec :writer)   (return)))
+	     (loop (unless (remf spec :initarg)  (return)))
+	     (setq *writers-for-this-defclass*
+		   (append writers *writers-for-this-defclass*))
+	     (setq *readers-for-this-defclass*
+		   (append readers *readers-for-this-defclass*))
+	     (setq spec `(:name     ',name
+			  :readers  ',readers
+			  :writers  ',writers
+			  :initargs ',initargs
+			  ',spec))
+	     (if (eq initform unsupplied)
+		 `(list* ,@spec)
+		 `(list* :initfunction ,(make-initfunction initform)
+		         ,@spec)))))))
 
 (defun canonicalize-defclass-option (class-name option)
   (declare (ignore class-name))
@@ -394,7 +430,10 @@
   (!bootstrap-get-slot 'class class 'direct-subclasses))
 
 (declaim (notinline load-defclass))
-(defun load-defclass (name metaclass supers canonical-slots canonical-options)
+(defun load-defclass (name metaclass supers canonical-slots canonical-options
+                      readers writers slot-names)
+  (%compiler-defclass name readers writers slot-names)
+  (preinform-compiler-about-accessors readers writers slot-names)
   (setq supers  (copy-tree supers)
 	canonical-slots   (copy-tree canonical-slots)
 	canonical-options (copy-tree canonical-options))