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