;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987 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 Artifical Intelligence Systems
;;;   2400 Hanover St.
;;;   Palo Alto, CA 94303
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
;;; The meta-braid.

(in-package 'pcl)

(eval-when (compile load eval)

(defun early-collect-inheritance (class-name)
  (declare (values slots cpl direct-subclasses))
  (multiple-value-bind (slots cpl)
      (early-collect-inheritance-1 class-name)
    (values slots
            cpl 
            (iterate ((defclass in *early-defclass-forms*))
              (when (memq class-name (caddr defclass))
                (collect (cadr defclass)))))))

(defun early-collect-inheritance-1 (class-name)
  (let ((defclass (find class-name *early-defclass-forms* :key #'cadr)))
    (unless defclass
      (error "~S is not a class in *early-defclass-forms*." class-name))
    (destructuring-bind (includes slots . options) (cddr defclass)
      (when options
        (error "options not supported in *early-defclass-forms*."))
      (when (cdr includes)
        (error "multiple supers not allowed in *early-defclass-forms*."))
      (if includes
          (multiple-value-bind (super-slots super-cpl)
              (early-collect-inheritance-1 (car includes))
            (values (append super-slots slots)
                    (cons class-name super-cpl)))
          (values slots
                  (list class-name))))))

(defvar *std-class-slots* (early-collect-inheritance 'class))

(defvar *std-slotd-slots* (early-collect-inheritance 'standard-slotd))

(defconstant class-instance-slots-position
             (position 'instance-slots *std-class-slots* :key #'car))

(defconstant slotd-name-position
             (position 'name *std-slotd-slots* :key #'car))

);eval-when


;;; CLASS-INSTANCE-SLOTS and SLOTD-NAME have to be defined specially!
;;;
;;; They cannot be defined using slot-value-using-class like all the other
;;; accessors are.  This is because slot-value-using-class itself must call
;;; CLASS-INSTANCE-SLOTS and SLOTD-NAME to do the slot access.
;;;
;;; This 'bottoming out' of the run-time slot-access code will be replaced
;;; by a corresponding bootstrapping constraint when permutation vectors
;;; happen.
;;;
;;; The defsetfs for these set-xxx functions are in defs.
;;; 
(defun class-instance-slots (class)
  (get-static-slot--class class
                          (%convert-slotd-position-to-slot-index
                            class-instance-slots-position)))

(defun set-class-instance-slots (class new-value)
  (setf (get-static-slot--class class
                                (%convert-slotd-position-to-slot-index
                                  class-instance-slots-position))
        new-value))

(defun slotd-name (slotd)
  (get-static-slot--class slotd
                          (%convert-slotd-position-to-slot-index
                            slotd-name-position)))

(defun set-slotd-name (slotd new-value)
  (setf (get-static-slot--class slotd
                                (%convert-slotd-position-to-slot-index
                                  slotd-name-position))
        new-value))



;;;
;;; 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.
;;; 
(defun bootstrap-get-slot (type object slot-name)
  (get-static-slot--class object (bootstrap-slot-index type slot-name)))

(defun bootstrap-set-slot (type object slot-name new-value)
  (setf (get-static-slot--class object (bootstrap-slot-index type slot-name))
        new-value))

(defun bootstrap-slot-index (type slot-name)
  (let ((position 0)
        (slots (ecase type
                 (class *std-class-slots*)
                 (slotd *std-slotd-slots*))))
    ;; This loop is a hand coded version of:
    ;; 
    ;;   (setq position (position slot-name slots :key #'car))
    ;;   
    (loop (cond ((eq (caar slots) slot-name) (return t))
                ((null slots) (error "~S not found" slot-name))
                (t (pop slots) (incf position))))
    (%convert-slotd-position-to-slot-index position)))


;;;
;;; bootstrap-meta-braid
;;;   
(defun bootstrap-meta-braid ()
  (let* ((std-class-size (length *std-class-slots*))
         (std-class (%allocate-instance--class std-class-size))
         (std-class-wrapper (make-class-wrapper std-class))
         (std-slotd (%allocate-instance--class std-class-size))
         (std-slotd-wrapper (make-class-wrapper std-slotd)))
    ;;
    ;; First, make a class object for each of the early classes.
    ;; 
    (dolist (early-defclass *early-defclass-forms*)
      (let* ((name (cadr early-defclass))
             (class (case name
                      (class std-class)
                      (standard-slotd std-slotd)
                      (otherwise
                        (%allocate-instance--class std-class-size)))))
        (setf (iwmc-class-class-wrapper class) std-class-wrapper)
        (setf (class-named name) class)))

    ;;
    ;; Now go back and initialize those classes.
    ;; 
    (dolist (early-defclass *early-defclass-forms*)      
      (multiple-value-bind (instance-slots cpl direct-subclasses)
          (early-collect-inheritance (cadr early-defclass))
        (let* ((name (cadr early-defclass))
               (includes (caddr early-defclass))
               (local-slots (cadddr early-defclass))
               (class (class-named name))
               (wrapper (if (eq class std-class)
                            std-class-wrapper
                            (make-class-wrapper class)))
               (proto nil))
          
          (setq proto (%allocate-instance--class (length instance-slots)))
          (setf (iwmc-class-class-wrapper proto) wrapper)

          (setq local-slots (bootstrap-parse-slots local-slots
                                                   std-slotd-wrapper))
          (setq instance-slots (bootstrap-parse-slots instance-slots
						      std-slotd-wrapper))

          (bootstrap-initialize class name includes local-slots
                                instance-slots cpl direct-subclasses
                                wrapper proto)
	  (unless (eq name 't)
	    (inform-type-system-about-class class name))

          (dolist (slotd local-slots)
            (bootstrap-accessor-definitions
              name
              (slotd-name slotd)
              (bootstrap-get-slot 'slotd slotd 'accessors)
              (bootstrap-get-slot 'slotd slotd 'readers))))))))

(defun bootstrap-accessor-definitions (class-name slot-name accessors readers)
  (let ((reader-constructor
	  (get-templated-function-constructor 'reader-function--std-class))
	(writer-constructor
	  (get-templated-function-constructor 'writer-function--std-class
					      nil)))
    (flet ((do-reader-definition (accessor)
	     (add-method
	       (ensure-generic-function accessor)
	       (make-a-method 'standard-reader-method
			      ()
			      (list class-name)
			      (list class-name)
			      (funcall reader-constructor slot-name)
			      "automatically generated reader method"
			      slot-name)))
	   (do-writer-definition (accessor)
	     (add-method
	       (ensure-generic-function `(SETF ,accessor))
	       (make-a-method 'standard-writer-method
			      ()
			      (list class-name 'new-value)
			      (list class-name 'T)
			      (funcall writer-constructor slot-name t)
			      "automatically generated writer method"
			      slot-name))))
      (dolist (accessor accessors)
	(do-reader-definition accessor)
	(do-writer-definition accessor))
      (dolist (reader readers)
	(do-reader-definition reader)))))
          
(defun bootstrap-initialize
       (c name includes local-slots slots cpl subs wrapper proto)
  (flet ((classes (names) (mapcar #'class-named names)))
    (bootstrap-set-slot 'class c 'name name)
    (bootstrap-set-slot 'class c 'class-precedence-list (classes cpl))
    (bootstrap-set-slot 'class c 'local-supers (classes includes))
    (bootstrap-set-slot 'class c 'local-slots local-slots)
    (bootstrap-set-slot 'class c 'direct-subclasses (classes subs))
    (bootstrap-set-slot 'class c 'direct-methods ())
    (bootstrap-set-slot 'class c 'no-of-instance-slots (length slots))
    (bootstrap-set-slot 'class c 'instance-slots slots)
    (bootstrap-set-slot 'class c 'non-instance-slots ())
    (bootstrap-set-slot 'class c 'wrapper wrapper)
    (bootstrap-set-slot 'class c 'direct-generic-functions ())
    (bootstrap-set-slot 'class c 'generic-functions-which-combine-methods ())
    (bootstrap-set-slot 'class c 'prototype proto)))

(defun bootstrap-parse-slots (slots std-slotd-wrapper)
  (mapcar #'(lambda (slot) (bootstrap-parse-slot slot std-slotd-wrapper))
          slots))

(defun bootstrap-parse-slot (slot std-slotd-wrapper)
  (let ((slotd (%allocate-instance--class (length *std-slotd-slots*))))
    (setf (iwmc-class-class-wrapper slotd) std-slotd-wrapper)
    (let ((name (pop slot))
          (initform nil)
          (accessors ())
	  (readers ())
          (type 't))
      (loop (when (null slot) (return t))
            (ecase (car slot)
              (:initform (setq initform (cadr slot)))
              (:accessor (push (cadr slot) accessors))
              (:reader   (push (cadr slot) readers))
              (:type (setq type (cadr slot))))
            (setq slot (cddr slot)))
      (bootstrap-set-slot 'slotd slotd 'name name)
      (bootstrap-set-slot 'slotd slotd 'keyword (make-keyword name))
      (bootstrap-set-slot 'slotd slotd 'accessors accessors)
      (bootstrap-set-slot 'slotd slotd 'readers readers)
      (bootstrap-set-slot 'slotd slotd 'allocation ':instance)
      (bootstrap-set-slot 'slotd slotd 'type type)
      slotd)))

(eval-when (eval load)
  (clrhash *class-name-hash-table*)
  (bootstrap-meta-braid)
  (precompile-class-of))


;;;
;;;
;;;
(defmethod print-object ((instance object) stream depth)
  (declare (ignore depth))
  (printing-random-thing (instance stream)
    (format stream "Standard-Instance")))

;(defmethod print-object ((instance object) stream depth)
;  (let ((length (if (numberp *print-length*) (* *print-length* 2) nil)))
;    (format stream "#S(~S" (class-name (class-of instance)))
;    (iterate ((slot-or-value in (all-slots instance))
;	      (slotp = t (not slotp)))
;      (when (numberp length)
;	(cond ((<= length 0) (format stream " ...") (return ()))
;	      (t (decf length))))
;      (princ " " stream)
;      (let ((*print-level* (cond ((null *print-level*) ())
;				 (slotp 1)
;				 (t (- *print-level* depth)))))
;	(if (and *print-level* (<= *print-level* 0))
;	    (princ "#" stream)
;	    (prin1 slot-or-value stream))))
;    (princ ")" stream)))

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

(defmethod print-object ((slotd standard-slotd) stream depth)
  (named-object-print-function slotd stream depth))