;;;-*-Mode:LISP; Package:(CLOS (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1991 Venue
;;; All rights reserved.
;;; *************************************************************************
;;;
;;; 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 'clos)

(defun early-class-definition (class-name)
  (or (find class-name *early-class-definitions* :key #'ecd-class-name)
      (error "~S is not a class in *early-class-definitions*." class-name)))

(defun canonical-slot-name (canonical-slot)
  (getf canonical-slot :name))

(defun early-collect-inheritance (class-name)
  (declare (values slots cpl default-initargs direct-subclasses))
  (let ((cpl (early-collect-cpl class-name)))
    (values (early-collect-slots cpl)
	    cpl
	    (early-collect-default-initargs cpl)
	    (gathering1 (collecting)
	      (dolist (definition *early-class-definitions*)
		(when (memq class-name (ecd-superclass-names definition))
		  (gather1 (ecd-class-name definition))))))))

(defun early-collect-cpl (class-name)
  (labels ((walk (c)
	     (let* ((definition (early-class-definition c))
		    (supers (ecd-superclass-names definition)))
	       (cons c
		     (apply #'append (mapcar #'early-collect-cpl supers))))))
    (remove-duplicates (walk class-name) :from-end nil :test #'eq)))

(defun early-collect-slots (cpl)
  (let* ((definitions (mapcar #'early-class-definition cpl))
	 (super-slots (mapcar #'ecd-canonical-slots definitions))
	 (slots (apply #'append (reverse super-slots))))
    (dolist (s1 slots)
      (let ((name1 (canonical-slot-name s1)))
	(dolist (s2 (cdr (memq s1 slots)))
	  (when (eq name1 (canonical-slot-name s2))
	    (error "More than one early class defines a slot with the~%~
                    name ~S.  This can't work because the bootstrap~%~
                    object system doesn't know how to compute effective~%~
                    slots."
		   name1)))))
    slots))

(defun early-collect-default-initargs (cpl)
  (let ((default-initargs ()))
    (dolist (class-name cpl)
      (let ((definition (early-class-definition class-name)))
	(dolist (option (ecd-other-initargs definition))
	  (unless (eq (car option) :default-initargs)
	    (error "The defclass option ~S is not supported by the bootstrap~%~
                    object system."
		   (car option)))
	  (setq default-initargs
		(nconc default-initargs (reverse (cdr option)))))))
    (reverse default-initargs)))


;;;
;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change
;;; the values of slots during bootstrapping.  During bootstrapping, there
;;; are only two kinds of objects whose slots we need to access, CLASSes
;;; and SLOTDs.  The first argument to these functions tells whether the
;;; object is a CLASS or a SLOTD.
;;;
;;; Note that the way this works it stores the slot in the same place in
;;; memory that the full object system will expect to find it later.  This
;;; is critical to the bootstrapping process, the whole changeover to the
;;; full object system is predicated on this.
;;;
;;; One important point is that the layout of standard classes and standard
;;; slots must be computed the same way in this file as it is by the full
;;; object system later.
;;; 
(defun bootstrap-get-slot (type object slot-name)
  (let ((index (bootstrap-slot-index type slot-name)))
    (svref (std-instance-slots object) index)))

(defun bootstrap-set-slot (type object slot-name new-value)
  (let ((index (bootstrap-slot-index type slot-name)))
    (setf (svref (std-instance-slots object) index) new-value)))

(defvar *std-class-slots*
	(mapcar #'canonical-slot-name
		(early-collect-inheritance 'standard-class)))

(defvar *bin-class-slots*
	(mapcar #'canonical-slot-name
		(early-collect-inheritance 'built-in-class)))

(defvar *std-slotd-slots*
	(mapcar #'canonical-slot-name
		(early-collect-inheritance 'standard-slot-definition)))

(defun bootstrap-slot-index (type slot-name)
  (or (position slot-name (ecase type
			    (std-class *std-class-slots*)
			    (bin-class *bin-class-slots*)
			    (std-slotd *std-slotd-slots*)))
      (error "~S not found" slot-name)))


;;;
;;; bootstrap-meta-braid
;;;
;;; This function builds the base metabraid from the early class definitions.
;;;   
(defun bootstrap-meta-braid ()
  (let* ((std-class-size (length *std-class-slots*))
         (std-class (%allocate-instance--class std-class-size))
         (std-class-wrapper (make-wrapper std-class))
	 (built-in-class (%allocate-instance--class std-class-size))
	 (built-in-class-wrapper (make-wrapper built-in-class))
	 (direct-slotd    (%allocate-instance--class std-class-size))
	 (effective-slotd (%allocate-instance--class std-class-size))
	 (direct-slotd-wrapper    (make-wrapper direct-slotd))
	 (effective-slotd-wrapper (make-wrapper effective-slotd)))
    ;;
    ;; 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))
             (class (case name
                      (standard-class                     std-class)
                      (standard-direct-slot-definition    direct-slotd)
		      (standard-effective-slot-definition effective-slotd)
		      (built-in-class                     built-in-class)
                      (otherwise
			(%allocate-instance--class std-class-size)))))
	(unless (eq name t)
	  (inform-type-system-about-class class name))
	(setf (std-instance-wrapper class)
	      (ecase meta
		(standard-class std-class-wrapper)
		(built-in-class built-in-class-wrapper)))
        (setf (find-class name) class)))
    ;;
    ;;
    ;;
    (dolist (definition *early-class-definitions*)
      (let ((name (ecd-class-name 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 :default-initargs)))
	  (multiple-value-bind (slots cpl default-initargs direct-subclasses)
	      (early-collect-inheritance name)
	    (let* ((class (find-class name))
		   (wrapper
		     (cond
		       ((eq class std-class)       std-class-wrapper)
		       ((eq class direct-slotd)    direct-slotd-wrapper)
		       ((eq class effective-slotd) effective-slotd-wrapper)
		       ((eq class built-in-class)  built-in-class-wrapper)
		       (t (make-wrapper class))))
		   (proto nil))
	      (cond ((eq name 't)
		     (setq *the-wrapper-of-t* wrapper
			   *the-class-t* class))
		    ((memq name '(standard-object 
				  standard-class
				  standard-effective-slot-definition))
		     (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name))
				  *the-clos-package*)
			  class)))
	      (dolist (slot slots)
		(unless (eq (getf slot :allocation :instance) :instance)
		  (error "Slot allocation ~S not supported in bootstrap.")))
	      
	      (setf (wrapper-instance-slots-layout wrapper)
		    (mapcar #'canonical-slot-name slots))
	      (setf (wrapper-class-slots wrapper)
		    ())
	      
	      (setq proto (%allocate-instance--class (length slots)))
	      (setf (std-instance-wrapper proto) wrapper)
	    
	      (setq direct-slots
		    (bootstrap-make-slot-definitions name direct-slots
						     direct-slotd-wrapper nil))
	      (setq slots
		    (bootstrap-make-slot-definitions name slots
						     effective-slotd-wrapper t))
	      
	      (bootstrap-initialize-std-class
		class name source
		direct-supers direct-subclasses cpl wrapper
		direct-slots slots direct-default-initargs default-initargs
		proto)
	      
	      (dolist (slotd direct-slots)
		(bootstrap-accessor-definitions
		  name
		  (bootstrap-get-slot 'std-slotd slotd 'name)
		  (bootstrap-get-slot 'std-slotd slotd 'readers)
		  (bootstrap-get-slot 'std-slotd slotd 'writers))))))))))

(defun bootstrap-accessor-definitions (class-name slot-name readers writers)
  (flet ((do-reader-definition (reader)
	   (add-method
	     (ensure-generic-function reader)
	     (make-a-method
	       'standard-reader-method
	       ()
	       (list class-name)
	       (list class-name)
	       (make-std-reader-method-function slot-name)
	       "automatically generated reader method"
	       slot-name)))
	 (do-writer-definition (writer)
	   (add-method
	     (ensure-generic-function writer)
	     (make-a-method
	       'standard-writer-method
	       ()
	       (list 'new-value class-name)
	       (list 't class-name)
	       (make-std-writer-method-function slot-name)
	       "automatically generated writer method"
	       slot-name))))
    (dolist (reader readers) (do-reader-definition reader))
    (dolist (writer writers) (do-writer-definition writer))))

;;;
;;; Initialize a standard class metaobject.
;;;
(defun bootstrap-initialize-std-class
       (class
	name definition-source direct-supers direct-subclasses cpl wrapper
	direct-slots slots direct-default-initargs default-initargs proto)
  (flet ((classes (names) (mapcar #'find-class names))
	 (set-slot (slot-name value)
	   (bootstrap-set-slot 'std-class class slot-name value)))
    
    (set-slot 'name name)
    (set-slot 'source definition-source)
    (set-slot 'class-precedence-list (classes cpl))
    (set-slot 'direct-superclasses (classes direct-supers))
    (set-slot 'direct-slots direct-slots)
    (set-slot 'direct-subclasses (classes direct-subclasses))
    (set-slot 'direct-methods (cons nil nil))
    (set-slot 'no-of-instance-slots (length slots))
    (set-slot 'slots slots)
    (set-slot 'wrapper wrapper)
    (set-slot 'prototype proto)
    (set-slot 'plist
	      `(,@(and direct-default-initargs
		       `(direct-default-initargs ,direct-default-initargs))
		,@(and default-initargs
		       `(default-initargs ,default-initargs))))
    ))

;;;
;;; Initialize a built-in-class metaobject.
;;;
(defun bootstrap-initialize-bin-class
       (class
	name definition-source direct-supers direct-subclasses cpl wrapper)
  (flet ((classes (names) (mapcar #'find-class names))
	 (set-slot (slot-name value)
	   (bootstrap-set-slot 'bin-class class slot-name value)))
    
    (set-slot 'name name)
    (set-slot 'source definition-source)
    (set-slot 'direct-superclasses (classes direct-supers))
    (set-slot 'direct-subclasses (classes direct-subclasses))
    (set-slot 'direct-methods (cons nil nil))
    (set-slot 'class-precedence-list (classes cpl))
    (set-slot 'wrapper wrapper)))

(defun bootstrap-make-slot-definitions (name slots wrapper e-p)
  (mapcar #'(lambda (slot) (bootstrap-make-slot-definition name slot wrapper e-p))
          slots))

(defun bootstrap-make-slot-definition (name slot wrapper e-p)  
  (let ((slotd (%allocate-instance--class (length *std-slotd-slots*))))
    (setf (std-instance-wrapper slotd) wrapper)
    (flet ((get-val (name) (getf slot name))
	   (set-val (name val) (bootstrap-set-slot 'std-slotd slotd name val)))
      (set-val 'name         (get-val :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         (get-val :type))
      (set-val 'class        nil)
      (set-val 'instance-index nil)
      (when (and (eq name 'standard-class) (eq (get-val :name) 'slots) e-p)
	(setq *the-eslotd-standard-class-slots* slotd))
      slotd)))

(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))
	 (bin-class-size (length *bin-class-slots*)))
    (dolist (e *built-in-classes*)
      (let ((class (%allocate-instance--class bin-class-size)))
	(setf (std-instance-wrapper class) built-in-class-wrapper)
	(setf (find-class (car e)) class))))

  ;;
  ;; In the second pass, we initialize the class objects.
  ;;
  (dolist (e *built-in-classes*)
    (destructuring-bind (name supers subs cpl) e
      (let* ((class (find-class name))
	     (wrapper (make-wrapper class)))
	(set (get-built-in-class-symbol name) class)
	(set (get-built-in-wrapper-symbol name) wrapper)

	(setf (wrapper-instance-slots-layout wrapper) ()
	      (wrapper-class-slots wrapper) ())

	(bootstrap-initialize-bin-class class
					name nil
					supers subs
					(cons name cpl) wrapper)
	))))


;;;
;;;
;;;

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

(defun wrapper-of (x) 
  (or (and (std-instance-p x)
	   (std-instance-wrapper x))
      (and (fsc-instance-p x)
	   (fsc-instance-wrapper x))
      (built-in-wrapper-of x)
      (error "Can't determine wrapper of ~S" x)))


(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)))))
)

(defun built-in-wrapper-of (x)
  #.(make-built-in-wrapper-of-body))




(eval-when (load eval)
  (clrhash *find-class*)
  (bootstrap-meta-braid)
  (bootstrap-built-in-classes)
  (setq *boot-state* 'braid)
  (setf (symbol-function 'load-defclass) #'real-load-defclass)
  )


;;;
;;; All of these method definitions must appear here because the bootstrap
;;; only allows one method per generic function until the braid is fully
;;; built.
;;;
(defmethod print-object (instance stream)
  (printing-random-thing (instance stream)
    (let ((name (class-name (class-of instance))))
      (if name
	  (format stream "~S" name)
	  (format stream "Instance")))))

(defmethod print-object ((class class) stream)
  (named-object-print-function class stream))

(defmethod print-object ((slotd standard-slot-definition) stream)
  (named-object-print-function slotd stream))

(defun named-object-print-function (instance stream
				    &optional (extra nil extra-p))
  (printing-random-thing (instance stream)
    (if extra-p					
	(format stream "~A ~S ~:S"
		(capitalize-words (class-name (class-of instance)))
		(slot-value-or-default instance 'name)
		extra)
	(format stream "~A ~S"
		(capitalize-words (class-name (class-of instance)))
		(slot-value-or-default instance 'name)))))


;;;
;;;
;;;
;(defmethod shared-initialize :after ((class class) slot-names &key name)
;  (declare (ignore slot-names))
;  (setf (slot-value class 'name) name))
;
;
;(defmethod shared-initialize :after ((class std-class)
;				     slot-names
;				     &key direct-superclasses
;					  direct-slots)
; (declare (ignore slot-names))
; (setf (slot-value class 'direct-superclasses) direct-superclasses
;	(slot-value class 'direct-slots) direct-slots))

;;;
;;;
;;;
(defmethod shared-initialize :after ((slotd standard-slot-definition)
				     slot-names
				     &key class
					  name
					  initform
					  initfunction
					  initargs 
					  (allocation :instance)
					  (type t)
					  readers
					  writers)
  (declare (ignore slot-names))
  (setf (slot-value slotd 'name) name
	(slot-value slotd 'initform) initform
	(slot-value slotd 'initfunction) initfunction
	(slot-value slotd 'initargs) initargs 
	(slot-value slotd 'allocation) (if (eq allocation :class) class allocation)
	(slot-value slotd 'type) type
	(slot-value slotd 'readers) readers
	(slot-value slotd 'writers) writers))