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   (setq initargs (default-initargs class initargs))
  34   #||
  35   (check-initargs-1
  36    class initargs
  37    (list (list* 'allocate-instance class initargs)
  38          (list* 'initialize-instance (class-prototype class) initargs)
  39          (list* 'shared-initialize (class-prototype class) t initargs)))
  40   ||#
  41   (let* ((info (initialize-info class initargs))
  42          (valid-p (initialize-info-valid-p info)))
  43     (when (and (consp valid-p) (eq (car valid-p) :invalid))
  44       (error 'simple-program-error
  45              :format-control "Invalid initialization argument ~S for class ~S"
  46              :format-arguments (list (cdr valid-p) (class-name class)))))
  47   (let ((instance (apply #'allocate-instance class initargs)))
  48     (apply #'initialize-instance instance initargs)
  49     instance))
  50
  51 (defmethod default-initargs ((class slot-class) supplied-initargs)
  52   (call-initialize-function
  53    (initialize-info-default-initargs-function
  54     (initialize-info class supplied-initargs))
  55    nil supplied-initargs))
  56
  57 (defmethod initialize-instance ((instance slot-object) &rest initargs)
  58   (apply #'shared-initialize instance t initargs))
  59
  60 (defmethod reinitialize-instance ((instance slot-object) &rest initargs)
  61   #||
  62   (check-initargs-1
  63    (class-of instance) initargs
  64    (list (list* 'reinitialize-instance instance initargs)
  65          (list* 'shared-initialize instance nil initargs)))
  66   ||#
  67   (let* ((class (class-of instance))
  68          (info (initialize-info class initargs))
  69          (valid-p (initialize-info-ri-valid-p info)))
  70     (when (and (consp valid-p) (eq (car valid-p) :invalid))
  71       (error 'simple-program-error
  72              :format-control "Invalid initialization argument ~S for class ~S"
  73              :format-arguments (list (cdr valid-p) (class-name class)))))
  74   (apply #'shared-initialize instance nil initargs)
  75   instance)
  76
  77 (defmethod update-instance-for-different-class ((previous std-object)
  78                                                 (current std-object)
  79                                                 &rest initargs)
  80   ;; First we must compute the newly added slots. The spec defines
  81   ;; newly added slots as "those local slots for which no slot of
  82   ;; the same name exists in the previous class."
  83   (let ((added-slots '())
  84         (current-slotds (class-slots (class-of current)))
  85         (previous-slot-names (mapcar #'slot-definition-name
  86                                      (class-slots (class-of previous)))))
  87     (dolist (slotd current-slotds)
  88       (if (and (not (memq (slot-definition-name slotd) previous-slot-names))
  89                (eq (slot-definition-allocation slotd) :instance))
  90           (push (slot-definition-name slotd) added-slots)))
  91     (check-initargs-1
  92      (class-of current) initargs
  93      (list (list* 'update-instance-for-different-class previous current initargs)
  94            (list* 'shared-initialize current added-slots initargs)))
  95     (apply #'shared-initialize current added-slots initargs)))
  96
  97 (defmethod update-instance-for-redefined-class ((instance std-object)
  98                                                 added-slots
  99                                                 discarded-slots
 100                                                 property-list
 101                                                 &rest initargs)
 102   (check-initargs-1
 103    (class-of instance) initargs
 104    (list (list* 'update-instance-for-redefined-class
 105                 instance added-slots discarded-slots property-list initargs)
 106          (list* 'shared-initialize instance added-slots initargs)))
 107   (apply #'shared-initialize instance added-slots initargs))
 108
 109 (defmethod shared-initialize
 110     ((instance slot-object) slot-names &rest initargs)
 111   (cond
 112     ((eq slot-names t)
 113      (call-initialize-function
 114       (initialize-info-shared-initialize-t-fun
 115        (initialize-info (class-of instance) initargs))
 116       instance initargs))
 117     ((eq slot-names nil)
 118      (call-initialize-function
 119       (initialize-info-shared-initialize-nil-fun
 120        (initialize-info (class-of instance) initargs))
 121       instance initargs))
 122     (t
 123      ;; Initialize the instance's slots in a two step process:
 124      ;;   (1) A slot for which one of the initargs in initargs can set
 125      ;;       the slot, should be set by that initarg. If more than
 126      ;;       one initarg in initargs can set the slot, the leftmost
 127      ;;       one should set it.
 128      ;;   (2) Any slot not set by step 1, may be set from its initform
 129      ;;       by step 2. Only those slots specified by the slot-names
 130      ;;       argument are set. If slot-names is:
 131      ;;       T
 132      ;;       then any slot not set in step 1 is set from its
 133      ;;       initform.
 134      ;;       <list of slot names>
 135      ;;       then any slot in the list, and not set in step 1
 136      ;;       is set from its initform.
 137      ;;       ()
 138      ;;       then no slots are set from initforms.
 139      (flet ((initialize-slot-from-initarg (class instance slotd)
 140               (let ((slot-initargs (slot-definition-initargs slotd)))
 141                 (doplist (initarg value) initargs
 142                          (when (memq initarg slot-initargs)
 143                            (setf (slot-value-using-class class instance slotd)
 144                                  value)
 145                            (return t)))))
 146             (initialize-slot-from-initfunction (class instance slotd)
 147               (unless (or (slot-boundp-using-class class instance slotd)
 148                           (null (slot-definition-initfunction slotd)))
 149                 (setf (slot-value-using-class class instance slotd)
 150                       (funcall (slot-definition-initfunction slotd)))))
 151             (class-slot-p (slotd)
 152               (eq :class (slot-definition-allocation slotd))))
 153        (loop with class = (class-of instance)
 154              for slotd in (class-slots class)
 155              unless (or (class-slot-p slotd)
 156                         (initialize-slot-from-initarg class instance slotd))
 157              when (memq (slot-definition-name slotd) slot-names) do
 158              (initialize-slot-from-initfunction class instance slotd))
 159        instance))))
 160 \f
 161 ;;; If initargs are valid return nil, otherwise signal an error.
 162 (defun check-initargs-1 (class initargs call-list
 163                          &optional (plist-p t) (error-p t))
 164   (multiple-value-bind (legal allow-other-keys)
 165       (check-initargs-values class call-list)
 166     (unless allow-other-keys
 167       (if plist-p
 168           (check-initargs-2-plist initargs class legal error-p)
 169           (check-initargs-2-list initargs class legal error-p)))))
 170
 171 (defun check-initargs-values (class call-list)
 172   (let ((methods (mapcan (lambda (call)
 173                            (if (consp call)
 174                                (copy-list (compute-applicable-methods
 175                                            (gdefinition (car call))
 176                                            (cdr call)))
 177                                (list call)))
 178                          call-list))
 179         (legal (apply #'append (mapcar #'slot-definition-initargs
 180                                        (class-slots class)))))
 181     ;; Add to the set of slot-filling initargs the set of
 182     ;; initargs that are accepted by the methods. If at
 183     ;; any point we come across &allow-other-keys, we can
 184     ;; just quit.
 185     (dolist (method methods)
 186       (multiple-value-bind (nreq nopt keysp restp allow-other-keys keys)
 187           (analyze-lambda-list (if (consp method)
 188                                    (early-method-lambda-list method)
 189                                    (method-lambda-list method)))
 190         (declare (ignore nreq nopt keysp restp))
 191         (when allow-other-keys
 192           (return-from check-initargs-values (values nil t)))
 193         (setq legal (append keys legal))))
 194     (values legal nil)))
 195
 196 (defun check-initargs-2-plist (initargs class legal &optional (error-p t))
 197   (unless (getf initargs :allow-other-keys)
 198     ;; Now check the supplied-initarg-names and the default initargs
 199     ;; against the total set that we know are legal.
 200     (doplist (key val) initargs
 201       (unless (memq key legal)
 202         (if error-p
 203             (error 'simple-program-error
 204                    :format-control "Invalid initialization argument ~S for class ~S"
 205                    :format-arguments (list key (class-name class)))
 206             (return-from check-initargs-2-plist nil)))))
 207   t)
 208
 209 (defun check-initargs-2-list (initkeys class legal &optional (error-p t))
 210   (unless (memq :allow-other-keys initkeys)
 211     ;; Now check the supplied-initarg-names and the default initargs
 212     ;; against the total set that we know are legal.
 213     (dolist (key initkeys)
 214       (unless (memq key legal)
 215         (if error-p
 216             (error 'simple-program-error
 217                    :format-control "Invalid initialization argument ~S for class ~S"
 218                    :format-arguments (list key (class-name class)))
 219             (return-from check-initargs-2-list nil)))))
 220   t)
 221