src/pcl/init.lisp

   1 ;;;; This file defines the initialization and related protocols.
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5
   6 ;;;; This software is derived from software originally released by Xerox
   7 ;;;; Corporation. Copyright and release statements follow. Later modifications
   8 ;;;; to the software are in the public domain and are provided with
   9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
  10 ;;;; information.
  11
  12 ;;;; copyright information from original PCL sources:
  13 ;;;;
  14 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  15 ;;;; All rights reserved.
  16 ;;;;
  17 ;;;; Use and copying of this software and preparation of derivative works based
  18 ;;;; upon this software are permitted. Any distribution of this software or
  19 ;;;; derivative works must comply with all applicable United States export
  20 ;;;; control laws.
  21 ;;;;
  22 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  23 ;;;; warranty about the software, its performance or its conformity to any
  24 ;;;; specification.
  25
  26 (in-package "SB-PCL")
  27 \f
  28 (defmethod make-instance ((class symbol) &rest initargs)
  29   (apply #'make-instance (find-class class) initargs))
  30
  31 (defmethod make-instance ((class class) &rest initargs)
  32   (unless (class-finalized-p class) (finalize-inheritance class))
  33   (let ((class-default-initargs (class-default-initargs class)))
  34     (when class-default-initargs
  35       (setf initargs (default-initargs class initargs class-default-initargs)))
  36     (when initargs
  37       (when (and (eq *boot-state* 'complete)
  38                  (not (getf initargs :allow-other-keys)))
  39         (let ((class-proto (class-prototype class)))
  40           (check-initargs-1
  41            class initargs
  42            (append (compute-applicable-methods
  43                     #'allocate-instance (list class))
  44                    (compute-applicable-methods
  45                     #'initialize-instance (list class-proto))
  46                    (compute-applicable-methods
  47                     #'shared-initialize (list class-proto t)))))))
  48     (let ((instance (apply #'allocate-instance class initargs)))
  49       (apply #'initialize-instance instance initargs)
  50       instance)))
  51
  52 (defmethod default-initargs ((class slot-class)
  53                              supplied-initargs
  54                              class-default-initargs)
  55   (loop for (key fn) in class-default-initargs
  56         when (eq (getf supplied-initargs key '.not-there.) '.not-there.)
  57           append (list key (funcall fn)) into default-initargs
  58         finally
  59           (return (append supplied-initargs default-initargs))))
  60
  61 (defmethod initialize-instance ((instance slot-object) &rest initargs)
  62   (apply #'shared-initialize instance t initargs))
  63
  64 (defmethod reinitialize-instance ((instance slot-object) &rest initargs)
  65   (apply #'shared-initialize instance nil initargs)
  66   instance)
  67
  68 (defmethod update-instance-for-different-class ((previous std-object)
  69                                                 (current std-object)
  70                                                 &rest initargs)
  71   ;; First we must compute the newly added slots. The spec defines
  72   ;; newly added slots as "those local slots for which no slot of
  73   ;; the same name exists in the previous class."
  74   (let ((added-slots '())
  75         (current-slotds (class-slots (class-of current)))
  76         (previous-slot-names (mapcar #'slot-definition-name
  77                                      (class-slots (class-of previous)))))
  78     (dolist (slotd current-slotds)
  79       (if (and (not (memq (slot-definition-name slotd) previous-slot-names))
  80                (eq (slot-definition-allocation slotd) :instance))
  81           (push (slot-definition-name slotd) added-slots)))
  82     (check-initargs-1
  83      (class-of current) initargs
  84      (list (list* 'update-instance-for-different-class previous current initargs)
  85            (list* 'shared-initialize current added-slots initargs)))
  86     (apply #'shared-initialize current added-slots initargs)))
  87
  88 (defmethod update-instance-for-redefined-class ((instance std-object)
  89                                                 added-slots
  90                                                 discarded-slots
  91                                                 property-list
  92                                                 &rest initargs)
  93   (check-initargs-1
  94    (class-of instance) initargs
  95    (list (list* 'update-instance-for-redefined-class
  96                 instance added-slots discarded-slots property-list initargs)
  97          (list* 'shared-initialize instance added-slots initargs)))
  98   (apply #'shared-initialize instance added-slots initargs))
  99
 100 (defmethod shared-initialize ((instance slot-object) slot-names &rest initargs)
 101   (flet ((initialize-slot-from-initarg (class instance slotd)
 102            (let ((slot-initargs (slot-definition-initargs slotd)))
 103              (doplist (initarg value) initargs
 104                       (when (memq initarg slot-initargs)
 105                         (setf (slot-value-using-class class instance slotd)
 106                               value)
 107                         (return t)))))
 108          (initialize-slot-from-initfunction (class instance slotd)
 109            ;; CLHS: If a before method stores something in a slot,
 110            ;; that slot won't be initialized from its :INITFORM, if any.
 111            (if (typep instance 'structure-object)
 112                (when (eq (funcall
 113                           ;; not SLOT-VALUE-USING-CLASS, as that
 114                           ;; throws an error if the value is the
 115                           ;; unbound marker.
 116                           (slot-definition-internal-reader-function slotd)
 117                           instance)
 118                          +slot-unbound+)
 119                  (setf (slot-value-using-class class instance slotd)
 120                        (let ((initfn (slot-definition-initfunction slotd)))
 121                          (when initfn
 122                            (funcall initfn)))))
 123                (unless (or (slot-boundp-using-class class instance slotd)
 124                            (null (slot-definition-initfunction slotd)))
 125                  (setf (slot-value-using-class class instance slotd)
 126                        (funcall (slot-definition-initfunction slotd)))))))
 127     (let* ((class (class-of instance))
 128            (initfn-slotds
 129             (loop for slotd in (class-slots class)
 130                   unless (initialize-slot-from-initarg class instance slotd)
 131                     collect slotd)))
 132       (loop for slotd in initfn-slotds
 133             when (and (not (eq :class (slot-definition-allocation slotd)))
 134                       (or (eq t slot-names)
 135                           (memq (slot-definition-name slotd) slot-names))) do
 136               (initialize-slot-from-initfunction class instance slotd)))
 137     instance))
 138 \f
 139 ;;; If initargs are valid return nil, otherwise signal an error.
 140 (defun check-initargs-1 (class initargs call-list
 141                          &optional (plist-p t) (error-p t))
 142   (multiple-value-bind (legal allow-other-keys)
 143       (check-initargs-values class call-list)
 144     (unless allow-other-keys
 145       (if plist-p
 146           (check-initargs-2-plist initargs class legal error-p)
 147           (check-initargs-2-list initargs class legal error-p)))))
 148
 149 (defun check-initargs-values (class call-list)
 150   (let ((methods (mapcan (lambda (call)
 151                            (if (consp call)
 152                                (copy-list (compute-applicable-methods
 153                                            (gdefinition (car call))
 154                                            (cdr call)))
 155                                (list call)))
 156                          call-list))
 157         (legal (apply #'append (mapcar #'slot-definition-initargs
 158                                        (class-slots class)))))
 159     ;; Add to the set of slot-filling initargs the set of
 160     ;; initargs that are accepted by the methods. If at
 161     ;; any point we come across &allow-other-keys, we can
 162     ;; just quit.
 163     (dolist (method methods)
 164       (multiple-value-bind (nreq nopt keysp restp allow-other-keys keys)
 165           (analyze-lambda-list (if (consp method)
 166                                    (early-method-lambda-list method)
 167                                    (method-lambda-list method)))
 168         (declare (ignore nreq nopt keysp restp))
 169         (when allow-other-keys
 170           (return-from check-initargs-values (values nil t)))
 171         (setq legal (append keys legal))))
 172     (values legal nil)))
 173
 174 (defun check-initargs-2-plist (initargs class legal &optional (error-p t))
 175   (unless (getf initargs :allow-other-keys)
 176     ;; Now check the supplied-initarg-names and the default initargs
 177     ;; against the total set that we know are legal.
 178     (doplist (key val) initargs
 179       (unless (memq key legal)
 180         (if error-p
 181             (error 'simple-program-error
 182                    :format-control "Invalid initialization argument ~S for class ~S"
 183                    :format-arguments (list key (class-name class)))
 184             (return-from check-initargs-2-plist nil)))))
 185   t)
 186
 187 (defun check-initargs-2-list (initkeys class legal &optional (error-p t))
 188   (unless (memq :allow-other-keys initkeys)
 189     ;; Now check the supplied-initarg-names and the default initargs
 190     ;; against the total set that we know are legal.
 191     (dolist (key initkeys)
 192       (unless (memq key legal)
 193         (if error-p
 194             (error 'simple-program-error
 195                    :format-control "Invalid initialization argument ~S for class ~S"
 196                    :format-arguments (list key (class-name class)))
 197             (return-from check-initargs-2-list nil)))))
 198   t)
 199