;;;-*-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)

