262 lines
12 KiB
Common Lisp
262 lines
12 KiB
Common Lisp
;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
|
|
|
|
|
|
;;;. Copyright (c) 1991 by Venue
|
|
|
|
(in-package "CLOS")
|
|
|
|
;;; These four functions work on std-instances and fsc-instances. These are instances for which it
|
|
;;; is possible to change the wrapper and the slots. For these kinds of instances, most specified
|
|
;;; methods from the instance structure protocol are promoted to the implementation-specific class
|
|
;;; std-class. Many of these methods call these four functions.
|
|
|
|
|
|
(defun get-wrapper (inst)
|
|
(cond ((std-instance-p inst)
|
|
(std-instance-wrapper inst))
|
|
((fsc-instance-p inst)
|
|
(fsc-instance-wrapper inst))
|
|
(t (error "What kind of instance is this?"))))
|
|
|
|
(defun get-slots (inst)
|
|
(cond ((std-instance-p inst)
|
|
(std-instance-slots inst))
|
|
((fsc-instance-p inst)
|
|
(fsc-instance-slots inst))
|
|
(t (error "What kind of instance is this?"))))
|
|
|
|
(defun set-wrapper (inst new)
|
|
(cond ((std-instance-p inst)
|
|
(setf (std-instance-wrapper inst)
|
|
new))
|
|
((fsc-instance-p inst)
|
|
(setf (fsc-instance-wrapper inst)
|
|
new))
|
|
(t (error "What kind of instance is this?"))))
|
|
|
|
(defun set-slots (inst new)
|
|
(cond ((std-instance-p inst)
|
|
(setf (std-instance-slots inst)
|
|
new))
|
|
((fsc-instance-p inst)
|
|
(setf (fsc-instance-slots inst)
|
|
new))
|
|
(t (error "What kind of instance is this?"))))
|
|
|
|
(defmacro get-slot-value-2 (instance wrapper slot-name slots index)
|
|
`(let ((val (%svref ,slots ,index)))
|
|
(if (eq val ',*slot-unbound*)
|
|
(slot-unbound (wrapper-class ,wrapper)
|
|
,instance
|
|
,slot-name)
|
|
val)))
|
|
|
|
(defmacro set-slot-value-2 (nv instance wrapper slot-name slots index)
|
|
(declare (ignore instance wrapper slot-name))
|
|
`(setf (%svref ,slots ,index)
|
|
,nv))
|
|
|
|
(defun get-class-slot-value-1 (object wrapper slot-name)
|
|
(let ((entry (assq slot-name (wrapper-class-slots wrapper))))
|
|
(if (null entry)
|
|
(slot-missing (wrapper-class wrapper)
|
|
object slot-name 'slot-value)
|
|
(if (eq (cdr entry)
|
|
*slot-unbound*)
|
|
(slot-unbound (wrapper-class wrapper)
|
|
object slot-name)
|
|
(cdr entry)))))
|
|
|
|
(defun set-class-slot-value-1 (new-value object wrapper slot-name)
|
|
(let ((entry (assq slot-name (wrapper-class-slots wrapper))))
|
|
(if (null entry)
|
|
(slot-missing (wrapper-class wrapper)
|
|
object slot-name 'setf new-value)
|
|
(setf (cdr entry)
|
|
new-value))))
|
|
|
|
(defmethod class-slot-value ((class std-class)
|
|
slot-name)
|
|
(let ((wrapper (class-wrapper class))
|
|
(prototype (class-prototype class)))
|
|
(get-class-slot-value-1 prototype wrapper slot-name)))
|
|
|
|
(defmethod (setf class-slot-value)
|
|
(nv (class std-class)
|
|
slot-name)
|
|
(let ((wrapper (class-wrapper class))
|
|
(prototype (class-prototype class)))
|
|
(set-class-slot-value-1 nv prototype wrapper slot-name)))
|
|
|
|
(defmethod find-slot-definition ((class std-class)
|
|
slot-name)
|
|
(if (and (eq class *the-class-standard-class*)
|
|
(eq slot-name 'slots))
|
|
*the-eslotd-standard-class-slots*
|
|
(progn (unless (class-finalized-p class)
|
|
(finalize-inheritance class))
|
|
(dolist (eslotd (class-slots class))
|
|
(when (eq (slotd-name eslotd)
|
|
slot-name)
|
|
(return eslotd))))))
|
|
|
|
(defun slot-value (object slot-name)
|
|
(let ((class (class-of object)))
|
|
(if (eq class *the-class-standard-effective-slot-definition*)
|
|
(let* ((wrapper (check-wrapper-validity object))
|
|
(slots (get-slots object))
|
|
(index (instance-slot-index wrapper slot-name)))
|
|
(if index
|
|
(get-slot-value-2 object wrapper slot-name slots index)
|
|
(get-class-slot-value-1 object wrapper slot-name)))
|
|
(let ((slot-definition (find-slot-definition class slot-name)))
|
|
(if (null slot-definition)
|
|
(slot-missing class object slot-name 'slot-value)
|
|
(slot-value-using-class class object slot-definition))))))
|
|
|
|
(defun set-slot-value (object slot-name new-value)
|
|
(let ((class (class-of object)))
|
|
(if (eq class *the-class-standard-effective-slot-definition*)
|
|
(let* ((wrapper (check-wrapper-validity object))
|
|
(slots (get-slots object))
|
|
(index (instance-slot-index wrapper slot-name)))
|
|
(if index
|
|
(set-slot-value-2 new-value object wrapper slot-name slots index)
|
|
(set-class-slot-value-1 new-value object wrapper slot-name)))
|
|
(let ((slot-definition (find-slot-definition class slot-name)))
|
|
(if (null slot-definition)
|
|
(slot-missing class object slot-name 'setf)
|
|
(setf (slot-value-using-class class object slot-definition)
|
|
new-value))))))
|
|
|
|
(defun slot-boundp (object slot-name)
|
|
(let* ((class (class-of object))
|
|
(slot-definition (find-slot-definition class slot-name)))
|
|
(if (null slot-definition)
|
|
(slot-missing class object slot-name 'slot-boundp)
|
|
(slot-boundp-using-class class object slot-definition))))
|
|
|
|
(defun slot-makunbound (object slot-name)
|
|
(let* ((class (class-of object))
|
|
(slot-definition (find-slot-definition class slot-name)))
|
|
(if (null slot-definition)
|
|
(slot-missing class object slot-name 'slot-makunbound)
|
|
(slot-makunbound-using-class class object slot-definition))))
|
|
|
|
(defun slot-exists-p (object slot-name)
|
|
(let* ((class (class-of object))
|
|
(slot-definition (find-slot-definition class slot-name)))
|
|
(and slot-definition (slot-exists-p-using-class class object slot-definition))))
|
|
|
|
|
|
;;; This isn't documented, but is used within CLOS in a number of print object methods (see
|
|
;;; named-object-print-function).
|
|
|
|
|
|
(defun slot-value-or-default (object slot-name &optional (default "unbound"))
|
|
(if (slot-boundp object slot-name)
|
|
(slot-value object slot-name)
|
|
default))
|
|
|
|
|
|
;;;
|
|
|
|
|
|
(defmethod slot-value-using-class ((class std-class)
|
|
(object standard-object)
|
|
(slotd standard-effective-slot-definition))
|
|
(let* ((wrapper (check-wrapper-validity object))
|
|
; trap if need be
|
|
(slots (get-slots object))
|
|
(slot-name (slotd-name slotd))
|
|
(index (or (slotd-instance-index slotd)
|
|
(setf (slotd-instance-index slotd)
|
|
(instance-slot-index wrapper slot-name)))))
|
|
(if index
|
|
(get-slot-value-2 object wrapper slot-name slots index)
|
|
(get-class-slot-value-1 object wrapper slot-name))))
|
|
|
|
(defmethod (setf slot-value-using-class)
|
|
(new-value (class std-class)
|
|
(object standard-object)
|
|
(slotd standard-effective-slot-definition))
|
|
(let* ((wrapper (check-wrapper-validity object))
|
|
; trap if need be
|
|
(slots (get-slots object))
|
|
(slot-name (slotd-name slotd))
|
|
(index (or (slotd-instance-index slotd)
|
|
(setf (slotd-instance-index slotd)
|
|
(instance-slot-index wrapper slot-name)))))
|
|
(if index
|
|
(set-slot-value-2 new-value object wrapper slot-name slots index)
|
|
(set-class-slot-value-1 new-value object wrapper slot-name))))
|
|
|
|
(defmethod slot-boundp-using-class ((class std-class)
|
|
(object standard-object)
|
|
(slotd standard-effective-slot-definition))
|
|
(let* ((wrapper (check-wrapper-validity object))
|
|
; trap if need be
|
|
(slots (get-slots object))
|
|
(slot-name (slotd-name slotd))
|
|
(index (or (slotd-instance-index slotd)
|
|
(setf (slotd-instance-index slotd)
|
|
(instance-slot-index wrapper slot-name)))))
|
|
(if index
|
|
(neq (svref slots index)
|
|
*slot-unbound*)
|
|
(let ((entry (assq slot-name (wrapper-class-slots wrapper))))
|
|
(if (null entry)
|
|
(slot-missing class object slot-name 'slot-boundp)
|
|
(neq (cdr entry)
|
|
*slot-unbound*))))))
|
|
|
|
(defmethod slot-makunbound-using-class ((class std-class)
|
|
(object standard-object)
|
|
(slotd standard-effective-slot-definition))
|
|
(let* ((wrapper (check-wrapper-validity object))
|
|
; trap if need be
|
|
(slots (get-slots object))
|
|
(slot-name (slotd-name slotd))
|
|
(index (or (slotd-instance-index slotd)
|
|
(setf (slotd-instance-index slotd)
|
|
(instance-slot-index wrapper slot-name)))))
|
|
(cond (index (setf (%svref slots index)
|
|
*slot-unbound*)
|
|
object)
|
|
(t (let ((entry (assq slot-name (wrapper-class-slots wrapper))))
|
|
(if* (null entry)
|
|
(slot-missing class object slot-name 'slot-makunbound)
|
|
(setf (cdr entry)
|
|
*slot-unbound*)
|
|
object))))))
|
|
|
|
(defmethod slot-exists-p-using-class ((class std-class)
|
|
(object standard-object)
|
|
(slotd standard-effective-slot-definition))
|
|
t)
|
|
|
|
(defmethod slot-missing ((class t)
|
|
instance slot-name operation &optional new-value)
|
|
(error "When attempting to ~A,~%the slot ~S is missing from the object ~S."
|
|
(ecase operation
|
|
(slot-value "read the slot's value (slot-value)")
|
|
(setf (format nil "set the slot's value to ~S (setf of slot-value)" new-value))
|
|
(slot-boundp "test to see if slot is bound (slot-boundp)")
|
|
(slot-makunbound "make the slot unbound (slot-makunbound)"))
|
|
slot-name instance))
|
|
|
|
(defmethod slot-unbound ((class t)
|
|
instance slot-name)
|
|
(error "The slot ~S is unbound in the object ~S." slot-name instance))
|
|
|
|
(defmethod allocate-instance ((class standard-class)
|
|
&rest initargs)
|
|
(declare (ignore initargs))
|
|
(unless (class-finalized-p class)
|
|
(finalize-inheritance class))
|
|
(let* ((class-wrapper (class-wrapper class))
|
|
(instance (%allocate-instance--class (class-no-of-instance-slots class))))
|
|
(setf (std-instance-wrapper instance)
|
|
class-wrapper)
|
|
instance))
|