;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); 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.
;;; *************************************************************************
;;;
;;; Bootstrapping the meta-braid.
;;;
;;; The code in this file takes the early definitions that have been saved
;;; up and actually builds those class objects.  This work is largely driven
;;; off of those class definitions, but the fact that STANDARD-CLASS is the
;;; class of all metaclasses in the braid is built into this code pretty
;;; deeply.
;;;
;;; 

(in-package :pcl)

(defun allocate-standard-instance (wrapper &optional (slots-init nil slots-init-p))
  #-new-kcl-wrapper (declare (special *slot-unbound*))
  #-new-kcl-wrapper
  (let ((instance (%%allocate-instance--class)))
    (setf (std-instance-wrapper instance) wrapper)
    (setf (std-instance-slots instance) 
	  (if slots-init-p
	      (copy-slots slots-init)
	      (make-array (wrapper-no-of-instance-slots wrapper)
			  :initial-element *slot-unbound*)))
    instance)
  #+new-kcl-wrapper
  (apply #'si:make-structure wrapper
	 (if slots-init-p
	     slots-init
	     (let ((no-of-slots (si::s-data-length wrapper)))
	       (if (< no-of-slots (fill-pointer *init-vector*))
		   (aref *init-vector* no-of-slots)
		   (get-init-list no-of-slots))))))

(defmacro allocate-funcallable-instance-slots (wrapper &optional 
						       slots-init-p slots-init)
  #-new-kcl-wrapper
  `(let ((no-of-slots (wrapper-no-of-instance-slots ,wrapper)))
     ,(if slots-init-p
	  `(if ,slots-init-p
	       (copy-slots ,slots-init)
	       (make-array no-of-slots :initial-element *slot-unbound*))
	  `(make-array no-of-slots :initial-element *slot-unbound*)))
  #+new-kcl-wrapper
  (if slots-init-p
      `(if ,slots-init-p
	   (allocate-standard-instance ,wrapper ,slots-init)
	   (allocate-standard-instance ,wrapper))
      `(allocate-standard-instance ,wrapper)))

(defun allocate-funcallable-instance (wrapper &optional (slots-init nil slots-init-p))
  (let ((fin (allocate-funcallable-instance-1)))
    (set-funcallable-instance-function
     fin
     (fin-lambda-fn (&rest args)
       (declare (ignore args))
       (error "The function of the funcallable-instance ~S has not been set" fin)))
    (setf (fsc-instance-wrapper fin) wrapper
	  (fsc-instance-slots fin) (allocate-funcallable-instance-slots
				    wrapper slots-init-p slots-init))
    fin))

(defun allocate-structure-instance (wrapper &optional (slots-init nil slots-init-p))
  #-new-kcl-wrapper
  (let* ((class (wrapper-class wrapper))
	 (constructor (class-defstruct-constructor class)))
    (if constructor
	(let ((instance (funcall constructor))
	      (slots (class-slots class)))
	  (when slots-init-p
	    (dotimes (i (length slots-init))
	      (let ((slot (pop slots)))
		(setf (slot-value-using-class class instance slot)
		      (svref slots-init i)))))
	  instance)
	(error "Can't allocate an instance of class ~S" (class-name class))))
  #+new-kcl-wrapper
  (if slots-init-p
      (allocate-standard-instance wrapper slots-init)
      (allocate-standard-instance wrapper)))

;;;
;;; bootstrap-meta-braid
;;;
;;; This function builds the base metabraid from the early class definitions.
;;;   
(defmacro initial-classes-and-wrappers (&rest classes)
  `(progn
     ,@(mapcar #'(lambda (class)
		   (let ((wr (intern (format nil "~A-WRAPPER" class) 
				     *the-pcl-package*)))
		     `(setf ,wr ,(if (eq class 'standard-generic-function)
				     '*sgf-wrapper*
				     #-cmu17
				     `(make-wrapper (early-class-size ',class))
				     #+cmu17
				     `(boot-make-wrapper
				       (early-class-size ',class)
				       ',class))
		            ,class (allocate-standard-instance
				    ,(if (eq class 'standard-generic-function)
					 'funcallable-standard-class-wrapper
					 'standard-class-wrapper))
		            (wrapper-class ,wr) ,class
		            #+new-kcl-wrapper (si::s-data-name ,wr)
		                   #+new-kcl-wrapper ',class
		            (find-class ',class) ,class)))
	      classes)))		        

(defun bootstrap-meta-braid ()
  (let* ((name 'class)
	 (predicate-name (make-type-predicate-name name)))
    (setf (gdefinition predicate-name)
	  #'(lambda (x) (declare (ignore x)) t))
    (do-satisfies-deftype name predicate-name))  
  (let* ((*create-classes-from-internal-structure-definitions-p* nil)
	 standard-class-wrapper standard-class
	 funcallable-standard-class-wrapper funcallable-standard-class
	 slot-class-wrapper slot-class
	 built-in-class-wrapper built-in-class
	 structure-class-wrapper structure-class
	 standard-direct-slot-definition-wrapper standard-direct-slot-definition
	 standard-effective-slot-definition-wrapper standard-effective-slot-definition
	 class-eq-specializer-wrapper class-eq-specializer
	 standard-generic-function-wrapper standard-generic-function)
    (initial-classes-and-wrappers 
     standard-class funcallable-standard-class
     slot-class built-in-class structure-class
     standard-direct-slot-definition standard-effective-slot-definition 
     class-eq-specializer standard-generic-function)
    ;;
    ;; First, make a class metaobject for each of the early classes.  For
    ;; each metaobject we also set its wrapper.  Except for the class T,
    ;; the wrapper is always that of STANDARD-CLASS.
    ;; 
    (dolist (definition *early-class-definitions*)
      (let* ((name (ecd-class-name definition))
	     (meta (ecd-metaclass definition))
	     (wrapper (ecase meta
			(slot-class slot-class-wrapper)
			(standard-class standard-class-wrapper)
			(funcallable-standard-class funcallable-standard-class-wrapper)
			(built-in-class built-in-class-wrapper)
			(structure-class structure-class-wrapper)))
             (class (or (find-class name nil)
			(allocate-standard-instance wrapper))))
	(when (or (eq meta 'standard-class) (eq meta 'funcallable-standard-class))
	  (inform-type-system-about-std-class name))
        (setf (find-class name) class)))
    ;;
    ;;
    ;;
    (dolist (definition *early-class-definitions*)
      (let ((name (ecd-class-name definition))
	    (meta (ecd-metaclass definition))
	    (source (ecd-source definition))
	    (direct-supers (ecd-superclass-names definition))
	    (direct-slots  (ecd-canonical-slots definition))
	    (other-initargs (ecd-other-initargs definition)))
	(let ((direct-default-initargs
	       (getf other-initargs :direct-default-initargs)))
	  (multiple-value-bind (slots cpl default-initargs direct-subclasses)
	      (early-collect-inheritance name)
	    (let* ((class (find-class name))
		   (wrapper (cond ((eq class slot-class)
				   slot-class-wrapper)
				  ((eq class standard-class) 
				   standard-class-wrapper)
				  ((eq class funcallable-standard-class) 
				   funcallable-standard-class-wrapper)
				  ((eq class standard-direct-slot-definition) 
				   standard-direct-slot-definition-wrapper)
				  ((eq class standard-effective-slot-definition) 
				   standard-effective-slot-definition-wrapper)
				  ((eq class built-in-class)  
				   built-in-class-wrapper)
				  ((eq class structure-class)
				   structure-class-wrapper)
				  ((eq class class-eq-specializer)
				   class-eq-specializer-wrapper)
				  ((eq class standard-generic-function)
				   standard-generic-function-wrapper)
				  (t
				   #-cmu17
				   (make-wrapper (length slots) class)
				   #+cmu17
				   (boot-make-wrapper (length slots) name))))
		   (proto nil))
	      (when (eq name 't) (setq *the-wrapper-of-t* wrapper))
	      (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name))
			   *the-pcl-package*)
		   class)
	      (dolist (slot slots)
		(unless (eq (getf slot :allocation :instance) :instance)
		  (error "Slot allocation ~S not supported in bootstrap.")))
	      
	      (when #+cmu17 (typep wrapper 'wrapper) #-cmu17 t
		(setf (wrapper-instance-slots-layout wrapper)
		      (mapcar #'canonical-slot-name slots))
		(setf (wrapper-class-slots wrapper)
		      ()))
	      
	      (setq proto (if (eq meta 'funcallable-standard-class)
			      (allocate-funcallable-instance wrapper)
			      (allocate-standard-instance wrapper)))
	    
	      (setq direct-slots
		    (bootstrap-make-slot-definitions 
		     name class direct-slots
		     standard-direct-slot-definition-wrapper nil))
	      (setq slots
		    (bootstrap-make-slot-definitions 
		     name class slots
		     standard-effective-slot-definition-wrapper t))
	      
	      (case meta
		((standard-class funcallable-standard-class)
		 (bootstrap-initialize-class 
		  meta
		  class name class-eq-specializer-wrapper source
		  direct-supers direct-subclasses cpl wrapper proto
		  direct-slots slots direct-default-initargs default-initargs))
		(built-in-class		; *the-class-t*
		 (bootstrap-initialize-class 
		  meta
		  class name class-eq-specializer-wrapper source
		  direct-supers direct-subclasses cpl wrapper proto))
		(slot-class		; *the-class-slot-object*
		 (bootstrap-initialize-class 
		  meta
		  class name class-eq-specializer-wrapper source
		  direct-supers direct-subclasses cpl wrapper proto))
		(structure-class	; *the-class-structure-object*
		 (bootstrap-initialize-class 
		  meta
		  class name class-eq-specializer-wrapper source
		  direct-supers direct-subclasses cpl wrapper))))))))

    (let* ((smc-class (find-class 'standard-method-combination))
	   (smc-wrapper (bootstrap-get-slot 'standard-class smc-class 'wrapper))
	   (smc (allocate-standard-instance smc-wrapper)))
      (flet ((set-slot (name value)
	       (bootstrap-set-slot 'standard-method-combination smc name value)))
	(set-slot 'source (load-truename))
	(set-slot 'type 'standard)
	(set-slot 'documentation "The standard method combination.")
	(set-slot 'options ()))
      (setq *standard-method-combination* smc))))

;;;
;;; Initialize a class metaobject.
;;;
(defun bootstrap-initialize-class
       (metaclass-name class name
        class-eq-wrapper source direct-supers direct-subclasses cpl wrapper
	&optional proto direct-slots slots direct-default-initargs default-initargs)
  (flet ((classes (names) (mapcar #'find-class names))
	 (set-slot (slot-name value)
	   (bootstrap-set-slot metaclass-name class slot-name value)))
    (set-slot 'name name)
    (set-slot 'source source)
    (set-slot 'type (if (eq class (find-class 't))
			t
			`(class ,class)))
    (set-slot 'class-eq-specializer 
	      (let ((spec (allocate-standard-instance class-eq-wrapper)))
		(bootstrap-set-slot 'class-eq-specializer spec 'type 
				    `(class-eq ,class))
		(bootstrap-set-slot 'class-eq-specializer spec 'object
				    class)
		spec))
    (set-slot 'class-precedence-list (classes cpl))
    (set-slot 'can-precede-list (classes (cdr cpl)))
    (set-slot 'incompatible-superclass-list nil)
    (set-slot 'direct-superclasses (classes direct-supers))
    (set-slot 'direct-subclasses (classes direct-subclasses))
    (set-slot 'direct-methods (cons nil nil))
    (set-slot 'wrapper wrapper)
    #+new-kcl-wrapper
    (setf (si::s-data-name wrapper) name)
    (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*))
				  (make-class-predicate-name name)))
    (set-slot 'plist
	      `(,@(and direct-default-initargs
		       `(direct-default-initargs ,direct-default-initargs))
		,@(and default-initargs
		       `(default-initargs ,default-initargs))))
    (when (memq metaclass-name '(standard-class funcallable-standard-class
				 structure-class slot-class))
      (set-slot 'direct-slots direct-slots)
      (set-slot 'slots slots)
      (set-slot 'initialize-info nil))
    (if (eq metaclass-name 'structure-class)
	(let ((constructor-sym '|STRUCTURE-OBJECT class constructor|))
	  (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*))
					(make-class-predicate-name name)))
	  (set-slot 'defstruct-form 
		    `(defstruct (structure-object (:constructor ,constructor-sym))))
	  (set-slot 'defstruct-constructor constructor-sym)
	  (set-slot 'from-defclass-p t)    
	  (set-slot 'plist nil)
	  (set-slot 'prototype (funcall constructor-sym)))
	(set-slot 'prototype (or proto (allocate-standard-instance wrapper))))
    class))

(defun bootstrap-make-slot-definitions (name class slots wrapper effective-p)
  (let ((index -1))
    (mapcar #'(lambda (slot)
		(incf index)
		(bootstrap-make-slot-definition
		  name class slot wrapper effective-p index))
	    slots)))

(defun bootstrap-make-slot-definition (name class slot wrapper effective-p index)  
  (let* ((slotd-class-name (if effective-p
			       'standard-effective-slot-definition
			       'standard-direct-slot-definition))
	 (slotd (allocate-standard-instance wrapper))
	 (slot-name (getf slot :name)))
    (flet ((get-val (name) (getf slot name))
	   (set-val (name val) (bootstrap-set-slot slotd-class-name slotd name val)))
      (set-val 'name         slot-name)
      (set-val 'initform     (get-val :initform))
      (set-val 'initfunction (get-val :initfunction))      
      (set-val 'initargs     (get-val :initargs))
      (set-val 'readers      (get-val :readers))
      (set-val 'writers      (get-val :writers))
      (set-val 'allocation   :instance)
      (set-val 'type         (or (get-val :type) t))
      (set-val 'documentation (or (get-val :documentation) ""))
      (set-val 'class        class)
      (when effective-p
	(set-val 'location index)
	(let ((fsc-p nil))
	  (set-val 'reader-function (make-optimized-std-reader-method-function 
				     fsc-p slot-name index))
	  (set-val 'writer-function (make-optimized-std-writer-method-function 
				     fsc-p slot-name index))
	  (set-val 'boundp-function (make-optimized-std-boundp-method-function 
				     fsc-p slot-name index)))
	(set-val 'accessor-flags 7)
	(let ((table (or (gethash slot-name *name->class->slotd-table*)
			 (setf (gethash slot-name *name->class->slotd-table*)
			       (make-hash-table :test 'eq :size 5)))))
	  (setf (gethash class table) slotd)))
      (when (and (eq name 'standard-class)
		 (eq slot-name 'slots) effective-p)
	(setq *the-eslotd-standard-class-slots* slotd))
      (when (and (eq name 'funcallable-standard-class)
		 (eq slot-name 'slots) effective-p)
	(setq *the-eslotd-funcallable-standard-class-slots* slotd))
      slotd)))

(defun bootstrap-accessor-definitions (early-p)
  (let ((*early-p* early-p))
    (dolist (definition *early-class-definitions*)
      (let ((name (ecd-class-name definition))
	    (meta (ecd-metaclass definition)))
	(unless (eq meta 'built-in-class)
	  (let ((direct-slots  (ecd-canonical-slots definition)))
	    (dolist (slotd direct-slots)
	      (let ((slot-name (getf slotd :name))
		    (readers (getf slotd :readers))
		    (writers (getf slotd :writers)))
		(bootstrap-accessor-definitions1 name slot-name readers writers nil)
		(bootstrap-accessor-definitions1 
		 'slot-object
		 slot-name
		 (list (slot-reader-symbol slot-name))
		 (list (slot-writer-symbol slot-name))
		 (list (slot-boundp-symbol slot-name)))))))))))

(defun bootstrap-accessor-definition (class-name accessor-name slot-name type)
  (multiple-value-bind (accessor-class make-method-function arglist specls doc)
      (ecase type
	(reader (values 'standard-reader-method #'make-std-reader-method-function
			(list class-name) (list class-name)
			"automatically generated reader method"))
	(writer (values 'standard-writer-method #'make-std-writer-method-function
			(list 'new-value class-name) (list 't class-name)
			"automatically generated writer method"))
	(boundp (values 'standard-boundp-method #'make-std-boundp-method-function
			(list class-name) (list class-name)
			"automatically generated boundp method")))
    (let ((gf (ensure-generic-function accessor-name)))
      (if (find specls (early-gf-methods gf) 
		:key #'early-method-specializers
		:test #'equal)
	  (unless (assoc accessor-name *generic-function-fixups*
			 :test #'equal)
	    (update-dfun gf))
	  (add-method gf
		      (make-a-method accessor-class
				     ()
				     arglist specls
				     (funcall make-method-function
					      class-name slot-name)
				     doc
				     slot-name))))))

(defun bootstrap-accessor-definitions1 (class-name slot-name readers writers boundps)
  (flet ((do-reader-definition (reader)
	   (bootstrap-accessor-definition class-name reader slot-name 'reader))
	 (do-writer-definition (writer)
	   (bootstrap-accessor-definition class-name writer slot-name 'writer))
	 (do-boundp-definition (boundp)
	   (bootstrap-accessor-definition class-name boundp slot-name 'boundp)))
    (dolist (reader readers) (do-reader-definition reader))
    (dolist (writer writers) (do-writer-definition writer))
    (dolist (boundp boundps) (do-boundp-definition boundp))))

(defun bootstrap-class-predicates (early-p)
  (let ((*early-p* early-p))
    (dolist (definition *early-class-definitions*)
      (let* ((name (ecd-class-name definition))
	     (class (find-class name)))
	(setf (find-class-predicate name)
	      (make-class-predicate class (class-predicate-name class)))))))

(defun bootstrap-built-in-classes ()
  ;;
  ;; First make sure that all the supers listed in *built-in-class-lattice*
  ;; are themselves defined by *built-in-class-lattice*.  This is just to
  ;; check for typos and other sorts of brainos.
  ;; 
  (dolist (e *built-in-classes*)
    (dolist (super (cadr e))
      (unless (or (eq super 't)
		  (assq super *built-in-classes*))
	(error "In *built-in-classes*: ~S has ~S as a super,~%~
                but ~S is not itself a class in *built-in-classes*."
	       (car e) super super))))

  ;;
  ;; In the first pass, we create a skeletal object to be bound to the
  ;; class name.
  ;;
  (let* ((built-in-class (find-class 'built-in-class))
	 (built-in-class-wrapper (class-wrapper built-in-class)))
    (dolist (e *built-in-classes*)
      (let ((class (allocate-standard-instance built-in-class-wrapper)))
	(setf (find-class (car e)) class))))

  ;;
  ;; In the second pass, we initialize the class objects.
  ;;
  (let ((class-eq-wrapper (class-wrapper (find-class 'class-eq-specializer))))
    (dolist (e *built-in-classes*)
    ; FIXME use regular destructuring-bind
      (pcl-destructuring-bind (name supers subs cpl prototype) e
	(let* ((class (find-class name))
	       #+cmu17
	       (lclass (lisp:find-class name))
	       (wrapper #-cmu17(make-wrapper 0 class)
			#+cmu17(kernel:class-layout lclass)))
	  (set (get-built-in-class-symbol name) class)
	  (set (get-built-in-wrapper-symbol name) wrapper)
	  #+cmu17
	  (setf (kernel:class-pcl-class lclass) class)
	  #-cmu17
	  (setf (wrapper-instance-slots-layout wrapper) ()
		(wrapper-class-slots wrapper) ())

	  (bootstrap-initialize-class 'built-in-class class
				      name class-eq-wrapper nil
				      supers subs
				      (cons name cpl)
				      wrapper prototype)))))
  
  (dolist (e *built-in-classes*)
    (let* ((name (car e))
	   (class (find-class name)))
      (setf (find-class-predicate name)
	    (make-class-predicate class (class-predicate-name class))))))


;;;
;;;
;;;
#-(or new-kcl-wrapper cmu17)
(progn
(defvar *built-in-or-structure-wrapper-table*
  (make-hash-table :test 'eq))

(defvar wft-type1 nil)
(defvar wft-wrapper1 nil)
(defvar wft-type2 nil)
(defvar wft-wrapper2 nil)

(defun wrapper-for-structure (x)
  (let ((type (structure-type x)))
    (when (symbolp type)
      (cond ((eq type 'std-instance) 
	     (return-from wrapper-for-structure (std-instance-wrapper x)))
	    ((eq type wft-type1) (return-from wrapper-for-structure wft-wrapper1))
	    ((eq type wft-type2) (return-from wrapper-for-structure wft-wrapper2))
	    (t (setq wft-type2 wft-type1  wft-wrapper2 wft-wrapper1))))
    (let* ((cell (find-class-cell type))
	   (class (or (find-class-cell-class cell)
		      (let* (#+lucid 
			     (*structure-type* type)
			     #+lucid
			     (*structure-length* (structure-length x type)))
			(find-class-from-cell type cell))))
	   (wrapper (if class (class-wrapper class) *the-wrapper-of-t*)))
      (when (symbolp type)
	(setq wft-type1 type  wft-wrapper1 wrapper))
      wrapper)))

(defun built-in-or-structure-wrapper1 (x)
  (let ((biw (or (built-in-wrapper-of x) *the-wrapper-of-t*)))
    (or (and (eq biw *the-wrapper-of-t*)
	     (structurep x)
	     (let* ((type (type-of x))
		    #+lucid 
		    (*structure-type* type)
		    #+lucid
		    (*structure-length* (structure-length x type))
		    (class (find-class type nil)))
	       (and class (class-wrapper class))))
	biw)))
)

#|| ; moved to low.lisp
(defmacro built-in-or-structure-wrapper (x)
  (once-only (x)
    (if (structure-functions-exist-p) ; otherwise structurep is too slow for this
	`(if (structurep ,x)
	     (wrapper-for-structure ,x)
	     (if (symbolp ,x)
		 (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*)
		 (built-in-wrapper-of ,x)))
	`(or (and (symbolp ,x)
		  (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*))
	     (built-in-or-structure-wrapper1 ,x)))))

#-cmu17
(defmacro wrapper-of-macro (x)
  `(cond ((std-instance-p ,x)
	  (std-instance-wrapper ,x))
         ((fsc-instance-p ,x)
	  (fsc-instance-wrapper ,x))	      
         (t
	  (#+new-kcl-wrapper built-in-wrapper-of
	   #-new-kcl-wrapper built-in-or-structure-wrapper
	   ,x))))

#+cmu17
(defmacro wrapper-of-macro (x)
  `(kernel:layout-of ,x))
||#

(defun class-of (x)
  (wrapper-class* (wrapper-of-macro x)))

#+cmu17
(declaim (inline wrapper-of))
(defun wrapper-of (x)
  (wrapper-of-macro x))

#-cmu17
(defun structure-wrapper (x)
  (class-wrapper (find-class (structure-type x))))

(defvar find-structure-class nil)

(defun eval-form (form)
  #'(lambda () (eval form)))

(defun slot-initargs-from-structure-slotd (slotd)
  `(:name ,(structure-slotd-name slotd)
    :defstruct-accessor-symbol ,(structure-slotd-accessor-symbol slotd)
    :internal-reader-function ,(structure-slotd-reader-function slotd)
    :internal-writer-function ,(structure-slotd-writer-function slotd)
    :type ,(or (structure-slotd-type slotd) t)
    :initform ,(structure-slotd-init-form slotd)
    :initfunction ,(eval-form (structure-slotd-init-form slotd))))

(defun find-structure-class (symbol)
  (if (structure-type-p symbol)
      (unless (eq find-structure-class symbol)
	(let ((find-structure-class symbol))
	  (ensure-class symbol
			:metaclass 'structure-class
			:name symbol
			:direct-superclasses
			(when (structure-type-included-type-name symbol)
			  (list (structure-type-included-type-name symbol)))
			:direct-slots
			(mapcar #'slot-initargs-from-structure-slotd
				(structure-type-slot-description-list symbol)))))
      (error "~S is not a legal structure class name." symbol)))

#-cmu17
(eval-when (compile eval)

(defun make-built-in-class-subs ()
  (mapcar #'(lambda (e)
	      (let ((class (car e))
		    (class-subs ()))
		(dolist (s *built-in-classes*)
		  (when (memq class (cadr s)) (pushnew (car s) class-subs)))
		(cons class class-subs)))
	  (cons '(t) *built-in-classes*)))

(defun make-built-in-class-tree ()
  (let ((subs (make-built-in-class-subs)))
    (labels ((descend (class)
	       (cons class (mapcar #'descend (cdr (assq class subs))))))
      (descend 't))))

(defun make-built-in-wrapper-of-body ()
  (make-built-in-wrapper-of-body-1 (make-built-in-class-tree)
				   'x
				   #'get-built-in-wrapper-symbol))

(defun make-built-in-wrapper-of-body-1 (tree var get-symbol)
  (let ((*specials* ()))
    (declare (special *specials*))
    (let ((inner (make-built-in-wrapper-of-body-2 tree var get-symbol)))
      `(locally (declare (special .,*specials*)) ,inner))))

(defun make-built-in-wrapper-of-body-2 (tree var get-symbol)
  (declare (special *specials*))
  (let ((symbol (funcall get-symbol (car tree))))
    (push symbol *specials*)
    (let ((sub-tests
	    (mapcar #'(lambda (x)
			(make-built-in-wrapper-of-body-2 x var get-symbol))
		    (cdr tree))))
      `(and (typep ,var ',(car tree))
	    ,(if sub-tests
		 `(or ,.sub-tests ,symbol)
		 symbol)))))
)

#-cmu17
(defun built-in-wrapper-of (x)
  #.(when (fboundp 'make-built-in-wrapper-of-body) ; so we can at least read this file
      (make-built-in-wrapper-of-body)))



(defun method-function-returning-nil (args next-methods)
  (declare (ignore args next-methods))
  nil)

(defun method-function-returning-t (args next-methods)
  (declare (ignore args next-methods))
  t)

(defun make-class-predicate (class name)
  (let* ((gf (ensure-generic-function name))
	 (mlist (if (eq *boot-state* 'complete)
		    (generic-function-methods gf)
		    (early-gf-methods gf))))
    (unless mlist
      (unless (eq class *the-class-t*)
	(let* ((default-method-function #'method-function-returning-nil)
	       (default-method-initargs (list :function
					      default-method-function))
	       (default-method (make-a-method 'standard-method
					      ()
					      (list 'object)
					      (list *the-class-t*)
					      default-method-initargs
					      "class predicate default method")))
	  (setf (method-function-get default-method-function :constant-value) nil)
	  (add-method gf default-method)))
      (let* ((class-method-function #'method-function-returning-t)
	     (class-method-initargs (list :function
					  class-method-function))
	     (class-method (make-a-method 'standard-method
					  ()
					  (list 'object)
					  (list class)
					  class-method-initargs
					  "class predicate class method")))
	(setf (method-function-get class-method-function :constant-value) t)
	(add-method gf class-method)))
    gf))


#+cmu17
;;; Set inherits from CPL and register layout.  This actually installs the
;;; class in the lisp type system.
;;;
(defun update-lisp-class-layout (class layout)
  (unless (eq (kernel:class-layout (kernel:layout-class layout))
	      layout)
    (setf (kernel:layout-inherits layout)
	  (map 'vector #'class-wrapper
	       (reverse (rest (class-precedence-list class)))))

    (kernel:register-layout layout :invalidate nil)))

(eval-when (load eval)
  (clrhash *find-class*)
  (bootstrap-meta-braid)
  (bootstrap-accessor-definitions t)
  (bootstrap-class-predicates t)
  (bootstrap-accessor-definitions nil)
  (bootstrap-class-predicates nil)
  (bootstrap-built-in-classes)

  #+cmu17
  (ext:do-hash (name x *find-class*)
    (let* ((class (find-class-from-cell name x))
	   (layout (class-wrapper class))
	   (lclass (kernel:layout-class layout))
	   (lclass-pcl-class (kernel:class-pcl-class lclass))
	   (olclass (lisp:find-class name nil)))
      (if lclass-pcl-class
	  (assert (eq class lclass-pcl-class))
	  (setf (kernel:class-pcl-class lclass) class))

      (update-lisp-class-layout class layout)

      (cond (olclass
	     (assert (eq lclass olclass)))
	    (t
	     (setf (lisp:find-class name) lclass)))))

  (setq *boot-state* 'braid)
  )

#-cmu17
(deftype slot-object ()
  '(or standard-object structure-object))

(defmethod no-applicable-method (generic-function &rest args)
  (cerror "Retry call to ~S"
	  "No matching method for the generic-function ~S,~@
          when called with arguments ~S."
	  generic-function args)
  (apply generic-function args))