mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-02 15:40:55 -08:00
Slot accessors go now through slot definition objects.
This commit is contained in:
jjgarcia
parent
a2fc3fc878
commit
d41d4544e8
8 changed files with 163 additions and 194 deletions
|
|
@ -79,6 +79,15 @@ ECL 0.9i
|
|||
|
||||
- New manual file for 'ecl-config' contributed by Peter Van Eynde.
|
||||
|
||||
* MOP compatibility:
|
||||
|
||||
- SLOT-VALUE, SLOT-BOUNDP, etc, together with MOP SLOT*-USING-CLASS generic
|
||||
functions now rely entirely on slot-definition objects.
|
||||
|
||||
- Effective slot definitions now have a "location" slot. Around methods for
|
||||
COMPUTE-SLOTS assign a location to each slot definition that has allocation
|
||||
:INSTANCE or :CLASS.
|
||||
|
||||
* Errors fixed:
|
||||
|
||||
- The intermediate output of the compiler is written in the directory in which
|
||||
|
|
|
|||
|
|
@ -12,9 +12,8 @@
|
|||
;;; ----------------------------------------------------------------------
|
||||
;;; Building the classes T, CLASS, STANDARD-OBJECT and STANDARD-CLASS.
|
||||
;;;
|
||||
;;; We cannot use the functions CREATE-STANDARD-CLASS and others because
|
||||
;;; SLOT-INDEX-TABLE, SLOTS, DIRECT-SLOTS, etc are empty and therefore
|
||||
;;; SLOT-VALUE does not work.
|
||||
;;; We cannot use the functions CREATE-STANDARD-CLASS and others because SLOTS,
|
||||
;;; DIRECT-SLOTS, etc are empty and therefore SLOT-VALUE does not work.
|
||||
|
||||
(defun make-empty-standard-class (name metaclass)
|
||||
(let ((class (si:allocate-raw-instance nil metaclass #.(length +standard-class-slots+))))
|
||||
|
|
@ -31,8 +30,7 @@
|
|||
(class-finalized-p class) t
|
||||
(find-class name) class)
|
||||
(unless (eq name 'T)
|
||||
(setf (slot-index-table class) (make-hash-table :size 2)
|
||||
(class-shared-slots class) nil))
|
||||
(setf (slot-table class) (make-hash-table :size 2)))
|
||||
class))
|
||||
|
||||
;; 1) Create the classes
|
||||
|
|
@ -59,12 +57,17 @@
|
|||
(do* ((i 0 (1+ i))
|
||||
(slots standard-slots (cdr slots)))
|
||||
((endp slots))
|
||||
(setf (gethash (caar slots) hash-table) i))
|
||||
(let ((slotd (first slots)))
|
||||
(setf (slot-definition-location slotd) i)
|
||||
(setf (gethash (slot-definition-name slotd) hash-table) slotd)))
|
||||
(dolist (slotd class-slots)
|
||||
(setf (slot-definition-location slotd)
|
||||
(slot-definition-location (gethash (slot-definition-name slotd) hash-table))))
|
||||
(setf (class-slots the-class) class-slots
|
||||
(slot-index-table the-class) hash-table
|
||||
(slot-table the-class) hash-table
|
||||
(class-direct-slots the-class) class-slots
|
||||
(class-slots standard-class) standard-slots
|
||||
(slot-index-table standard-class) hash-table
|
||||
(slot-table standard-class) hash-table
|
||||
(class-direct-slots standard-class) (set-difference standard-slots class-slots))
|
||||
|
||||
;; 3) Fix the class hierarchy
|
||||
|
|
@ -91,6 +94,8 @@
|
|||
;; 5) Generate accessors (In macros.lsp)
|
||||
)
|
||||
|
||||
(defconstant +the-standard-class+ (find-class 'standard nil))
|
||||
|
||||
(defmethod class-prototype ((class class))
|
||||
(unless (slot-boundp class 'prototype)
|
||||
(setf (slot-value class 'prototype) (allocate-instance class)))
|
||||
|
|
@ -103,62 +108,104 @@
|
|||
;;; 1) Functional interface
|
||||
;;;
|
||||
|
||||
(defun find-slot-definition (class slot-name)
|
||||
(declare (si::c-local))
|
||||
(if (eq (si:instance-class class) +the-standard-class+)
|
||||
(gethash (class-slot-table class) slot-name nil)
|
||||
(find slot-name (class-slots class) :key #'slot-definition-name)))
|
||||
|
||||
(defun slot-value (self slot-name)
|
||||
(slot-value-using-class (class-of self) self slot-name))
|
||||
(let* ((class (class-of self))
|
||||
(slotd (find-slot-definition class slot-name)))
|
||||
(if slotd
|
||||
(slot-value-using-class class self slotd)
|
||||
(values (slot-missing class self slot-name 'SLOT-VALUE)))))
|
||||
|
||||
(defun slot-boundp (self slot-name)
|
||||
(slot-boundp-using-class (class-of self) self slot-name))
|
||||
(let* ((class (class-of self))
|
||||
(slotd (find-slot-definition class slot-name)))
|
||||
(if slotd
|
||||
(slot-boundp-using-class class self slotd)
|
||||
(values (slot-missing class self slot-name 'SLOT-BOUNDP)))))
|
||||
|
||||
(defun (setf slot-value) (value self slot-name)
|
||||
(funcall #'(setf slot-value-using-class) value (class-of self) self slot-name))
|
||||
(let* ((class (class-of self))
|
||||
(slotd (find-slot-definition class slot-name)))
|
||||
(if slotd
|
||||
(funcall #'(setf slot-value-using-class) value class self slotd)
|
||||
(slot-missing class self slot-name 'SETF value))
|
||||
value))
|
||||
|
||||
(defun slot-makunbound (self slot-name)
|
||||
(slot-makunbound-using-class (class-of self) self slot-name))
|
||||
(let* ((class (class-of self))
|
||||
(slotd (find-slot-definition class slot-name)))
|
||||
(if slotd
|
||||
(slot-makunbound-using-class class self slotd)
|
||||
(slot-missing class self slot-name 'SLOT-MAKUNBOUND))
|
||||
self))
|
||||
|
||||
(defun slot-exists-p (self slot-name)
|
||||
(slot-exists-p-using-class (class-of self) self slot-name))
|
||||
(and (find-slot-definition (class-of self) slot-name)
|
||||
t))
|
||||
|
||||
;;;
|
||||
;;; 2) Overloadable methods on which the previous functions are based
|
||||
;;;
|
||||
|
||||
(defmethod slot-value-using-class ((class class) self slot-name)
|
||||
(ensure-up-to-date-instance self)
|
||||
(let* ((index (position slot-name (class-slots class)
|
||||
:key #'slot-definition-name :test #'eq)))
|
||||
(values
|
||||
(if index
|
||||
(let ((val (si:instance-ref self (the fixnum index))))
|
||||
(if (si:sl-boundp val)
|
||||
val
|
||||
(slot-unbound (si::instance-class class) class slot-name)))
|
||||
(slot-missing (si:instance-class class) class slot-name
|
||||
'SLOT-VALUE)))))
|
||||
(defun standard-instance-get (instance slotd)
|
||||
(ensure-up-to-date-instance instance)
|
||||
(let* ((class (si:instance-class instance))
|
||||
(location (slot-definition-location slotd)))
|
||||
(cond ((si:fixnump location)
|
||||
;; local slot
|
||||
(si:instance-ref instance (the fixnum location)))
|
||||
((consp location)
|
||||
;; shared slot
|
||||
(car location))
|
||||
(t
|
||||
(error "Effective slot definition lacks a valid location:~%~A"
|
||||
slotd)))))
|
||||
|
||||
(defmethod slot-boundp-using-class ((class class) self slot-name)
|
||||
(ensure-up-to-date-instance self)
|
||||
(let* ((index (position slot-name (class-slots class)
|
||||
:key #'slot-definition-name :test #'eq)))
|
||||
(values
|
||||
(if index
|
||||
(si:sl-boundp (si:instance-ref self (the fixnum index)))
|
||||
(slot-missing (si:instance-class class) class slot-name
|
||||
'SLOT-BOUNDP)))))
|
||||
(defun standard-instance-set (val instance slotd)
|
||||
(ensure-up-to-date-instance instance)
|
||||
(let* ((class (si:instance-class instance))
|
||||
(location (slot-definition-location slotd)))
|
||||
(cond ((si:fixnump location)
|
||||
;; local slot
|
||||
(si:instance-set instance (the fixnum location) val))
|
||||
((consp location)
|
||||
;; shared slot
|
||||
(setf (car location) val))
|
||||
(t
|
||||
(error "Effective slot definition lacks a valid location:~%~A"
|
||||
slotd)))
|
||||
val))
|
||||
|
||||
(defmethod (setf slot-value-using-class) (val (class class) self slot-name)
|
||||
(ensure-up-to-date-instance self)
|
||||
(let* ((index (position slot-name (class-slots class)
|
||||
:key #'slot-definition-name :test #'eq)))
|
||||
(if index
|
||||
(si:instance-set self (the fixnum index) val)
|
||||
(slot-missing (si:instance-class self) self slot-name
|
||||
'SETF val)))
|
||||
val)
|
||||
(defmethod slot-value-using-class ((class class) self slotd)
|
||||
(let ((value (standard-instance-get self slotd)))
|
||||
(if (si:sl-boundp value)
|
||||
value
|
||||
(values (slot-unbound class self (slot-definition-name slotd))))))
|
||||
|
||||
(defmethod slot-exists-p-using-class ((class class) self slot-name)
|
||||
(ensure-up-to-date-instance self)
|
||||
(and (position slot-name (class-slots class) :key #'slot-definition-name :test #'eq)
|
||||
t))
|
||||
(defmethod slot-boundp-using-class ((class class) self slotd)
|
||||
(si::sl-boundp (standard-instance-get self slotd)))
|
||||
|
||||
(defmethod (setf slot-value-using-class) (val (class class) self slotd)
|
||||
(standard-instance-set val self slotd))
|
||||
|
||||
(defmethod slot-makunbound-using-class ((class class) instance slotd)
|
||||
(ensure-up-to-date-instance instance)
|
||||
(let* ((location (slot-definition-location slotd)))
|
||||
(cond ((si:fixnump location)
|
||||
;; local slot
|
||||
(si:sl-makunbound instance (the fixnum location)))
|
||||
((consp location)
|
||||
;; shared slot
|
||||
(setf (car location) (unbound)))
|
||||
(t
|
||||
(error "Effective slot definition lacks a valid location:~%~A"
|
||||
slotd))))
|
||||
instance)
|
||||
|
||||
;;;
|
||||
;;; 3) Error messages related to slot access
|
||||
|
|
|
|||
|
|
@ -102,19 +102,19 @@
|
|||
(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 slot-name)
|
||||
(defmethod slot-makunbound-using-class ((class built-in-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 slot-name)
|
||||
(defmethod slot-boundp-using-class ((class built-in-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 slot-name)
|
||||
(defmethod slot-value-using-class ((class built-in-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 slot-name)
|
||||
(defmethod (setf slot-value-using-class) (val (class built-in-class) self slotd)
|
||||
(error "SLOT-VALUE-USING-CLASS cannot be applied on built-in objects"))
|
||||
|
||||
(defmethod slot-exists-p-using-class ((class built-in-class) self slot-name)
|
||||
(defmethod slot-exists-p-using-class ((class built-in-class) self slotd)
|
||||
nil)
|
||||
|
||||
;;; ======================================================================
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@
|
|||
|#
|
||||
|
||||
(defun convert-one-class (class)
|
||||
(dolist (l (class-slots class))
|
||||
(dolist (l (class-direct-slots class))
|
||||
(let ((x (first l)))
|
||||
(when (consp x)
|
||||
(setf (first l)
|
||||
|
|
@ -219,24 +219,3 @@ their lambda lists ~A and ~A are not congruent."
|
|||
(t (error "~A is not a class." new-value))))
|
||||
new-value)
|
||||
)
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; Slot accessors
|
||||
;;;
|
||||
|
||||
(defmethod slot-value-using-class ((class standard-class) instance
|
||||
(slot standard-effective-slot-definition))
|
||||
(slot-value-using-class class instance (slot-definition-name slot)))
|
||||
|
||||
(defmethod slot-boundp-using-class ((class standard-class) instance
|
||||
(slot standard-effective-slot-definition))
|
||||
(slot-boundp-using-class class instance (slot-definition-name slot)))
|
||||
|
||||
(defmethod (setf slot-value-using-class) (val (class standard-class) instance
|
||||
(slot standard-effective-slot-definition))
|
||||
(standard-instance-set val instance (slot-definition-name slot)))
|
||||
|
||||
(defmethod slot-makunbound-using-class ((class standard-class) instance
|
||||
(slot standard-effective-slot-definition))
|
||||
(slot-makunbound-using-class class instance (slot-definition-name slot)))
|
||||
|
||||
|
|
|
|||
|
|
@ -73,8 +73,7 @@
|
|||
(eval-when (compile eval)
|
||||
(defparameter +standard-class-slots+
|
||||
(append +class-slots+
|
||||
'((slot-index-table :accessor slot-index-table)
|
||||
(shared-slots :initform nil :accessor class-shared-slots)
|
||||
'((slot-table :accessor slot-table)
|
||||
(forward)))))
|
||||
|
||||
#.(create-accessors +standard-class-slots+ 'standard-class)
|
||||
|
|
|
|||
|
|
@ -38,10 +38,11 @@
|
|||
(readers :initarg :readers :initform nil :accessor slot-definition-readers)
|
||||
(writers :initarg :writers :initform nil :accessor slot-definition-writers)
|
||||
(documentation :initarg :documentation :initform nil :accessor slot-definition-documentation)
|
||||
(location :initarg :documentation :initform nil :accessor slot-definition-location)
|
||||
))
|
||||
|
||||
(defun make-simple-slotd (&key name initform initfunction type allocation initargs readers writers documentation)
|
||||
(list name initform initfunction type allocation initargs readers writers documentation))
|
||||
(defun make-simple-slotd (&key name initform initfunction type allocation initargs readers writers documentation location)
|
||||
(list name initform initfunction type allocation initargs readers writers documentation location))
|
||||
|
||||
(defun canonical-slot-to-direct-slot (class slotd)
|
||||
(if (find-class 'slot-definition nil)
|
||||
|
|
|
|||
|
|
@ -234,9 +234,16 @@ because it contains a reference to the undefined class~% ~A"
|
|||
:direct-superclasses (class-direct-superclasses subclass)))
|
||||
)
|
||||
|
||||
(defun std-create-slots-table (class)
|
||||
(let* ((all-slots (class-slots class))
|
||||
(table (make-hash-table :size (max 32 (length all-slots)))))
|
||||
(dolist (slotd (class-slots class))
|
||||
(setf (gethash (slot-definition-name slotd) table) slotd))
|
||||
(setf (slot-table class) table)))
|
||||
|
||||
(defmethod finalize-inheritance ((class standard-class))
|
||||
(call-next-method)
|
||||
(std-class-allocate-slots class)
|
||||
(std-create-slots-table class)
|
||||
(std-class-generate-accessors class))
|
||||
|
||||
(defmethod compute-class-precedence-list ((class class))
|
||||
|
|
@ -346,38 +353,44 @@ because it contains a reference to the undefined class~% ~A"
|
|||
(list* :direct-superclasses direct-superclasses options)))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; Slots hashing for standard classes
|
||||
;;; Around methods for COMPUTE-SLOTS which assign locations to each slot.
|
||||
;;;
|
||||
|
||||
(defun std-class-allocate-slots (class)
|
||||
(defun class-compute-slots (class slots)
|
||||
(let ((local-index -1))
|
||||
(declare (fixnum local-index))
|
||||
(dolist (slotd slots)
|
||||
(when (eq (slot-definition-allocation slotd) :instance)
|
||||
(setf (slot-definition-location slotd) (incf local-index))))
|
||||
slots))
|
||||
|
||||
(defmethod compute-slots :around ((class class))
|
||||
(class-compute-slots class (call-next-method)))
|
||||
|
||||
(defun std-class-compute-slots (class slots)
|
||||
(declare (si::c-local))
|
||||
(let* ((slots (class-slots class))
|
||||
(direct-slots (class-direct-slots class))
|
||||
(slot-instance-count (count-instance-slots class))
|
||||
(table (make-hash-table :size (max 32 (* 2 slot-instance-count))))
|
||||
(local-index -1)
|
||||
(shared-index -1))
|
||||
(declare (fixnum local-index shared-index))
|
||||
(dolist (slot slots)
|
||||
(let* ((name (slot-definition-name slot))
|
||||
(allocation (slot-definition-allocation slot))
|
||||
location)
|
||||
(cond ((eq allocation :INSTANCE) ; local slot
|
||||
(setq location (incf local-index)))
|
||||
(let* ((direct-slots (class-direct-slots class)))
|
||||
(dolist (slotd slots)
|
||||
(let* ((name (slot-definition-name slotd))
|
||||
(allocation (slot-definition-allocation slotd)))
|
||||
(cond ((not (eq (slot-definition-allocation slotd) :class)))
|
||||
((find name direct-slots :key #'slot-definition-name) ; new shared slot
|
||||
(setq location (cons class (incf shared-index))))
|
||||
(setf (slot-definition-location slotd) (list (unbound))))
|
||||
(t ; inherited shared slot
|
||||
(dolist (c (class-precedence-list class))
|
||||
(when (and
|
||||
(not (eql c class))
|
||||
(typep c 'STANDARD-CLASS)
|
||||
(setq location
|
||||
(gethash name (slot-value c 'SLOT-INDEX-TABLE))))
|
||||
(return)))))
|
||||
(setf (gethash name table) location)))
|
||||
(setf (class-shared-slots class)
|
||||
(make-array (1+ shared-index) :initial-element (unbound))
|
||||
(slot-index-table class) table)))
|
||||
(unless (eql c class)
|
||||
(let ((other (find (slot-definition-name slotd)
|
||||
(class-slots c)
|
||||
:key #'slot-definition-name)))
|
||||
(when (and other
|
||||
(eq (slot-definition-allocation other) allocation)
|
||||
(setf (slot-definition-location slotd)
|
||||
(slot-definition-location other)))
|
||||
(return)))))))))
|
||||
slots))
|
||||
|
||||
(defmethod compute-slots :around ((class standard-class))
|
||||
(std-class-compute-slots class (call-next-method)))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; Optional accessors
|
||||
|
|
@ -391,28 +404,26 @@ because it contains a reference to the undefined class~% ~A"
|
|||
;; the liberty of using SI:INSTANCE-REF because they know the class of
|
||||
;; the instance.
|
||||
;;
|
||||
(do* ((slots (class-slots standard-class) (cdr slots))
|
||||
(i 0))
|
||||
((endp slots))
|
||||
(declare (fixnum i))
|
||||
(let* ((slotd (first slots))
|
||||
(slot-name (slot-definition-name slotd))
|
||||
(index i)
|
||||
(dolist (slotd (class-slots standard-class))
|
||||
(let* ((slot-name (slot-definition-name slotd))
|
||||
(index (slot-definition-location slotd))
|
||||
reader setter)
|
||||
(declare (fixnum index))
|
||||
(if (eql (slot-definition-allocation slotd) :instance)
|
||||
(if (and (eql (slot-definition-allocation slotd) :instance)
|
||||
(si:fixnump index))
|
||||
(setf reader #'(lambda (self)
|
||||
(let ((value (si:instance-ref self index)))
|
||||
(if (si:sl-boundp value)
|
||||
value
|
||||
(values (slot-unbound (class-of self) self slot-name)))))
|
||||
setter #'(lambda (value self)
|
||||
(si:instance-set self index value))
|
||||
i (1+ i))
|
||||
(si:instance-set self index value)))
|
||||
(setf reader #'(lambda (self)
|
||||
(slot-value self slot-name))
|
||||
(slot-value-using-class (si:instance-class self)
|
||||
self slotd))
|
||||
setter #'(lambda (value self)
|
||||
(setf (slot-value self slot-name) value))))
|
||||
(setf (slot-value-using-class (si:instance-class self)
|
||||
self slotd) value))))
|
||||
(dolist (fname (slot-definition-readers slotd))
|
||||
(install-method fname nil `(,standard-class) '(self) nil nil
|
||||
reader))
|
||||
|
|
@ -426,48 +437,6 @@ because it contains a reference to the undefined class~% ~A"
|
|||
;;; Standard-object has no slots and inherits only from t:
|
||||
;;; (defclass standard-object (t) ())
|
||||
|
||||
(defmethod slot-value-using-class ((class standard-class) instance slot-name)
|
||||
(multiple-value-bind (val condition)
|
||||
(standard-instance-get instance slot-name)
|
||||
(case condition
|
||||
(:VALUE val)
|
||||
(:UNBOUND (values (slot-unbound (si:instance-class instance) instance
|
||||
slot-name)))
|
||||
(:MISSING (values (slot-missing (si:instance-class instance) instance
|
||||
slot-name 'SLOT-VALUE)))
|
||||
)))
|
||||
|
||||
(defmethod slot-boundp-using-class ((class standard-class) instance slot-name)
|
||||
(multiple-value-bind (val condition)
|
||||
(standard-instance-get instance slot-name)
|
||||
(declare (ignore val))
|
||||
(case condition
|
||||
(:VALUE t)
|
||||
(:UNBOUND nil)
|
||||
(:MISSING (values (slot-missing (si:instance-class instance) instance
|
||||
slot-name 'SLOT-BOUNDP)))
|
||||
)))
|
||||
|
||||
(defmethod (setf slot-value-using-class) (val (class standard-class) instance
|
||||
slot-name)
|
||||
(standard-instance-set val instance slot-name))
|
||||
|
||||
(defmethod slot-exists-p-using-class ((class standard-class) instance slot-name)
|
||||
(and (nth-value 0 (gethash slot-name (slot-index-table class) nil))
|
||||
t))
|
||||
|
||||
(defmethod slot-makunbound-using-class ((class standard-class) instance slot-name)
|
||||
(let* ((index (slot-index slot-name (slot-index-table class))))
|
||||
(if index
|
||||
(if (atom index)
|
||||
(si:sl-makunbound instance (the fixnum index))
|
||||
;; else it is a shared slot
|
||||
(setf (svref (class-shared-slots (car index)) (cdr index))
|
||||
(unbound)))
|
||||
(slot-missing (si:instance-class instance) instance slot-name
|
||||
'SLOT-MAKUNBOUND)))
|
||||
instance)
|
||||
|
||||
(defmethod describe-object ((obj standard-object) (stream t))
|
||||
(let* ((class (si:instance-class obj))
|
||||
(slotds (class-slots class))
|
||||
|
|
@ -556,39 +525,6 @@ because it contains a reference to the undefined class~% ~A"
|
|||
(t
|
||||
(setf unknown-key name)))))))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; Basic access to instances
|
||||
|
||||
(defun standard-instance-get (instance slot-name)
|
||||
(ensure-up-to-date-instance instance)
|
||||
(let* ((class (si:instance-class instance))
|
||||
(index (gethash slot-name (slot-index-table class))))
|
||||
(declare (type standard-class class))
|
||||
(if (null index)
|
||||
(values nil :MISSING)
|
||||
(let ((val (if (atom index)
|
||||
;; local slot
|
||||
(si:instance-ref instance (the fixnum index))
|
||||
;; shared slot
|
||||
(svref (class-shared-slots (car index)) (cdr index)))))
|
||||
(if (si:sl-boundp val)
|
||||
(values val :VALUE)
|
||||
(values nil :UNBOUND))))))
|
||||
|
||||
(defun standard-instance-set (val instance slot-name)
|
||||
(ensure-up-to-date-instance instance)
|
||||
(let* ((class (si:instance-class instance))
|
||||
(index (gethash slot-name (slot-index-table class))))
|
||||
(declare (type standard-class class))
|
||||
(if index
|
||||
(if (atom index)
|
||||
(si:instance-set instance (the fixnum index) val)
|
||||
;; else it is a shared slot
|
||||
(setf (svref (class-shared-slots (car index)) (cdr index)) val))
|
||||
(slot-missing (si:instance-class instance) instance slot-name
|
||||
'SETF val))
|
||||
val))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; Methods
|
||||
|
||||
|
|
|
|||
|
|
@ -1412,9 +1412,7 @@ type_of(#0)==t_bitvector")
|
|||
clos::class-direct-subclasses
|
||||
clos::class-slots
|
||||
clos::class-precedence-list
|
||||
clos::slot-index-table
|
||||
clos::class-direct-slots
|
||||
clos::class-shared-slots
|
||||
clos::default-initargs-of
|
||||
clos::generic-function-lambda-list
|
||||
clos::generic-function-argument-precedence-order
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue