Work at SourceForge, help us to make it a better place! We have an immediate need for a Support Technician in our San Francisco or Denver office.

Close

[130675]: src / clos / std-slot-value.lsp Maximize Restore History

Download this file

std-slot-value.lsp    254 lines (235 with data), 9.4 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*-
;;;;
;;;; Copyright (c) 1992, Giuseppe Attardi.o
;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll.
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Library General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2 of the License, or (at your option) any later version.
;;;;
;;;; See file '../Copyright' for full details.
(in-package "CLOS")
(eval-when (:compile-toplevel :execute)
(load "src:clos;hierarchy.lsp"))
;;; ----------------------------------------------------------------------
;;; SLOTS READING AND WRITING
;;;
;;; Functional and macro interface for accessing the slots of an instance.
;;; This interface is defined with specialization for classes that ECL
;;; knows of such as standard classes and funcallable standard class.
;;; This is needed to avoid circularity in compute-applicable-methods,
;;; which needs the slot values and thus cannot go through a dispatch
;;; itself.
;;;
;;; Note that using SLOT-VALUE or specialized versions of it is not
;;; wrong because the MOP enforces various restrictions on portable
;;; code:
;;; 1) Accessors must behave as SLOT-VALUE
;;; 2) In particular, any method defined by the user must be
;;; specialized on at least one non-specified class. This means
;;; that the user cannot change the behavoir of SLOT-VALUE for
;;; standard classes.
;;;
;;; First of all we define WITH-SLOTS because it is going to be useful
;;; for enforcing the use of SLOT-VALUE and not of accessors
;;; throughout the bootstrap code.
;;;
(defmacro with-slots (slot-entries instance-form &body body)
(let* ((temp (gensym))
(accessors
(do ((scan slot-entries (cdr scan))
(res))
((null scan) (nreverse res))
(if (symbolp (first scan))
(push `(,(first scan) (slot-value ,temp ',(first scan))) res)
(push `(,(caar scan)
(slot-value ,temp ',(cadar scan))) res)))))
`(let ((,temp ,instance-form))
(symbol-macrolet ,accessors ,@body))))
;;;
;;; The following macro is a convenience that can be used to directly
;;; access the slots of a class based on their s-form description. It
;;; is used internally by ECL during bootstrap. Unlike WITH-SLOTS,
;;; the macros directly access the slots by index.
;;;
(eval-when (:compile-toplevel :execute)
(defmacro with-early-accessors ((&rest slot-definitions) &rest body)
`(macrolet
,(loop for slots in slot-definitions
nconc (loop for (name . slotd) in (if (symbolp slots)
(symbol-value slots)
slots)
for index from 0
for accessor = (getf slotd :accessor)
when accessor
collect `(,accessor (object) `(si::instance-ref ,object ,,index))))
,@body)))
;;;
;;; The following macro is also used at bootstap for instantiating
;;; a class based only on the s-form description.
;;;
(eval-when (:compile-toplevel :execute)
(defmacro with-early-make-instance (slots (object class &rest key-value-pairs)
&rest body)
(when (symbolp slots)
(setf slots (symbol-value slots)))
`(let* ((%class ,class)
(,object (si::allocate-raw-instance nil %class
,(length slots))))
(declare (type standard-object ,object))
,@(flet ((initializerp (name list)
(not (eq (getf list name 'wrong) 'wrong))))
(loop for (name . slotd) in slots
for initarg = (getf slotd :initarg)
for initform = (getf slotd :initform (si::unbound))
for initvalue = (getf key-value-pairs initarg)
for index from 0
do (cond ((and initarg (initializerp initarg key-value-pairs))
(setf initform (getf key-value-pairs initarg)))
((initializerp name key-value-pairs)
(setf initform (getf key-value-pairs name))))
when (si:sl-boundp initform)
collect `(si::instance-set ,object ,index ,initform)))
(when %class
(si::instance-sig-set ,object))
(with-early-accessors (,slots)
,@body))))
;;;
;;; ECL classes store slots in a hash table for faster access. The
;;; following functions create the cache and allow us to locate the
;;; slots rapidly.
;;;
(defun std-create-slots-table (class)
(with-slots ((all-slots slots)
(slot-table slot-table)
(location-table location-table))
class
(let* ((size (max 32 (* 2 (length all-slots))))
(table (make-hash-table :size size)))
(dolist (slotd all-slots)
(setf (gethash (slot-definition-name slotd) table) slotd))
(let ((metaclass (si::instance-class class))
(locations nil))
(when (or (eq metaclass (find-class 'standard-class))
(eq metaclass (find-class 'funcallable-standard-class))
(eq metaclass (find-class 'structure-class)))
(setf locations (make-hash-table :size size))
(dolist (slotd all-slots)
(setf (gethash (slot-definition-name slotd) locations)
(slot-definition-location slotd))))
(setf slot-table table
location-table locations)))))
(defun find-slot-definition (class slot-name)
(with-slots ((slots slots) (slot-table slot-table))
class
(if (or (eq (si:instance-class class) +the-standard-class+)
(eq (si:instance-class class) +the-funcallable-standard-class+))
(gethash slot-name slot-table nil)
(find slot-name slots :key #'slot-definition-name))))
;;;
;;; INSTANCE UPDATE PREVIOUS
;;;
(eval-when (:compile-toplevel :execute)
(defmacro ensure-up-to-date-instance (instance)
;; The up-to-date status of a class is determined by
;; instance.sig. This slot of the C structure contains a list of
;; slot definitions that was used to create the instance. When the
;; class is updated, the list is newly created. Structures are also
;; "instances" but keep ECL_UNBOUND instead of the list.
`(let* ((i ,instance)
(s (si::instance-sig i)))
(declare (:read-only i s))
(with-early-accessors (+standard-class-slots+)
(when (si:sl-boundp s)
(unless (eq s (class-slots (si::instance-class i)))
(update-instance i)))))))
(defun update-instance (x)
(si::instance-sig-set x))
(declaim (notinline update-instance))
;;;
;;; STANDARD-CLASS INTERFACE
;;;
;;; Specific functions for slot reading, writing, boundness checking, etc.
;;;
(defun standard-instance-get (instance location)
(with-early-accessors (+standard-class-slots+
+slot-definition-slots+)
(ensure-up-to-date-instance instance)
(cond ((ext:fixnump location)
;; local slot
(si:instance-ref instance (truly-the fixnum location)))
((consp location)
;; shared slot
(car location))
(t
(invalid-slot-location instance location)))))
(defun standard-instance-set (val instance location)
(with-early-accessors (+standard-class-slots+
+slot-definition-slots+)
(ensure-up-to-date-instance instance)
(cond ((ext:fixnump location)
;; local slot
(si:instance-set instance (truly-the fixnum location) val))
((consp location)
;; shared slot
(setf (car location) val))
(t
(invalid-slot-location instance location)))
val))
(defun slot-value (self slot-name)
(with-early-accessors (+standard-class-slots+
+slot-definition-slots+)
(let* ((class (class-of self))
(location-table (class-location-table class)))
(if location-table
(let ((location (gethash slot-name location-table nil)))
(if location
(let ((value (standard-instance-get self location)))
(if (si:sl-boundp value)
value
(values (slot-unbound class self slot-name))))
(slot-missing class self slot-name 'SLOT-VALUE)))
(let ((slotd (find slot-name (class-slots class) :key #'slot-definition-name)))
(if slotd
(slot-value-using-class class self slotd)
(values (slot-missing class self slot-name 'SLOT-VALUE))))))))
(defun slot-exists-p (self slot-name)
(and (find-slot-definition (class-of self) slot-name)
t))
(defun slot-boundp (self slot-name)
(with-early-accessors (+standard-class-slots+
+slot-definition-slots+)
(let* ((class (class-of self))
(location-table (class-location-table class)))
(if location-table
(let ((location (gethash slot-name location-table nil)))
(if location
(si:sl-boundp (standard-instance-get self location))
(slot-missing class self slot-name 'SLOT-VALUE)))
(let ((slotd (find slot-name (class-slots class) :key #'slot-definition-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)
(with-early-accessors (+standard-class-slots+
+slot-definition-slots+)
(let* ((class (class-of self))
(location-table (class-location-table class)))
(if location-table
(let ((location (gethash slot-name location-table nil)))
(if location
(standard-instance-set value self location)
(slot-missing class self slot-name 'SETF value)))
(let ((slotd (find slot-name (class-slots class) :key #'slot-definition-name)))
(if slotd
(setf (slot-value-using-class class self slotd) value)
(slot-missing class self slot-name 'SETF value))))))
value)
;;;
;;; 2) Overloadable methods on which the previous functions are based
;;;
(defun invalid-slot-location (instance location)
(declare (si::c-local))
(error "Invalid location ~A when accessing slot of class ~A"
location (class-of location)))