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