;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: CLOS -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:

;;;;
;;;;  Copyright (c) 1992, Giuseppe Attardi.
;;;;
;;;;    See file 'LICENSE' for the copyright details.

(in-package "CLOS")

;;; ----------------------------------------------------------------------
;;; Methods

;;; ======================================================================
;;; Built-in classes
;;; ----------------------------------------------------------------------

(defmethod make-instance ((class built-in-class) &rest initargs)
  (declare (ignore initargs))
  (error "The built-in class (~A) cannot be instantiated" class))

;;;
;;; At this point we can activate the vector of builtin classes, which
;;; is used by class-of and other functions.
;;;
(si::*make-constant '+builtin-classes+ +builtin-classes-pre-array+)

(defmethod ensure-class-using-class ((class null) name &rest rest)
  (declare (ignore class))
  (multiple-value-bind (metaclass direct-superclasses options)
      (apply #'help-ensure-class rest)
    (declare (ignore direct-superclasses))
    (setf class (apply #'make-instance metaclass :name name options))
    (when name
      (si:create-type-name name)
      (setf (find-class name) class))))

(defmethod change-class ((instance t) (new-class symbol) &rest initargs)
  (apply #'change-class instance (find-class new-class) initargs))

(defmethod make-instances-obsolete ((class symbol))
  (make-instances-obsolete (find-class class))
  class)

(defmethod make-instance ((class-name symbol) &rest initargs)
  (apply #'make-instance (find-class class-name) initargs))

(defmethod slot-makunbound-using-class ((class built-in-class) self slotd)
  (declare (ignore class self slotd))
  (error "SLOT-MAKUNBOUND-USING-CLASS cannot be applied on built-in objects"))

(defmethod slot-boundp-using-class ((class built-in-class) self slotd)
  (declare (ignore class self slotd))
  (error "SLOT-BOUNDP-USING-CLASS cannot be applied on built-in objects"))

(defmethod slot-value-using-class ((class built-in-class) self slotd)
  (declare (ignore class self slotd))
  (error "SLOT-VALUE-USING-CLASS cannot be applied on built-in objects"))

(defmethod (setf slot-value-using-class) (val (class built-in-class) self slotd)
  (declare (ignore class self slotd val))
  (error "SLOT-VALUE-USING-CLASS cannot be applied on built-in objects"))

(defmethod slot-exists-p-using-class ((class built-in-class) self slotd)
  (declare (ignore class self slotd))
  nil)

;;; ======================================================================
;;; STRUCTURES
;;;

;;; structure-classes cannot be instantiated
(defmethod allocate-instance ((class structure-class) &rest initargs)
  (declare (ignore initargs))
  (apply #'si::make-structure class
         (make-list (class-size class) :initial-element nil)))

(defmethod finalize-inheritance ((class structure-class))
  (when (class-finalized-p class)
    (return-from finalize-inheritance))
  (call-next-method)
  (dolist (slot (class-slots class))
    (unless (eq :INSTANCE (slot-definition-allocation slot))
      (error "The structure class ~S can't have shared slots" (class-name class)))))

(defmethod make-load-form ((object structure-object) &optional environment)
  (make-load-form-saving-slots object :key environment))

(defmethod print-object ((obj structure-object) stream)
  (let* ((class (si:instance-class obj))
         (slotds (class-slots class)))
    (declare (:read-only class))
    (when (and ;; *p-readably* effectively disables *p-level*
               (not *print-readably*)
               *print-level*
               (zerop *print-level*))
      (write-string "#" stream)
      (return-from print-object obj))
    (write-string "#S(" stream)
    (prin1 (class-name class) stream)
    (let ((*print-level* (if (and *print-level* (>= *print-level* 1))
                             (1- *print-level*)
                             *print-level*)))
      (do ((scan slotds (cdr scan))
           (i 0 (1+ i))
           (limit (or *print-length* most-positive-fixnum))
           (sv))
          ((null scan))
        (declare (fixnum i))
        (when (>= i limit)
          (write-string " ..." stream)
          (return))
        (setq sv (si:instance-ref obj i))
        (write-string " " stream)
        ;; 2.4.8.13 Sharpsign S: slots are keywords
        (prin1 (intern (symbol-name (slot-definition-name (car scan)))
                       (find-package 'keyword))
               stream)
        (write-string " " stream)
        (prin1 sv stream)))
    (write-string ")" stream)
    obj))