;;;-*-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 optimized make-instance functions.
;;; 

(in-package :pcl)

(defvar *compile-make-instance-functions-p* nil)

(defun update-make-instance-function-table (&optional (class *the-class-t*))
  (when (symbolp class) (setq class (find-class class)))
    (when (eq class *the-class-t*) (setq class *the-class-slot-object*))
    (when (memq *the-class-slot-object* (class-precedence-list class))
      (map-all-classes #'reset-class-initialize-info class)))

(defun constant-symbol-p (form)
  (and (constantp form) 
       (let ((object (eval form)))
	 (and (symbolp object)
	      (symbol-package object)))))

(defvar *make-instance-function-keys* nil)

(defun expand-make-instance-form (form)
  (let ((class (cadr form)) (initargs (cddr form))
	(keys nil)(allow-other-keys-p nil) key value)
    (when (and (constant-symbol-p class)
	       (let ((initargs-tail initargs))
		 (loop (when (null initargs-tail) (return t))
		       (unless (constant-symbol-p (car initargs-tail))
			 (return nil))		       
		       (setq key (eval (pop initargs-tail)))
		       (setq value (pop initargs-tail))
		       (when (eq ':allow-other-keys key)
			 (setq allow-other-keys-p value))
		       (push key keys))))
      (let* ((class (eval class))
	     (keys (nreverse keys))
	     (key (list class keys allow-other-keys-p))
	     (sym (make-instance-function-symbol key)))
	(push key *make-instance-function-keys*)
	(when sym
	  `(,sym ',class ,@initargs))))))

(defmacro expanding-make-instance-top-level (&rest forms &environment env)
  (let* ((*make-instance-function-keys* nil)
	 (form (macroexpand `(expanding-make-instance ,@forms) env)))
    `(progn
       ,@(when *make-instance-function-keys*
	   `((get-make-instance-functions ',*make-instance-function-keys*)))
       ,form)))
	  
(defmacro expanding-make-instance (&rest forms &environment env)
  `(progn
     ,@(mapcar #'(lambda (form)
		   (walk-form form env 
			      #'(lambda (subform context env)
				  (declare (ignore env))
				  (or (and (eq context ':eval)
					   (consp subform)
					   (eq (car subform) 'make-instance)
					   (expand-make-instance-form subform))
				      subform))))
	       forms)))

(defmacro defconstructor
	  (name class lambda-list &rest initialization-arguments)
  `(expanding-make-instance-top-level
    (defun ,name ,lambda-list
      (make-instance ',class ,@initialization-arguments))))

(defun get-make-instance-functions (key-list)
  (dolist (key key-list)
    (let* ((cell (find-class-cell (car key)))
	   (make-instance-function-keys 
	    (find-class-cell-make-instance-function-keys cell))
	   (mif-key (cons (cadr key) (caddr key))))
      (unless (find mif-key make-instance-function-keys 
		    :test #'equal)
	(push mif-key (find-class-cell-make-instance-function-keys cell))
	(let ((class (find-class-cell-class cell)))
	  (when (and class (not (forward-referenced-class-p class)))
	    (update-initialize-info-internal
	     (initialize-info class (car mif-key) nil (cdr mif-key))
	     'make-instance-function)))))))

(defun make-instance-function-symbol (key)
  (let* ((class (car key))
	 (symbolp (symbolp class)))
    (when (or symbolp (classp class))
      (let* ((class-name (if (symbolp class) class (class-name class)))
	     (keys (cadr key))
	     (allow-other-keys-p (caddr key)))
	(when (and (or symbolp 
		       (and (symbolp class-name)
			    (eq class (find-class class-name nil))))
		   (symbol-package class-name))
	  (let ((*package* *the-pcl-package*)
		(*print-length* nil) (*print-level* nil)
		(*print-circle* nil) (*print-case* :upcase)
		(*print-pretty* nil))
	    (intern (format nil "MAKE-INSTANCE ~S ~S ~S"
			    class-name keys allow-other-keys-p))))))))

(defun make-instance-1 (class &rest initargs)
  (apply #'make-instance class initargs))

(defmacro define-cached-reader (type name trap)
  (let ((reader-name (intern (format nil "~A-~A" type name)))
	(cached-name (intern (format nil "~A-CACHED-~A" type name))))
    `(defmacro ,reader-name (info)
       `(let ((value (,',cached-name ,info)))
	  (if (eq value ':unknown)
	      (progn
		(,',trap ,info ',',name)
		(,',cached-name ,info))
	      value)))))

(eval-when (compile load eval)
(defparameter initialize-info-cached-slots
  '(valid-p				; t or (:invalid key)
    ri-valid-p
    initargs-form-list
    combined-initargs-form-list
    new-keys
    default-initargs-function
    shared-initialize-t-function
    shared-initialize-nil-function
    constants
    combined-initialize-function ; allocate-instance + shared-initialize
    make-instance-function ; nil means use gf
    make-instance-function-symbol)))

(defmacro define-initialize-info ()
  (let ((cached-slot-names 
	 (mapcar #'(lambda (name)
		     (intern (format nil "CACHED-~A" name)))
		 initialize-info-cached-slots))
	(cached-names
	 (mapcar #'(lambda (name)
		     (intern (format nil "~A-CACHED-~A" 
				     'initialize-info name)))
		 initialize-info-cached-slots)))
    `(progn
       (defstruct initialize-info 
	 key wrapper 
	 ,@(mapcar #'(lambda (name)
		       `(,name :unknown))
		   cached-slot-names))
       (defmacro reset-initialize-info-internal (info)
	 `(progn 
	    ,@(mapcar #'(lambda (cname)
			  `(setf (,cname ,info) ':unknown))
		      ',cached-names)))
       (defun initialize-info-bound-slots (info)
	 (let ((slots nil))
	   ,@(mapcar #'(lambda (name cached-name)
			 `(unless (eq ':unknown (,cached-name info))
			    (push ',name slots)))
		     initialize-info-cached-slots cached-names)
	   slots))
      ,@(mapcar #'(lambda (name)
		    `(define-cached-reader initialize-info ,name 
		      update-initialize-info-internal))
	        initialize-info-cached-slots))))

(define-initialize-info)

(defvar *initialize-info-cache-class* nil)
(defvar *initialize-info-cache-initargs* nil)
(defvar *initialize-info-cache-info* nil)

(defvar *revert-initialize-info-p* nil)

(defun reset-initialize-info (info)
  (setf (initialize-info-wrapper info)
	(class-wrapper (car (initialize-info-key info))))
  (let ((slots-to-revert (if *revert-initialize-info-p*
			     (initialize-info-bound-slots info)
			     '(make-instance-function))))
    (reset-initialize-info-internal info)
    (dolist (slot slots-to-revert)
      (update-initialize-info-internal info slot))
    info))

(defun reset-class-initialize-info (class)
  (reset-class-initialize-info-1 (class-initialize-info class)))

(defun reset-class-initialize-info-1 (cell)
  (when (consp cell)
    (when (car cell)
      (reset-initialize-info (car cell)))
    (let ((alist (cdr cell)))
      (dolist (a alist)
	(reset-class-initialize-info-1 (cdr a))))))

(defun initialize-info (class initargs &optional (plist-p t) allow-other-keys-arg)
  (let ((info nil))
    (if (and (eq *initialize-info-cache-class* class)
	     (eq *initialize-info-cache-initargs* initargs))
	(setq info *initialize-info-cache-info*)
	(let ((initargs-tail initargs)
	      (cell (or (class-initialize-info class)
			(setf (class-initialize-info class) (cons nil nil)))))
	  (loop (when (null initargs-tail) (return nil))
		(let ((keyword (pop initargs-tail))
		      (alist-cell cell))
		  (when plist-p
		    (if (eq keyword :allow-other-keys)
			(setq allow-other-keys-arg (pop initargs-tail))
			(pop initargs-tail)))
		  (loop (let ((alist (cdr alist-cell)))
			  (when (null alist)
			    (setq cell (cons nil nil))
			    (setf (cdr alist-cell) (list (cons keyword cell)))
			    (return nil))
			  (when (eql keyword (caar alist))
			    (setq cell (cdar alist))
			    (return nil))
			  (setq alist-cell alist)))))
	  (setq info (or (car cell)
			 (setf (car cell) (make-initialize-info))))))
    (let ((wrapper (initialize-info-wrapper info)))
      (unless (eq wrapper (class-wrapper class))
	(unless wrapper
	  (let* ((initargs-tail initargs)
		 (klist-cell (list nil))
		 (klist-tail klist-cell))
	    (loop (when (null initargs-tail) (return nil))
		  (let ((key (pop initargs-tail)))
		    (setf (cdr klist-tail) (list key)))
		  (setf klist-tail (cdr klist-tail))
		  (when plist-p (pop initargs-tail)))
	    (setf (initialize-info-key info)
		  (list class (cdr klist-cell) allow-other-keys-arg))))
	(reset-initialize-info info)))
    (setq *initialize-info-cache-class* class)
    (setq *initialize-info-cache-initargs* initargs)
    (setq *initialize-info-cache-info* info)    
    info))

(defun update-initialize-info-internal (info name)
  (let* ((key (initialize-info-key info))
	 (class (car key))
	 (keys (cadr key))
	 (allow-other-keys-arg (caddr key)))
    (ecase name
      ((initargs-form-list new-keys)
       (multiple-value-bind (initargs-form-list new-keys)
	   (make-default-initargs-form-list class keys)
	 (setf (initialize-info-cached-initargs-form-list info) initargs-form-list)
	 (setf (initialize-info-cached-new-keys info) new-keys)))
      ((combined-initargs-form-list)
       (multiple-value-bind (initargs-form-list new-keys)
	   (make-default-initargs-form-list class keys nil)
	 (setf (initialize-info-cached-combined-initargs-form-list info) 
	       initargs-form-list)
	 (setf (initialize-info-cached-new-keys info) new-keys)))
      ((default-initargs-function)
       (let ((initargs-form-list (initialize-info-initargs-form-list info)))
	 (setf (initialize-info-cached-default-initargs-function info)
	       (initialize-instance-simple-function 
		'default-initargs-function info
		class initargs-form-list))))
      ((valid-p ri-valid-p)
       (flet ((compute-valid-p (methods)
		(or (not (null allow-other-keys-arg))
		    (multiple-value-bind (legal allow-other-keys)
			(check-initargs-values class methods)
		      (or (not (null allow-other-keys))
			  (dolist (key keys t)
			    (unless (member key legal)
			      (return (cons :invalid key)))))))))
	 (let ((proto (class-prototype class)))
	   (setf (initialize-info-cached-valid-p info)
		 (compute-valid-p
		  (list (list* 'allocate-instance class nil)
			(list* 'initialize-instance proto nil)
			(list* 'shared-initialize proto t nil))))
	   (setf (initialize-info-cached-ri-valid-p info)
		 (compute-valid-p 
		  (list (list* 'reinitialize-instance proto nil)
			(list* 'shared-initialize proto nil nil)))))))
      ((shared-initialize-t-function)
       (multiple-value-bind (initialize-form-list ignore)
	   (make-shared-initialize-form-list class keys t nil)
	 (declare (ignore ignore))
	 (setf (initialize-info-cached-shared-initialize-t-function info)
	       (initialize-instance-simple-function 
		'shared-initialize-t-function info
		class initialize-form-list))))
      ((shared-initialize-nil-function)
       (multiple-value-bind (initialize-form-list ignore)
	   (make-shared-initialize-form-list class keys nil nil)
	 (declare (ignore ignore))
	 (setf (initialize-info-cached-shared-initialize-nil-function info)
	       (initialize-instance-simple-function 
		'shared-initialize-nil-function info 
		class initialize-form-list))))
      ((constants combined-initialize-function)
       (let ((initargs-form-list (initialize-info-combined-initargs-form-list info))
	     (new-keys (initialize-info-new-keys info)))
	 (multiple-value-bind (initialize-form-list constants)
	     (make-shared-initialize-form-list class new-keys t t)
	   (setf (initialize-info-cached-constants info) constants)
	   (setf (initialize-info-cached-combined-initialize-function info)
		 (initialize-instance-simple-function 
		  'combined-initialize-function info 
		  class (append initargs-form-list initialize-form-list))))))
      ((make-instance-function-symbol)
       (setf (initialize-info-cached-make-instance-function-symbol info)
	     (make-instance-function-symbol key)))
      ((make-instance-function)
       (let* ((function (get-make-instance-function key))
	      (symbol (initialize-info-make-instance-function-symbol info)))
	 (setf (initialize-info-cached-make-instance-function info) function)
	 (when symbol (setf (gdefinition symbol)
			    (or function #'make-instance-1)))))))
  info)

(defun get-make-instance-function (key)
  (let* ((class (car key))
	 (keys (cadr key)))
    (unless (eq *boot-state* 'complete) 
      (return-from get-make-instance-function nil))
    (when (symbolp class)
      (setq class (find-class class)))
    (when (classp class)
      (unless (class-finalized-p class) (finalize-inheritance class)))
    (let* ((initargs (mapcan #'(lambda (key) (list key nil)) keys))
	   (class-and-initargs (list* class initargs))
	   (make-instance (gdefinition 'make-instance))
	   (make-instance-methods
	    (compute-applicable-methods make-instance class-and-initargs))
	   (std-mi-meth (find-standard-ii-method make-instance-methods 'class))
	   (class+initargs (list class initargs))
	   (default-initargs (gdefinition 'default-initargs))
	   (default-initargs-methods
	       (compute-applicable-methods default-initargs class+initargs))
	   (proto (and (classp class) (class-prototype class)))
	   (initialize-instance-methods
	    (when proto
	      (compute-applicable-methods (gdefinition 'initialize-instance)
					  (list* proto initargs))))
	   (shared-initialize-methods
	    (when proto
	      (compute-applicable-methods (gdefinition 'shared-initialize)
					  (list* proto t initargs)))))
      (when (null make-instance-methods)
	(return-from get-make-instance-function
	  #'(lambda (class &rest initargs)
	      (apply #'no-applicable-method make-instance class initargs))))
      (unless (and (null (cdr make-instance-methods))
		   (eq (car make-instance-methods) std-mi-meth)
		   (null (cdr default-initargs-methods))
		   (eq (car (method-specializers (car default-initargs-methods)))
		       *the-class-slot-class*)
		   (flet ((check-meth (meth)
			    (let ((quals (method-qualifiers meth)))
			      (if (null quals)
				  (eq (car (method-specializers meth))
				      *the-class-slot-object*)
				  (and (null (cdr quals))
				       (or (eq (car quals) ':before)
					   (eq (car quals) ':after)))))))
		     (and (every #'check-meth initialize-instance-methods)
			  (every #'check-meth shared-initialize-methods))))
	(return-from get-make-instance-function nil))
      (get-make-instance-function-internal 
       class key (default-initargs class initargs) 
       initialize-instance-methods shared-initialize-methods))))

(defun get-make-instance-function-internal (class key initargs 
						  initialize-instance-methods
						  shared-initialize-methods)
  (let* (#|(class-key (car key))|#
	 (keys (cadr key))
	 (allow-other-keys-p (caddr key))
	 (allocate-instance-methods
	  (compute-applicable-methods (gdefinition 'allocate-instance)
				      (list* class initargs))))
    (unless allow-other-keys-p
      (unless (check-initargs-1
	       class initargs
	       (append allocate-instance-methods
		       initialize-instance-methods
		       shared-initialize-methods)
	       t nil)
	(return-from get-make-instance-function-internal nil)))
    (cond ((or (cdr allocate-instance-methods)
	       (some #'complicated-instance-creation-method
		     initialize-instance-methods)
	       (some #'complicated-instance-creation-method
		     shared-initialize-methods))
	   (make-instance-function-complex
	    key class keys
	    initialize-instance-methods shared-initialize-methods))
	  (t #|(or (not (standard-class-p class)) (not (symbolp class-key))
	       initialize-instance-methods shared-initialize-methods)|#
	   (make-instance-function-simple
	    key class keys
	    initialize-instance-methods shared-initialize-methods))
	  #|(t
	   (make-instance-function-basic
	    key class keys))|#)))

(defun complicated-instance-creation-method (m)
  (let ((qual (method-qualifiers m)))
    (if qual 
	(not (and (null (cdr qual)) (eq (car qual) ':after)))
	(let ((specl (car (method-specializers m))))
	  (or (not (classp specl))
	      (not (eq 'slot-object (class-name specl))))))))

(defun find-standard-ii-method (methods class-names)
  (dolist (m methods)
    (when (null (method-qualifiers m))
      (let ((specl (car (method-specializers m))))
	(when (and (classp specl)
		   (if (listp class-names)
		       (member (class-name specl) class-names)
		       (eq (class-name specl) class-names)))
	  (return m))))))

(defmacro call-initialize-function (initialize-function instance initargs)
  `(let ((.function. ,initialize-function))
     (if (and (consp .function.)
	      (eq (car .function.) 'call-initialize-instance-simple))
	 (initialize-instance-simple (cadr .function.) (caddr .function.)
				     ,instance ,initargs)
	 (funcall (the function .function.) ,instance ,initargs))))

(defmacro copy-slots (slots-init)
  #-(or lucid cmu17)
  `(copy-seq ,slots-init)
  #+(or lucid cmu17)
  `(let* ((init ,slots-init)
	  (len (length init))
	  (v #+lucid (system:new-simple-vector len)
	     #+cmu17 (lisp::allocate-vector #.vm:simple-vector-type len len)))
     (declare (simple-vector init v)
	      (type #-cmu fixnum #+cmu lisp::index len))
     (dotimes (i len v)
       (declare (type #-cmu fixnum #+cmu lisp::index i))
       (setf (svref v i) (svref init i)))))

(defmacro allocate-standard-instance--macro (wrapper slots-init)
  #-new-kcl-wrapper
  `(let ((instance (%%allocate-instance--class)))
     (setf (std-instance-wrapper instance) ,wrapper)
     (setf (std-instance-slots instance) (copy-slots ,slots-init))
     instance)
  #+new-kcl-wrapper
  `(allocate-standard-instance ,wrapper ,slots-init))

(defmacro with-make-instance-function-valid-p-check (initargs-form &body body)
  `(let ((current-class (if class-cell
			    (find-class-from-cell class-key class-cell)
			    class-symbol)))
     (if (or (not (eq current-class class-symbol))
	     (invalid-wrapper-p wrapper))
	 (make-instance-function-trap current-class ,initargs-form)
	 (progn ,@body))))

(defun make-instance-function-trap (class-symbol initargs)
  (let* ((info (initialize-info class-symbol initargs))
	 (fn (initialize-info-make-instance-function info)))
    (declare (type function fn))
    (funcall fn class-symbol initargs)))

(defun make-instance-function-simple (key class keys
					  initialize-instance-methods 
					  shared-initialize-methods)
  (let* ((class-key (car key))
	 (class-cell (when (symbolp class-key)
		       (find-class-cell class-key nil)))
	 (wrapper (class-wrapper class))
	 (lwrapper (list wrapper))
	 (allocate-function 
	  (cond ((structure-class-p class)
		 #'allocate-structure-instance)
		((standard-class-p class)
		 #'allocate-standard-instance)
		((funcallable-standard-class-p class)
		 #'allocate-funcallable-instance)
		(t 
		 (error "error in make-instance-function-simple"))))
	 (allocate-macro
	  (cond ((standard-class-p class)
		 'allocate-standard-instance--macro)))
	 (std-si-meth (find-standard-ii-method shared-initialize-methods
					       'slot-object))
	 (shared-initfns
	  (nreverse (mapcar #'(lambda (method)
				(make-effective-method-function
				 #'shared-initialize
				 `(call-method ,method nil)
				 nil lwrapper))
			    (remove std-si-meth shared-initialize-methods))))
	 (std-ii-meth (find-standard-ii-method initialize-instance-methods
					       'slot-object))
	 (initialize-initfns 
	  (nreverse (mapcar #'(lambda (method)
				(make-effective-method-function
				 #'initialize-instance
				 `(call-method ,method nil)
				 nil lwrapper))
			    (remove std-ii-meth
				    initialize-instance-methods)))))
    (multiple-value-bind (initialize-function constants)
	(get-simple-initialization-function class keys (caddr key))
      (if (eq allocate-macro 'allocate-standard-instance--macro)
	  #'(lambda (class-symbol &rest initargs) 
	      (with-make-instance-function-valid-p-check initargs
		(let ((instance 
		       (allocate-standard-instance--macro wrapper constants)))
		  (call-initialize-function initialize-function instance initargs)
		  (dolist (fn shared-initfns)
		    (invoke-effective-method-function fn t instance t initargs))
		  (dolist (fn initialize-initfns)
		    (invoke-effective-method-function fn t instance initargs))
		  instance)))
	  #'(lambda (class-symbol &rest initargs)
	      (with-make-instance-function-valid-p-check initargs
		(let* ((instance (funcall allocate-function wrapper constants))
		       (initargs (call-initialize-function initialize-function
							   instance initargs)))
		  (dolist (fn shared-initfns)
		    (invoke-effective-method-function fn t instance t initargs))
		  (dolist (fn initialize-initfns)
		    (invoke-effective-method-function fn t instance initargs))
		  instance)))))))

(defun make-instance-function-complex (key class keys
					   initialize-instance-methods
					   shared-initialize-methods)
  (multiple-value-bind (initargs-function initialize-function)
      (get-complex-initialization-functions class keys (caddr key))
    (let* ((class-key (car key))
	   (class-cell (when (symbolp class-key)
			 (find-class-cell class-key nil)))
	   (wrapper (class-wrapper class))
	   (shared-initialize
	    (get-secondary-dispatch-function
	     #'shared-initialize shared-initialize-methods
	     `((class-eq ,class) t t)
	     `((,(find-standard-ii-method shared-initialize-methods 'slot-object)
		,#'(lambda (instance init-type &rest initargs)
		     (declare (ignore init-type))
		     #+copy-&rest-arg (setq initargs (copy-list initargs))
		     (call-initialize-function initialize-function 
					       instance initargs)
		     instance)))
	     (list wrapper *the-wrapper-of-t* *the-wrapper-of-t*)))
	   (initialize-instance
	    (get-secondary-dispatch-function
	     #'initialize-instance initialize-instance-methods
	     `((class-eq ,class) t)
	     `((,(find-standard-ii-method initialize-instance-methods 'slot-object)
		,#'(lambda (instance &rest initargs)
		     #+copy-&rest-arg (setq initargs (copy-list initargs))
		     (invoke-effective-method-function
		      shared-initialize t instance t initargs))))
	     (list wrapper *the-wrapper-of-t*))))
      #'(lambda (class-symbol &rest initargs)
	  (with-make-instance-function-valid-p-check initargs
	    (let* ((initargs (call-initialize-function initargs-function 
						       nil initargs))
		   (instance (apply #'allocate-instance class initargs)))
	      (invoke-effective-method-function
	       initialize-instance t instance initargs)
	      instance))))))

#|
(defmacro call-initialize-function (initialize-function instance initargs)
  `(let ((.function. ,initialize-function))
     (if (and (consp .function.)
	      (eq (car .function.) 'call-initialize-instance-simple))
	 (initialize-instance-simple (cadr .function.) (caddr .function.)
				     ,instance ,initargs)
	 (funcall (the function .function.) ,instance ,initargs))))

(defun make-instance-function-basic (key class keys)
  (let* ((class-key (car key))
	 (class-cell (find-class-cell class-key nil))
	 (wrapper (class-wrapper class)))
    (multiple-value-bind (initialize-function constants)
	(get-simple-initialization-function class keys (caddr key))
      #'(lambda (class-symbol &rest initargs)
	  (let ((current-class (find-class-from-cell class-key class-cell)))
	    (if (or (not (eq current-class class-symbol))
		    (invalid-wrapper-p wrapper))
		(make-instance-function-trap current-class initargs-form)
		(let ((instance 
		       (allocate-standard-instance--macro wrapper constants)))
		  (call-initialize-function initialize-function instance initargs)
		  instance)))))))
|#

(defun get-simple-initialization-function (class keys &optional allow-other-keys-arg)
  (let ((info (initialize-info class keys nil allow-other-keys-arg)))
    (values (initialize-info-combined-initialize-function info)
	    (initialize-info-constants info))))

(defun get-complex-initialization-functions (class keys &optional allow-other-keys-arg
						   separate-p)
  (let* ((info (initialize-info class keys nil allow-other-keys-arg))
	 (default-initargs-function (initialize-info-default-initargs-function info)))
    (if separate-p
	(values default-initargs-function
		(initialize-info-shared-initialize-t-function info))
	(values default-initargs-function
		(initialize-info-shared-initialize-t-function
		 (initialize-info class (initialize-info-new-keys info)
				  nil allow-other-keys-arg))))))

(defun add-forms (forms forms-list)
  (when forms
    (setq forms (copy-list forms))
    (if (null (car forms-list))
	(setf (car forms-list) forms)
	(setf (cddr forms-list) forms))
    (setf (cdr forms-list) (last forms)))
  (car forms-list))

(defun make-default-initargs-form-list (class keys &optional (separate-p t))
  (let ((initargs-form-list (cons nil nil))
	(default-initargs (class-default-initargs class))
	(nkeys keys)
	(slots-alist
	 (mapcan #'(lambda (slot)
		     (mapcar #'(lambda (arg)
				 (cons arg slot))
			     (slot-definition-initargs slot)))
		 (class-slots class)))
	(nslots nil))
    (dolist (key nkeys)
      (pushnew (cdr (assoc key slots-alist)) nslots))
    (dolist (default default-initargs)
      (let* ((key (car default))
	     (slot (cdr (assoc key slots-alist)))
	     (function (cadr default)))
	(unless (member slot nslots)
	  (add-forms `((funcall ,function) (push-initarg ,key))
		     initargs-form-list)
	  (push key nkeys)
	  (push slot nslots))))
    (when separate-p
      (add-forms `((update-initialize-info-cache
		    ,class ,(initialize-info class nkeys nil)))
		 initargs-form-list))
    (add-forms `((finish-pushing-initargs))
	       initargs-form-list)
    (values (car initargs-form-list) nkeys)))

(defun make-shared-initialize-form-list (class keys si-slot-names simple-p)
  (let* ((initialize-form-list (cons nil nil))
	 (type (cond ((structure-class-p class)
		      'structure)
		     ((standard-class-p class)
		      'standard)
		     ((funcallable-standard-class-p class)
		      'funcallable)
		     (t (error "error in make-shared-initialize-form-list"))))
	 (wrapper (class-wrapper class))
	 (constants (when simple-p
		      (make-array (wrapper-no-of-instance-slots wrapper)
				  ':initial-element *slot-unbound*)))
	 (slots (class-slots class))
	 (slot-names (mapcar #'slot-definition-name slots))
	 (slots-key (mapcar #'(lambda (slot)
				(let ((index most-positive-fixnum))
				  (dolist (key (slot-definition-initargs slot))
				    (let ((pos (position key keys)))
				      (when pos (setq index (min index pos)))))
				  (cons slot index)))
			    slots))
	 (slots (stable-sort slots-key #'< :key #'cdr)))
    (let ((n-popped 0))
      (declare (fixnum n-popped))
      (dolist (slot+index slots)
	(let* ((slot (car slot+index))
	       (name (slot-definition-name slot))
	       (npop (1+ (- (the fixnum (cdr slot+index)) n-popped))))
	  (declare (fixnum npop))
	  (unless (eql (cdr slot+index) most-positive-fixnum)
	    (let* ((pv-offset (1+ (position name slot-names))))
	      (add-forms `(,@(when (plusp npop)
			       `((pop-initargs ,(the fixnum (* 2 npop)))))
			   (instance-set ,pv-offset ,slot))
			 initialize-form-list))
	    (incf n-popped npop)))))
    (dolist (slot+index slots)
      (let* ((slot (car slot+index))
	     (name (slot-definition-name slot)))
	(when (and (eql (cdr slot+index) most-positive-fixnum)
		   (or (eq si-slot-names 't)
		       (member name si-slot-names)))
	  (let* ((initform (slot-definition-initform slot))
		 (initfunction (slot-definition-initfunction slot))
		 (location (unless (eq type 'structure)
			     (slot-definition-location slot)))
		 (pv-offset (1+ (position name slot-names)))
		 (forms (cond ((null initfunction)
			       nil)
			      ((constantp initform)
			       (let ((value (funcall initfunction)))
				 (if (and simple-p (integerp location))
				     (progn (setf (svref constants location) value)
					    nil)
				     `((const ,value)
				       (instance-set ,pv-offset ,slot)))))
			      (t
			       `((funcall ,(slot-definition-initfunction slot))
				 (instance-set ,pv-offset ,slot))))))
	    (add-forms `(,@(unless (or simple-p (null forms))
			     `((skip-when-instance-boundp ,pv-offset ,slot
				,(length forms))))
			 ,@forms)
		       initialize-form-list)))))
    (values (car initialize-form-list) constants)))

(defvar *class-pv-table-table* (make-hash-table :test 'eq))

(defun get-pv-cell-for-class (class)
  (let* ((slot-names (mapcar #'slot-definition-name (class-slots class)))
	 (slot-name-lists (list (cons nil slot-names)))
	 (pv-table (gethash class *class-pv-table-table*)))
    (unless (and pv-table
		 (equal slot-name-lists (pv-table-slot-name-lists pv-table)))
      (setq pv-table (intern-pv-table :slot-name-lists slot-name-lists))
      (setf (gethash class *class-pv-table-table*) pv-table))
    (pv-table-lookup pv-table (class-wrapper class))))    

(defvar *initialize-instance-simple-alist* nil)
(defvar *note-iis-entry-p* nil)

(defvar *compiled-initialize-instance-simple-functions*
  (make-hash-table :test #'equal))

(defun initialize-instance-simple-function (use info class form-list)
  (let* ((pv-cell (get-pv-cell-for-class class))
	 (key (initialize-info-key info))
	 (sf-key (list* use (class-name (car key)) (cdr key))))
    (if (or *compile-make-instance-functions-p*
	    (gethash sf-key *compiled-initialize-instance-simple-functions*))
	(multiple-value-bind (form args)
	    (form-list-to-lisp pv-cell form-list)
	  (let ((entry (assoc form *initialize-instance-simple-alist*
			      :test #'equal)))
	    (setf (gethash sf-key
			   *compiled-initialize-instance-simple-functions*)
		  t)
	    (if entry
		(setf (cdddr entry) (union (list sf-key) (cdddr entry)
					   :test #'equal))
		(progn
		  (setq entry (list* form nil nil (list sf-key)))
		  (setq *initialize-instance-simple-alist*
			(nconc *initialize-instance-simple-alist*
			       (list entry)))))
	    (unless (or *note-iis-entry-p* (cadr entry))
	      (setf (cadr entry) (compile-lambda (car entry))))
	    (if (cadr entry)
		(apply (the function (cadr entry)) args)
		`(call-initialize-instance-simple ,pv-cell ,form-list))))
	#||
	#'(lambda (instance initargs)
	    (initialize-instance-simple pv-cell form-list instance initargs))
	||#
	`(call-initialize-instance-simple ,pv-cell ,form-list))))

(defun load-precompiled-iis-entry (form function system uses)
  (let ((entry (assoc form *initialize-instance-simple-alist*
		      :test #'equal)))
    (unless entry
      (setq entry (list* form nil nil nil))
      (setq *initialize-instance-simple-alist*
	    (nconc *initialize-instance-simple-alist*
		   (list entry))))
    (setf (cadr entry) function)
    (setf (caddr entry) system)
    (dolist (use uses)
      (setf (gethash use *compiled-initialize-instance-simple-functions*) t))
    (setf (cdddr entry) (union uses (cdddr entry)
			       :test #'equal))))

(defmacro precompile-iis-functions (&optional system)
  (let ((index -1))
    `(progn
      ,@(gathering1 (collecting)
	 (dolist (iis-entry *initialize-instance-simple-alist*)
	   (when (or (null (caddr iis-entry))
		     (eq (caddr iis-entry) system))
	     (when system (setf (caddr iis-entry) system))
	     (gather1
	      (make-top-level-form
	       `(precompile-initialize-instance-simple ,system ,(incf index))
	       '(load)
	       `(load-precompiled-iis-entry
		 ',(car iis-entry)
		 #',(car iis-entry)
		 ',system
		 ',(cdddr iis-entry))))))))))

(defun compile-iis-functions (after-p)
  (let ((*compile-make-instance-functions-p* t)
	(*revert-initialize-info-p* t)
	(*note-iis-entry-p* (not after-p)))
    (declare (special *compile-make-instance-functions-p*))
    (when (eq *boot-state* 'complete)
      (update-make-instance-function-table))))


;(const const)
;(funcall function)
;(push-initarg const)
;(pop-supplied count) ; a positive odd number 
;(instance-set pv-offset slotd)
;(skip-when-instance-boundp pv-offset slotd n)

(defun initialize-instance-simple (pv-cell form-list instance initargs)
  (let ((pv (car pv-cell))
	(initargs-tail initargs)
	(slots (get-slots-or-nil instance))
	(class (class-of instance))
	value)
    (loop (when (null form-list) (return nil))
	  (let ((form (pop form-list)))
	    (ecase (car form)
	      (push-initarg 
	       (push value initargs)
	       (push (cadr form) initargs))
	      (const
	       (setq value (cadr form)))
	      (funcall
	       (setq value (funcall (the function (cadr form)))))
	      (pop-initargs
	       (setq initargs-tail (nthcdr (1- (cadr form)) initargs-tail))
	       (setq value (pop initargs-tail)))
	      (instance-set
	       (instance-write-internal 
		pv slots (cadr form) value
		(setf (slot-value-using-class class instance (caddr form)) value)))
	      (skip-when-instance-boundp
	       (when (instance-boundp-internal 
		      pv slots (cadr form)
		      (slot-boundp-using-class class instance (caddr form)))
		 (dotimes (i (cadddr form))
		   (pop form-list))))
	      (update-initialize-info-cache
	       (when (consp initargs)
		 (setq initargs (cons (car initargs) (cdr initargs))))
	       (setq *initialize-info-cache-class* (cadr form))
	       (setq *initialize-info-cache-initargs* initargs)
	       (setq *initialize-info-cache-info* (caddr form)))
	      (finish-pushing-initargs
	       (setq initargs-tail initargs)))))
    initargs))

(defun add-to-cvector (cvector constant)
  (or (position constant cvector)
      (prog1 (fill-pointer cvector)
	(vector-push-extend constant cvector))))

(defvar *inline-iis-instance-locations-p* t)

(defun first-form-to-lisp (forms cvector pv)
  (flet ((const (constant)
	   (cond ((or (numberp constant) (characterp constant))
		  constant)
		 ((and (symbolp constant) (symbol-package constant))
		  `',constant)
		 (t
		  `(svref cvector ,(add-to-cvector cvector constant))))))
    (let ((form (pop (car forms))))
      (ecase (car form)
	(push-initarg
	 `((push value initargs)
	   (push ,(const (cadr form)) initargs)))
	(const
	 `((setq value ,(const (cadr form)))))
	(funcall
	 `((setq value (funcall (the function ,(const (cadr form)))))))
	(pop-initargs
	 `((setq initargs-tail (,@(let ((pop (1- (cadr form))))
				    (case pop
				      (1 `(cdr))
				      (3 `(cdddr))
				      (t `(nthcdr ,pop))))
				initargs-tail))
	   (setq value (pop initargs-tail))))
	(instance-set
	 (let* ((pv-offset (cadr form))
		(location (pvref pv pv-offset))
		(default `(setf (slot-value-using-class class instance
							,(const (caddr form)))
				value)))
	   (if *inline-iis-instance-locations-p*
	       (typecase location
		 (fixnum `((setf (%instance-ref slots ,(const location)) value)))
		 (cons `((setf (cdr ,(const location)) value)))
		 (t `(,default)))
	       `((instance-write-internal pv slots ,(const pv-offset) value
		  ,default
		  ,(typecase location
		     (fixnum ':instance)
		     (cons ':class)
		     (t ':default)))))))
	(skip-when-instance-boundp
	 (let* ((pv-offset (cadr form))
		(location (pvref pv pv-offset))
		(default `(slot-boundp-using-class class instance
			   ,(const (caddr form)))))
	   `((unless ,(if *inline-iis-instance-locations-p*
			  (typecase location
			    (fixnum `(not (eq (%instance-ref slots ,(const location))
					      ',*slot-unbound*)))
			    (cons `(not (eq (cdr ,(const location)) ',*slot-unbound*)))
			    (t default))
			  `(instance-boundp-internal pv slots ,(const pv-offset)
			    ,default
			    ,(typecase (pvref pv pv-offset)
			       (fixnum ':instance)
			       (cons ':class)
			       (t ':default))))
	       ,@(let ((sforms (cons nil nil)))
		   (dotimes (i (cadddr form) (car sforms))
		     (add-forms (first-form-to-lisp forms cvector pv) sforms)))))))
	(update-initialize-info-cache
	 `((when (consp initargs)
	     (setq initargs (cons (car initargs) (cdr initargs))))
	   (setq *initialize-info-cache-class* ,(const (cadr form)))
	   (setq *initialize-info-cache-initargs* initargs)
	   (setq *initialize-info-cache-info* ,(const (caddr form)))))
	(finish-pushing-initargs
	 `((setq initargs-tail initargs)))))))

(defmacro iis-body (&body forms)
  (let ((vars '(initargs-tail pv slots wrapper class value)))
    `(let ((initargs-tail initargs)
	   (pv (car pv-cell))
	   (slots nil)
	   (wrapper #+cmu17 (kernel:layout-of instance) #-cmu17 nil)
	   class
	   value)
       ,@(progn
	  #-cmu vars
	  #+cmu `((declare (ignorable ,@vars))))
       #+cmu17
       (cond ((not (typep wrapper 'wrapper)))
	     ((std-instance-p instance)
	      (setq slots (std-instance-slots instance)))
	     (t
	      (setq slots (fsc-instance-slots instance))))
       #-cmu17
       (cond ((std-instance-p instance)
	      (setq slots (std-instance-slots instance))
	      (setq wrapper (std-instance-wrapper instance)))
	     ((fsc-instance-p instance)
	      (setq slots (fsc-instance-slots instance))
	      (setq wrapper (fsc-instance-wrapper instance)))
	     (t
	      (setq wrapper (wrapper-of instance))))
       (setq class (wrapper-class wrapper))
       ,@forms)))

(defun form-list-to-lisp (pv-cell form-list)
  (let* ((forms (list form-list))
	 (cvector (make-array (floor (length form-list) 2)
			      :fill-pointer 0 :adjustable t))
	 (pv (car pv-cell))
	 (body (let ((rforms (cons nil nil)))
		 (loop (when (null (car forms)) (return (car rforms)))
		       (add-forms (first-form-to-lisp forms cvector pv)
				  rforms))))
	 (cvector-type `(simple-vector ,(length cvector))))
    (values
     `(lambda (pv-cell cvector)
        (declare (type ,cvector-type cvector))
	#+cmu
	(declare (ignorable pv-cell cvector))
        #'(lambda (instance initargs)
	    (declare #.*optimize-speed*)
	    #+cmu
	    (declare (ignorable instance initargs))
	    (iis-body ,@body)
	    initargs))
     (list pv-cell (coerce cvector cvector-type)))))


;The effect of this is to cause almost all of the overhead of make-instance
;to happen at load time (or maybe at precompile time, as explained in a 
;previous message) rather than the first time make-instance is called with 
;a given class-name and sequence of keywords.  

;This optimization applys only when the first argument and all the even 
;numbered arguments are constants evaluating to interned symbols.

#+cmu
(declaim (ftype (function (t) symbol) get-make-instance-function-symbol))

; Use this definition in any CL implementation supporting 
; both define-compiler-macro and load-time-value.
#+cmu
(define-compiler-macro make-instance (&whole form &rest args)
  (declare (ignore args))
  (let* ((*make-instance-function-keys* nil)
	 (expanded-form (expand-make-instance-form form)))
    (if expanded-form
	`(funcall (the function
		       (symbol-function
			;; The symbol is guaranteed to be fbound.
			;; Is there a way to declare this?
			(load-time-value
			 (get-make-instance-function-symbol 
			  ',(first *make-instance-function-keys*)))))
		  ,@(cdr expanded-form))
	form)))

(defun get-make-instance-function-symbol (key)
  (get-make-instance-functions (list key))
  (make-instance-function-symbol key))