| -rw-r--r-- | gcl/pcl/init.lisp | 261 |
diff --git a/gcl/pcl/init.lisp b/gcl/pcl/init.lisp new file mode 100644 index 000000000..217cca7da --- /dev/null +++ b/gcl/pcl/init.lisp @@ -0,0 +1,261 @@ +;;;-*-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 + ;; <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 + ;; + (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) + |