mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2025-12-05 18:30:24 -08:00
122 lines
4.5 KiB
Common Lisp
122 lines
4.5 KiB
Common Lisp
;;;; -*- 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))
|