Forked from
cmucl / cmucl
5464 commits behind the upstream repository.
-
gerd authored
SHARED-INITIALIZE being specified to initialize slots that are unbound, including class slots. * src/pcl/init.lisp (shared-initialize): Initialize class slots that are unbound.
gerd authoredSHARED-INITIALIZE being specified to initialize slots that are unbound, including class slots. * src/pcl/init.lisp (shared-initialize): Initialize class slots that are unbound.
init.lisp 8.91 KiB
;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
;;; All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted. Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;; CommonLoops Coordinator
;;; Xerox PARC
;;; 3333 Coyote Hill Rd.
;;; Palo Alto, CA 94304
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/init.lisp,v 1.20 2003/05/02 12:43:06 gerd Exp $")
;;;
;;; This file defines the initialization and related protocols.
;;;
(in-package :pcl)
(defmethod make-instance ((class symbol) &rest initargs)
(apply #'make-instance (find-class class) initargs))
(defmethod make-instance ((class class) &rest initargs)
;;
;; Try to use an optimized constructor if there is one.
(let ((instance (call-ctor class initargs)))
(when instance
(return-from make-instance instance)))
;;
(unless (class-finalized-p class)
(finalize-inheritance class))
(let ((class-default-initargs (class-default-initargs class)))
(when class-default-initargs
(setf initargs (default-initargs class initargs class-default-initargs)))
(when initargs
(when (and (eq *boot-state* 'complete)
(not (getf initargs :allow-other-keys)))
(let ((class-proto (class-prototype class)))
(check-initargs
class initargs
(append (compute-applicable-methods
#'allocate-instance (list class))
(compute-applicable-methods
#'initialize-instance (list class-proto))
(compute-applicable-methods
#'shared-initialize (list class-proto t)))))))
(let ((instance (apply #'allocate-instance class initargs)))
(apply #'initialize-instance instance initargs)
instance)))
(defmethod default-initargs ((class slot-class) supplied-initargs
class-default-initargs)
(loop for (key fn) in class-default-initargs
when (eq (getf supplied-initargs key '.not-there.) '.not-there.)
append (list key (funcall fn)) 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-ri-initargs instance initargs)
(apply #'shared-initialize instance nil initargs)
instance)
(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)))))
(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)))
(check-initargs
(class-of current) initargs
(list (list* 'update-instance-for-different-class previous current initargs)
(list* 'shared-initialize current added-slots initargs)))
(apply #'shared-initialize current added-slots initargs)))
(defmethod update-instance-for-redefined-class
((instance standard-object)
added-slots
discarded-slots
property-list
&rest initargs)
(check-initargs
(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)))
(apply #'shared-initialize instance added-slots initargs))
;;;
;;; 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
;;; any slot not set in step 1 is set from its
;;; initform
;;; <list of slot names>
;;; any slot in the list, and not set in step 1
;;; is set from its initform
;;;
;;; ()
;;; no slots are set from initforms
;;;
(defmethod shared-initialize ((instance slot-object) slot-names &rest initargs)
(let ((structure-p (structure-class-p (class-of instance))))
(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.
(if structure-p
(when (eq '.unbound.
(slot-value-using-class class instance slotd))
(let ((initfn (slot-definition-initfunction slotd)))
(setf (slot-value-using-class class instance slotd)
(if (null initfn)
nil
(funcall initfn)))))
(unless (slot-boundp-using-class class instance slotd)
(let ((initfn (slot-definition-initfunction slotd)))
(unless (null initfn)
(setf (slot-value-using-class class instance slotd)
(funcall initfn))))))))
(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)
(if (eq (slot-definition-allocation slotd) :class)
(unless (slot-boundp-using-class class instance slotd)
(initialize-slot-from-initfunction class instance slotd))
(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
;;; If ERROR-P is false, return a list of invalid initkeys.
;;;
(defun check-initargs (class initargs call-list
&optional (plist-p t) (error-p t))
(multiple-value-bind (legal allow-other-keys)
(valid-initargs class call-list)
(unless allow-other-keys
(let ((invalid-keys ()))
(if plist-p
(unless (getf initargs :allow-other-keys)
(doplist (key val) initargs
(unless (or (memq key legal)
;; :ALLOW-OTHER-KEYS NIL
(eq key :allow-other-keys))
(push key invalid-keys))))
(unless (memq :allow-other-keys initargs)
(dolist (key initargs)
(unless (memq key legal)
(push key invalid-keys)))))
(when (and invalid-keys error-p)
(invalid-initargs-error class invalid-keys))
invalid-keys))))
(defun valid-initargs (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)))))
;; 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 valid-initargs (values nil t)))
(setq legal (append keys legal))))
(values legal nil)))
(defun invalid-initargs-error (class invalid-keys)
(simple-program-error "~@<Invalid initialization argument~P ~2I~_~
~<~{~S~^, ~}~@:> ~I~_in call for class ~S.~:>"
(length invalid-keys)
(list invalid-keys)
class))