X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Finit.lisp;h=14475ea1bdd8da639698e4a548f359cb96de962b;hb=0e3c4b4db102bd204a30402d7e5a0de44aea57ce;hp=47b89887ccd6ac5a52a082a74bc4cba9136464ed;hpb=4cf9c8955fc99aa5718eb4b265360578d0de29e0;p=sbcl.git

diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp
index 47b8988..14475ea 100644
--- a/src/pcl/init.lisp
+++ b/src/pcl/init.lisp
@@ -29,193 +29,312 @@
   (apply #'make-instance (find-class class) initargs))
 
 (defmethod make-instance ((class class) &rest initargs)
+  (let ((instance-or-nil (maybe-call-ctor class initargs)))
+    (when instance-or-nil
+      (return-from make-instance instance-or-nil)))
   (unless (class-finalized-p class) (finalize-inheritance class))
-  (setq initargs (default-initargs class initargs))
-  #||
-  (check-initargs-1
-   class initargs
-   (list (list* 'allocate-instance class initargs)
-	 (list* 'initialize-instance (class-prototype class) initargs)
-	 (list* 'shared-initialize (class-prototype class) t initargs)))
-  ||#
-  (let* ((info (initialize-info class initargs))
-	 (valid-p (initialize-info-valid-p info)))
-    (when (and (consp valid-p) (eq (car valid-p) :invalid))
-      (error 'simple-program-error
-	     :format-control "Invalid initialization argument ~S for class ~S"
-	     :format-arguments (list (cdr valid-p) (class-name class)))))
-  (let ((instance (apply #'allocate-instance class initargs)))
-    (apply #'initialize-instance instance initargs)
-    instance))
+  (let ((class-default-initargs (class-default-initargs class)))
+    (when class-default-initargs
+      (setf initargs (default-initargs initargs class-default-initargs)))
+    (when initargs
+      (when (eq **boot-state** 'complete)
+        (check-mi-initargs class initargs)))
+    (let ((instance (apply #'allocate-instance class initargs)))
+      (apply #'initialize-instance instance initargs)
+      instance)))
 
-(defmethod default-initargs ((class slot-class) supplied-initargs)
-  (call-initialize-function
-   (initialize-info-default-initargs-function
-    (initialize-info class supplied-initargs))
-   nil supplied-initargs))
+(defun default-initargs (supplied-initargs class-default-initargs)
+  (loop for (key nil fun) in class-default-initargs
+        when (eq (getf supplied-initargs key '.not-there.) '.not-there.)
+          append (list key (funcall fun)) into default-initargs
+        finally
+          (return (append supplied-initargs default-initargs))))
 
 (defmethod initialize-instance ((instance slot-object) &rest initargs)
   (apply #'shared-initialize instance t initargs))
 
 (defmethod reinitialize-instance ((instance slot-object) &rest initargs)
-  #||
-  (check-initargs-1
-   (class-of instance) initargs
-   (list (list* 'reinitialize-instance instance initargs)
-	 (list* 'shared-initialize instance nil initargs)))
-  ||#
-  (let* ((class (class-of instance))
-	 (info (initialize-info class initargs))
-	 (valid-p (initialize-info-ri-valid-p info)))
-    (when (and (consp valid-p) (eq (car valid-p) :invalid))
-      (error 'simple-program-error 
-	     :format-control "Invalid initialization argument ~S for class ~S"
-	     :format-arguments (list (cdr valid-p) (class-name class)))))
+  ;; the ctor machinery allows us to track when memoization of
+  ;; validity of initargs should be cleared.
+  (check-ri-initargs instance initargs)
   (apply #'shared-initialize instance nil initargs)
   instance)
 
-(defmethod update-instance-for-different-class ((previous std-object)
-						(current std-object)
-						&rest initargs)
+(defglobal **typecheck-cache** (make-hash-table :test #'equal :synchronized t))
+(defvar *typecheck-stack* nil)
+
+(defun generate-slotd-typecheck (slotd info)
+  (let* ((type (slot-definition-type slotd))
+         (class (slot-definition-class slotd))
+         (cookie (cons class (slot-definition-name slotd))))
+    (declare (dynamic-extent cookie))
+    (when (and (neq t type) (safe-p class))
+      (or
+       ;; Have one already!
+       (awhen (gethash type **typecheck-cache**)
+         (setf (slot-info-typecheck info) it))
+       ;; It is possible for compilation of a typecheck to trigger class
+       ;; finalization, which in turn may trigger compilation of a
+       ;; slot-typechecking function -- detects and break those cycles.
+       ;;
+       ;; We use the slow function here, but the outer call will replace it
+       ;; with the fast one.
+       (when (member cookie *typecheck-stack* :test #'equal)
+         (setf (slot-info-typecheck info)
+               (named-lambda slow-slot-typecheck (value)
+                       (if (typep value type)
+                           value
+                           (error 'type-error
+                                  :datum value
+                                  :expected-type type)))))
+       ;; The normal, good case: compile an efficient typecheck function.
+       (let ((*typecheck-stack* (cons cookie *typecheck-stack*)))
+         (handler-bind (((or style-warning compiler-note) #'muffle-warning))
+           (let ((fun (compile
+                       nil
+                       `(named-lambda (slot-typecheck ,type) (value)
+                          (declare (optimize (sb-c:store-coverage-data 0)
+                                             (sb-c::type-check 3)
+                                             (sb-c::verify-arg-count 0)))
+                          (the ,type value)))))
+             (setf (gethash type **typecheck-cache**) fun
+                   (slot-info-typecheck info) fun))))))))
+
+(define-condition slotd-initialization-error (reference-condition error)
+  ((initarg :initarg :initarg :reader slotd-initialization-error-initarg)
+   (kind :initarg :kind :reader slotd-initialization-error-kind)
+   (value :initarg :value :initform nil :reader slotd-initialization-error-value))
+  (:default-initargs :references (list '(:amop :initialization slot-definition)))
+  (:report (lambda (condition stream)
+             (let ((initarg (slotd-initialization-error-initarg condition))
+                   (kind (slotd-initialization-error-kind condition))
+                   (value (slotd-initialization-error-value condition)))
+               (format stream
+                       "~@<Invalid ~S initialization: the initialization ~
+                        argument ~S was ~
+                        ~[missing~*~;not a symbol: ~S~;constant: ~S~].~@:>"
+                       'slot-definition initarg
+                       (getf '(:missing 0 :symbol 1 :constant 2) kind)
+                       value)))))
+
+(define-condition slotd-initialization-type-error (slotd-initialization-error type-error)
+  ((value :initarg :datum))
+  (:report (lambda (condition stream)
+             (let ((initarg (slotd-initialization-error-initarg condition))
+                   (datum (type-error-datum condition))
+                   (expected-type (type-error-expected-type condition)))
+               (format stream
+                       "~@<Invalid ~S initialization: the initialization ~
+                        argument ~S was ~S, which is not of type ~S.~@:>"
+                       'slot-definition initarg
+                       datum expected-type)))))
+
+(defmethod initialize-instance :before ((slotd slot-definition)
+                                        &key (name nil namep)
+                                          (initform nil initformp)
+                                          (initfunction nil initfunp)
+                                          (type nil typep)
+                                          (allocation nil allocationp)
+                                          (initargs nil initargsp)
+                                          (documentation nil docp))
+  (unless namep
+    (error 'slotd-initialization-error :initarg :name :kind :missing))
+  (unless (symbolp name)
+    (error 'slotd-initialization-type-error :initarg :name :datum name :expected-type 'symbol))
+  (when (and (constantp name)
+             ;; KLUDGE: names of structure slots are weird, and their
+             ;; weird behaviour gets grandfathered in this way.  (The
+             ;; negative constraint is hard to express in normal
+             ;; CLOS method terms).
+             (not (typep slotd 'structure-slot-definition)))
+    (error 'slotd-initialization-error :initarg :name :kind :constant :value name))
+  (when (and initformp (not initfunp))
+    (error 'slotd-initialization-error :initarg :initfunction :kind :missing))
+  (when (and initfunp (not initformp))
+    (error 'slotd-initialization-error :initarg :initform :kind :missing))
+  (when (and typep (not t))
+    ;; FIXME: do something.  Need SYNTACTICALLY-VALID-TYPE-SPECIFIER-P
+    )
+  (when (and allocationp (not (symbolp allocation)))
+    (error 'slotd-initialization-type-error :initarg :allocation :datum allocation :expected-type 'symbol))
+  (when initargsp
+    (unless (typep initargs 'list)
+      (error 'slotd-initialization-type-error :initarg :initarg :datum initargs :expected-type 'list))
+    (do ((is initargs (cdr is)))
+        ((atom is)
+         (unless (null is)
+           (error 'slotd-initialization-type-error :initarg :initarg :datum initargs :expected-type '(satisfies proper-list-p))))
+      (unless (symbolp (car is))
+        (error 'slotd-initialization-type-error :initarg :initarg :datum is :expected-type '(or null (cons symbol))))))
+  (when docp
+    (unless (typep documentation '(or null string))
+      (error 'slotd-initialization-type-error :initarg :documentation :datum documentation :expected-type '(or null string)))))
+
+(defmethod initialize-instance :before ((dslotd direct-slot-definition)
+                                        &key
+                                          (readers nil readersp)
+                                          (writers nil writersp))
+  (macrolet ((check (arg argp)
+               `(when ,argp
+                  (unless (typep ,arg 'list)
+                    (error 'slotd-initialization-type-error
+                           :initarg ,(keywordicate arg)
+                           :datum ,arg :expected-type 'list))
+                  (do ((as ,arg (cdr as)))
+                      ((atom as)
+                       (unless (null as)
+                         (error 'slotd-initialization-type-error
+                                :initarg ,(keywordicate arg)
+                                :datum ,arg :expected-type '(satisfies proper-list-p))))
+                    (unless (valid-function-name-p (car as))
+                      (error 'slotd-initialization-type-error
+                             :initarg ,(keywordicate arg)
+                             :datum ,arg :expected-type '(or null (cons (satisfies valid-function-name-p)))))))))
+    (check readers readersp)
+    (check writers writersp)))
+
+(defmethod initialize-instance :after ((slotd effective-slot-definition) &key)
+  (let ((info (make-slot-info :slotd slotd)))
+    (generate-slotd-typecheck slotd info)
+    (setf (slot-definition-info slotd) info)))
+
+;;; FIXME: Do we need (SETF SLOT-DEFINITION-TYPE) at all?
+(defmethod (setf slot-definition-type) :after (new-type (slotd effective-slot-definition))
+  (generate-slotd-typecheck slotd (slot-definition-info slotd)))
+
+(defmethod update-instance-for-different-class
+    ((previous standard-object) (current standard-object) &rest initargs)
   ;; First we must compute the newly added slots. The spec defines
   ;; newly added slots as "those local slots for which no slot of
   ;; the same name exists in the previous class."
   (let ((added-slots '())
-	(current-slotds (class-slots (class-of current)))
-	(previous-slot-names (mapcar #'slot-definition-name
-				     (class-slots (class-of previous)))))
+        (current-slotds (class-slots (class-of current)))
+        (previous-slot-names (mapcar #'slot-definition-name
+                                     (class-slots (class-of previous)))))
     (dolist (slotd current-slotds)
       (if (and (not (memq (slot-definition-name slotd) previous-slot-names))
-	       (eq (slot-definition-allocation slotd) :instance))
-	  (push (slot-definition-name slotd) added-slots)))
+               (eq (slot-definition-allocation slotd) :instance))
+          (push (slot-definition-name slotd) added-slots)))
     (check-initargs-1
      (class-of current) initargs
      (list (list* 'update-instance-for-different-class previous current initargs)
-	   (list* 'shared-initialize current added-slots initargs)))
+           (list* 'shared-initialize current added-slots initargs)))
     (apply #'shared-initialize current added-slots initargs)))
 
-(defmethod update-instance-for-redefined-class ((instance std-object)
-						added-slots
-						discarded-slots
-						property-list
-						&rest initargs)
+(defmethod update-instance-for-redefined-class
+    ((instance standard-object) added-slots discarded-slots property-list
+     &rest initargs)
   (check-initargs-1
    (class-of instance) initargs
    (list (list* 'update-instance-for-redefined-class
-		instance added-slots discarded-slots property-list initargs)
-	 (list* 'shared-initialize instance added-slots initargs)))
+                instance added-slots discarded-slots property-list initargs)
+         (list* 'shared-initialize instance added-slots initargs)))
   (apply #'shared-initialize instance added-slots initargs))
 
-(defmethod shared-initialize
-    ((instance slot-object) slot-names &rest initargs)
-  (cond
-    ((eq slot-names t)
-     (call-initialize-function
-      (initialize-info-shared-initialize-t-fun
-       (initialize-info (class-of instance) initargs))
-      instance initargs))
-    ((eq slot-names nil)
-     (call-initialize-function
-      (initialize-info-shared-initialize-nil-fun
-       (initialize-info (class-of instance) initargs))
-      instance initargs))
-    (t
-     ;; Initialize the instance's slots in a two step process:
-     ;;   (1) A slot for which one of the initargs in initargs can set
-     ;;       the slot, should be set by that initarg. If more than
-     ;;       one initarg in initargs can set the slot, the leftmost
-     ;;       one should set it.
-     ;;   (2) Any slot not set by step 1, may be set from its initform
-     ;;       by step 2. Only those slots specified by the slot-names
-     ;;       argument are set. If slot-names is:
-     ;;       T
-     ;;	      then any slot not set in step 1 is set from its
-     ;;	      initform.
-     ;;       <list of slot names>
-     ;;	      then any slot in the list, and not set in step 1
-     ;;	      is set from its initform.
-     ;;       ()
-     ;;	      then no slots are set from initforms.
-     (flet ((initialize-slot-from-initarg (class instance slotd)
-              (let ((slot-initargs (slot-definition-initargs slotd)))
-                (doplist (initarg value) initargs
-                         (when (memq initarg slot-initargs)
-                           (setf (slot-value-using-class class instance slotd)
-                                 value)
-                           (return t)))))
-            (initialize-slot-from-initfunction (class instance slotd)
-              (unless (or (slot-boundp-using-class class instance slotd)
-                          (null (slot-definition-initfunction slotd)))
-                (setf (slot-value-using-class class instance slotd)
-                      (funcall (slot-definition-initfunction slotd)))))
-            (class-slot-p (slotd)
-              (eq :class (slot-definition-allocation slotd))))
-       (loop with class = (class-of instance)
-             for slotd in (class-slots class)
-             unless (or (class-slot-p slotd)
-                        (initialize-slot-from-initarg class instance slotd))
-             when (memq (slot-definition-name slotd) slot-names) do
-             (initialize-slot-from-initfunction class instance slotd))
-       instance))))
+(defmethod shared-initialize ((instance slot-object) slot-names &rest initargs)
+  (flet ((initialize-slot-from-initarg (class instance slotd)
+           (let ((slot-initargs (slot-definition-initargs slotd)))
+             (doplist (initarg value) initargs
+               (when (memq initarg slot-initargs)
+                 (setf (slot-value-using-class class instance slotd)
+                       value)
+                 (return t)))))
+         (initialize-slot-from-initfunction (class instance slotd)
+           ;; CLHS: If a before method stores something in a slot,
+           ;; that slot won't be initialized from its :INITFORM, if any.
+           (let ((initfun (slot-definition-initfunction slotd)))
+             (if (typep instance 'structure-object)
+                 ;; We don't have a consistent unbound marker for structure
+                 ;; object slots, and structure object redefinition is not
+                 ;; really supported anyways -- so unconditionally
+                 ;; initializing the slot should be fine.
+                 (when initfun
+                   (setf (slot-value-using-class class instance slotd)
+                         (funcall initfun)))
+                 (unless (or (not initfun)
+                             (slot-boundp-using-class class instance slotd))
+                   (setf (slot-value-using-class class instance slotd)
+                         (funcall initfun)))))))
+    (let* ((class (class-of instance))
+           (initfn-slotds
+            (loop for slotd in (class-slots class)
+                  unless (initialize-slot-from-initarg class instance slotd)
+                  collect slotd)))
+      (dolist (slotd initfn-slotds)
+        (when (or (eq t slot-names)
+                  (memq (slot-definition-name slotd) slot-names))
+          (initialize-slot-from-initfunction class instance slotd))))
+    instance))
 
 ;;; If initargs are valid return nil, otherwise signal an error.
 (defun check-initargs-1 (class initargs call-list
-			 &optional (plist-p t) (error-p t))
+                         &optional (plist-p t) (error-p t))
   (multiple-value-bind (legal allow-other-keys)
       (check-initargs-values class call-list)
     (unless allow-other-keys
       (if plist-p
-	  (check-initargs-2-plist initargs class legal error-p)
-	  (check-initargs-2-list initargs class legal error-p)))))
+          (check-initargs-2-plist initargs class legal error-p)
+          (check-initargs-2-list initargs class legal error-p)))))
 
 (defun check-initargs-values (class call-list)
   (let ((methods (mapcan (lambda (call)
-			   (if (consp call)
-			       (copy-list (compute-applicable-methods
-					   (gdefinition (car call))
-					   (cdr call)))
-			       (list call)))
-			 call-list))
-	(legal (apply #'append (mapcar #'slot-definition-initargs
-				       (class-slots class)))))
+                           (if (consp call)
+                               (copy-list (compute-applicable-methods
+                                           (gdefinition (car call))
+                                           (cdr call)))
+                               (list call)))
+                         call-list))
+        (legal (apply #'append (mapcar #'slot-definition-initargs
+                                       (class-slots class)))))
     ;; Add to the set of slot-filling initargs the set of
     ;; initargs that are accepted by the methods. If at
     ;; any point we come across &allow-other-keys, we can
     ;; just quit.
     (dolist (method methods)
       (multiple-value-bind (nreq nopt keysp restp allow-other-keys keys)
-	  (analyze-lambda-list (if (consp method)
-				   (early-method-lambda-list method)
-				   (method-lambda-list method)))
-	(declare (ignore nreq nopt keysp restp))
-	(when allow-other-keys
-	  (return-from check-initargs-values (values nil t)))
-	(setq legal (append keys legal))))
+          (analyze-lambda-list (if (consp method)
+                                   (early-method-lambda-list method)
+                                   (method-lambda-list method)))
+        (declare (ignore nreq nopt keysp restp))
+        (when allow-other-keys
+          (return-from check-initargs-values (values nil t)))
+        (setq legal (append keys legal))))
     (values legal nil)))
 
+(define-condition initarg-error (reference-condition program-error)
+  ((class :reader initarg-error-class :initarg :class)
+   (initargs :reader initarg-error-initargs :initarg :initargs))
+  (:default-initargs :references (list '(:ansi-cl :section (7 1 2))))
+  (:report (lambda (condition stream)
+             (format stream "~@<Invalid initialization argument~P: ~2I~_~
+                             ~<~{~S~^, ~} ~@:>~I~_in call for class ~S.~:>"
+                     (length (initarg-error-initargs condition))
+                     (list (initarg-error-initargs condition))
+                     (initarg-error-class condition)))))
+
 (defun check-initargs-2-plist (initargs class legal &optional (error-p t))
-  (unless (getf initargs :allow-other-keys)
-    ;; Now check the supplied-initarg-names and the default initargs
-    ;; against the total set that we know are legal.
-    (doplist (key val) initargs
-      (unless (memq key legal)
-	(if error-p
-	    (error 'simple-program-error
-		   :format-control "Invalid initialization argument ~S for class ~S"
-		   :format-arguments (list key (class-name class)))
-	    (return-from check-initargs-2-plist nil)))))
-  t)
+  (let ((invalid-keys ()))
+    (unless (getf initargs :allow-other-keys)
+      ;; Now check the supplied-initarg-names and the default initargs
+      ;; against the total set that we know are legal.
+      (doplist (key val) initargs
+        (unless (or (memq key legal)
+                    ;; :ALLOW-OTHER-KEYS NIL gets here
+                    (eq key :allow-other-keys))
+          (push key invalid-keys)))
+      (when (and invalid-keys error-p)
+        (error 'initarg-error :class class :initargs invalid-keys)))
+    invalid-keys))
 
 (defun check-initargs-2-list (initkeys class legal &optional (error-p t))
-  (unless (memq :allow-other-keys initkeys)
-    ;; Now check the supplied-initarg-names and the default initargs
-    ;; against the total set that we know are legal.
-    (dolist (key initkeys)
-      (unless (memq key legal)
-	(if error-p
-	    (error 'simple-program-error
-		   :format-control "Invalid initialization argument ~S for class ~S"
-		   :format-arguments (list key (class-name class)))
-	    (return-from check-initargs-2-list nil)))))
-  t)
+  (let ((invalid-keys ()))
+    (unless (memq :allow-other-keys initkeys)
+      ;; Now check the supplied-initarg-names and the default initargs
+      ;; against the total set that we know are legal.
+      (dolist (key initkeys)
+        (unless (memq key legal)
+          (push key invalid-keys)))
+      (when (and invalid-keys error-p)
+        (error 'initarg-error :class class :initargs invalid-keys)))
+    invalid-keys))