;;;-*-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. ;;; ************************************************************************* ;;; ;;; ;;; 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) (unless (class-finalized-p class) (finalize-inheritance class)) (setq initargs (default-initargs class initargs)) #|| (check-initargs-1 class initargs (list (list* 'allocate-instance class initargs) (list* 'initialize-instance (class-prototype class) initargs) (list* 'shared-initialize (class-prototype class) t initargs))) ||# (let* ((info (initialize-info class initargs)) (valid-p (initialize-info-valid-p info))) (when (and (consp valid-p) (eq (car valid-p) :invalid)) (error "Invalid initialization argument ~S for class ~S" (cdr valid-p) (class-name class)))) (let ((instance (apply #'allocate-instance class initargs))) (apply #'initialize-instance instance initargs) instance)) (defvar *default-initargs-flag* (list nil)) (defmethod default-initargs ((class slot-class) supplied-initargs) (call-initialize-function (initialize-info-default-initargs-function (initialize-info class supplied-initargs)) nil supplied-initargs) #|| ;; This implementation of default initargs is critically dependent ;; on all-default-initargs not having any duplicate initargs in it. (let ((all-default (class-default-initargs class)) (miss *default-initargs-flag*)) (flet ((getf* (plist key) (do () ((null plist) miss) (if (eq (car plist) key) (return (cadr plist)) (setq plist (cddr plist)))))) (labels ((default-1 (tail) (if (null tail) nil (if (eq (getf* supplied-initargs (caar tail)) miss) (list* (caar tail) (funcall (cadar tail)) (default-1 (cdr tail))) (default-1 (cdr tail)))))) (append supplied-initargs (default-1 all-default))))) ||#) (defmethod initialize-instance ((instance slot-object) &rest initargs) (apply #'shared-initialize instance t initargs)) (defmethod reinitialize-instance ((instance slot-object) &rest initargs) #|| (check-initargs-1 (class-of instance) initargs (list (list* 'reinitialize-instance instance initargs) (list* 'shared-initialize instance nil initargs))) ||# (let* ((class (class-of instance)) (info (initialize-info class initargs)) (valid-p (initialize-info-ri-valid-p info))) (when (and (consp valid-p) (eq (car valid-p) :invalid)) (error "Invalid initialization argument ~S for class ~S" (cdr valid-p) (class-name class)))) (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-1 (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-1 (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)) (defmethod shared-initialize ((instance slot-object) slot-names &rest initargs) (when (eq slot-names 't) (return-from shared-initialize (call-initialize-function (initialize-info-shared-initialize-t-function (initialize-info (class-of instance) initargs)) instance initargs))) (when (eq slot-names 'nil) (return-from shared-initialize (call-initialize-function (initialize-info-shared-initialize-nil-function (initialize-info (class-of instance) initargs)) instance 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 ;; ;; any slot in the list, and not set in step 1 ;; is set from its initform ;; ;; () ;; no slots are set from initforms ;; (let* ((class (class-of instance)) (slotds (class-slots class)) #-new-kcl-wrapper (std-p #+cmu17 (pcl-instance-p instance) #-cmu17 (or (std-instance-p instance) (fsc-instance-p instance)))) (dolist (slotd slotds) (let ((slot-name (slot-definition-name slotd)) (slot-initargs (slot-definition-initargs slotd))) (unless (progn ;; Try to initialize the slot from one of the initargs. ;; If we succeed return T, otherwise return nil. (doplist (initarg val) initargs (when (memq initarg slot-initargs) (setf (slot-value-using-class class instance slotd) val) (return 't)))) ;; Try to initialize the slot from its initform. (if (and slot-names (or (eq slot-names 't) (memq slot-name slot-names)) (or #-new-kcl-wrapper (and (not std-p) (eq slot-names 't)) (not (slot-boundp-using-class class instance slotd)))) (let ((initfunction (slot-definition-initfunction slotd))) (when initfunction (setf (slot-value-using-class class instance slotd) (funcall (the function initfunction))))))))) instance)) ;;; ;;; if initargs are valid return nil, otherwise signal an error ;;; (defun check-initargs-1 (class initargs call-list &optional (plist-p t) (error-p t)) (multiple-value-bind (legal allow-other-keys) (check-initargs-values class call-list) (unless allow-other-keys (if plist-p (check-initargs-2-plist initargs class legal error-p) (check-initargs-2-list initargs class legal error-p))))) (defun check-initargs-values (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 check-initargs-values (values nil t))) (setq legal (append keys legal)))) (values legal nil))) (defun check-initargs-2-plist (initargs class legal &optional (error-p t)) (unless (getf initargs :allow-other-keys) ;; Now check the supplied-initarg-names and the default initargs ;; against the total set that we know are legal. (doplist (key val) initargs (unless (memq key legal) (if error-p (error "Invalid initialization argument ~S for class ~S" key (class-name class)) (return-from check-initargs-2-plist nil))))) t) (defun check-initargs-2-list (initkeys class legal &optional (error-p t)) (unless (memq :allow-other-keys initkeys) ;; Now check the supplied-initarg-names and the default initargs ;; against the total set that we know are legal. (dolist (key initkeys) (unless (memq key legal) (if error-p (error "Invalid initialization argument ~S for class ~S" key (class-name class)) (return-from check-initargs-2-list nil))))) t)