1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from software originally released by Xerox
5 ;;;; Corporation. Copyright and release statements follow. Later modifications
6 ;;;; to the software are in the public domain and are provided with
7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
10 ;;;; copyright information from original PCL sources:
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
15 ;;;; Use and copying of this software and preparation of derivative works based
16 ;;;; upon this software are permitted. Any distribution of this software or
17 ;;;; derivative works must comply with all applicable United States export
20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
21 ;;;; warranty about the software, its performance or its conformity to any
29 (defmethod initialize-internal-slot-functions :after
30 ((slotd structure-effective-slot-definition))
31 (let ((name (slot-definition-name slotd)))
32 (initialize-internal-slot-reader-gfs name)
33 (initialize-internal-slot-writer-gfs name)
34 (initialize-internal-slot-boundp-gfs name)))
36 (defmethod slot-definition-allocation ((slotd structure-slot-definition))
39 (defmethod class-prototype ((class structure-class))
40 (with-slots (prototype) class
42 (setq prototype (make-class-prototype class)))))
44 (defmethod make-class-prototype ((class structure-class))
45 (with-slots (wrapper defstruct-constructor) class
46 (if defstruct-constructor
48 (let* ((proto (%allocate-instance--class *empty-vector*)))
49 (shared-initialize proto T :check-initargs-legality-p NIL)
50 (setf (std-instance-wrapper proto) wrapper)
53 (defmethod make-direct-slotd ((class structure-class)
56 (name (error "Slot needs a name."))
57 (conc-name (class-defstruct-conc-name class))
58 (defstruct-accessor-symbol () acc-sym-p)
60 (declare (ignore defstruct-accessor-symbol))
61 (declare (type symbol name)
62 (type simple-string conc-name))
63 (let ((initargs (list* :class class :allow-other-keys T initargs)))
66 (list* :defstruct-accessor-symbol
67 (intern (concatenate 'simple-string conc-name (symbol-name name))
68 (symbol-package (class-name class)))
70 (apply #'make-instance (direct-slot-definition-class class initargs) initargs)))
72 (defun slot-definition-defstruct-slot-description (slot)
73 (let ((type (slot-definition-type slot)))
74 `(,(slot-definition-name slot) ,(slot-definition-initform slot)
75 ,@(unless (eq type t) `(:type ,type)))))
77 (defmethod shared-initialize :after
78 ((class structure-class)
80 &key (direct-superclasses nil direct-superclasses-p)
81 (direct-slots nil direct-slots-p)
82 direct-default-initargs
83 (predicate-name nil predicate-name-p))
84 (declare (ignore slot-names direct-default-initargs))
85 (let* ((name (class-name class))
86 (from-defclass-p (slot-value class 'from-defclass-p))
87 (defstruct-form (defstruct-form name))
89 (or (if defstruct-form (defstruct-form-conc-name defstruct-form))
90 (slot-value class 'defstruct-conc-name)
91 (format nil "~S structure class " name)))
93 (if defstruct-form (defstruct-form-predicate-name defstruct-form)))
94 (pred-name ;; Predicate name for class
95 (or (if predicate-name-p (car predicate-name))
96 (if defstruct-form defstruct-predicate)
97 (slot-value class 'predicate-name)
98 (make-class-predicate-name name)))
100 (or (if defstruct-form (defstruct-form-constructor defstruct-form))
101 (slot-value class 'defstruct-constructor)
103 (list (intern (format nil "~Aconstructor" conc-name)
104 (symbol-package name))
106 (declare (type symbol name defstruct-predicate pred-name)
107 (type boolean from-defclass-p)
108 (type simple-string conc-name))
109 (if direct-superclasses-p
110 (setf (slot-value class 'direct-superclasses)
111 (or direct-superclasses
112 (setq direct-superclasses
113 (if (eq name 'structure-object)
115 (list *the-class-structure-object*)))))
116 (setq direct-superclasses (slot-value class 'direct-superclasses)))
119 (setf (slot-value class 'direct-slots)
120 (mapcar #'(lambda (pl)
121 (apply #'make-direct-slotd class
122 :conc-name conc-name pl))
124 (slot-value class 'direct-slots)))
125 (when from-defclass-p
126 (do-defstruct-from-defclass
127 class direct-superclasses direct-slots conc-name pred-name constructor))
128 (compile-structure-class-internals
129 class direct-slots conc-name pred-name constructor)
130 (setf (slot-value class 'predicate-name) pred-name)
131 (setf (slot-value class 'defstruct-conc-name) conc-name)
132 (unless (extract-required-parameters (second constructor))
133 (setf (slot-value class 'defstruct-constructor) (car constructor)))
134 (when (and defstruct-predicate (not from-defclass-p))
135 (setf (symbol-function pred-name) (symbol-function defstruct-predicate)))
136 (unless (or from-defclass-p (slot-value class 'documentation))
137 (setf (slot-value class 'documentation)
138 (format nil "~S structure class made from Defstruct" name)))
139 (setf (find-class name) class)
140 (update-structure-class class direct-superclasses direct-slots)))
142 (defun update-structure-class (class direct-superclasses direct-slots)
143 (add-direct-subclasses class direct-superclasses)
144 (setf (slot-value class 'class-precedence-list) (compute-class-precedence-list class))
145 (let* ((eslotds (compute-slots class))
146 (internal-slotds (mapcar #'slot-definition-internal-slotd eslotds)))
147 (setf (slot-value class 'slots) eslotds)
148 (setf (slot-value class 'internal-slotds) internal-slotds)
149 (setf (slot-value class 'side-effect-internal-slotds) internal-slotds))
150 (unless (slot-value class 'wrapper)
151 (setf (slot-value class 'finalized-p) T)
152 (setf (slot-value class 'wrapper) (make-wrapper class)))
153 (unless (slot-boundp class 'prototype)
154 (setf (slot-value class 'prototype) nil))
155 (setf (slot-value class 'default-initargs) nil)
156 (add-slot-accessors class direct-slots))
158 (defmethod do-defstruct-from-defclass ((class structure-class)
159 direct-superclasses direct-slots
160 conc-name predicate constructor)
161 (declare (type simple-string conc-name))
162 (let* ((name (class-name class))
163 (original-defstruct-form
166 ,@(when direct-superclasses
167 `((:include ,(class-name (car direct-superclasses)))))
168 (:print-function print-std-instance)
169 (:predicate ,predicate)
170 (:conc-name ,(intern conc-name (symbol-package name)))
171 (:constructor ,@constructor))
172 ,@(mapcar #'slot-definition-defstruct-slot-description
174 (eval original-defstruct-form)
175 (store-defstruct-form (cdr original-defstruct-form))))
177 (defmethod compile-structure-class-internals ((class structure-class)
178 direct-slots conc-name
179 predicate-name constructor)
180 (declare (type simple-string conc-name))
181 (let* ((name (class-name class))
182 (package (symbol-package name))
183 (direct-slots-needing-internals
184 (if (slot-value class 'from-defclass-p)
186 (remove-if #'slot-definition-internal-reader-function
189 (mapcar #'(lambda (slotd)
190 (intern (format nil "~A~A reader" conc-name
191 (slot-definition-name slotd))
193 direct-slots-needing-internals))
195 (mapcar #'(lambda (slotd)
196 (intern (format nil "~A~A writer" conc-name
197 (slot-definition-name slotd))
199 direct-slots-needing-internals))
200 (defstruct-accessor-names
201 (mapcar #'slot-definition-defstruct-accessor-symbol
202 direct-slots-needing-internals))
204 (mapcar #'(lambda (defstruct-accessor reader-name)
206 (force-compile ',defstruct-accessor)
207 (defun ,reader-name (obj)
208 (declare (type ,name obj) #.*optimize-speed*)
209 (,defstruct-accessor obj))
210 (force-compile ',reader-name)))
211 defstruct-accessor-names reader-names))
213 (mapcar #'(lambda (defstruct-accessor writer-name)
215 (force-compile ',defstruct-accessor)
216 (defun ,writer-name (nv obj)
217 (declare (type ,name obj) #.*optimize-speed*)
218 (setf (,defstruct-accessor obj) nv))
219 (force-compile ',writer-name)))
220 defstruct-accessor-names writer-names))
221 (defstruct-extras-form
223 ,@(when (car constructor)
224 `((force-compile ',(car constructor))))
225 ,@(when (fboundp predicate-name)
226 `((force-compile ',predicate-name)))
229 (declare (type package package))
230 (eval defstruct-extras-form)
231 (mapc #'(lambda (dslotd reader-name writer-name)
232 (setf (slot-value dslotd 'internal-reader-function)
233 (gdefinition reader-name))
234 (setf (slot-value dslotd 'internal-writer-function)
235 (gdefinition writer-name)))
236 direct-slots-needing-internals reader-names writer-names)))
238 (defmethod reinitialize-instance :after ((class structure-class)
241 (map-dependents class
242 #'(lambda (dependent)
243 (apply #'update-dependent class dependent initargs))))
245 (defmethod direct-slot-definition-class ((class structure-class) initargs)
246 (declare (ignore initargs))
247 (find-class 'structure-direct-slot-definition))
249 (defmethod effective-slot-definition-class ((class structure-class) initargs)
250 (declare (ignore initargs))
251 (find-class 'structure-effective-slot-definition))
253 (defmethod finalize-inheritance ((class structure-class))
254 nil) ; always finalized
256 (defmethod compute-slots ((class structure-class))
257 (mapcan #'(lambda (superclass)
258 (mapcar #'(lambda (dslotd)
259 (compute-effective-slot-definition
260 class (slot-definition-name dslotd) (list dslotd)))
261 (class-direct-slots superclass)))
262 (reverse (slot-value class 'class-precedence-list))))
264 (defmethod compute-slots :around ((class structure-class))
265 (let ((eslotds (call-next-method)))
266 (mapc #'initialize-internal-slot-functions eslotds)
269 (defmethod compute-effective-slot-definition ((class structure-class)
271 (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
272 (class (effective-slot-definition-class class initargs))
273 (slot-definition (apply #'make-instance class initargs))
277 :slot-definition slot-definition
278 :initargs (slot-definition-initargs slot-definition)
279 :initfunction (slot-definition-initfunction slot-definition))))
280 (setf (fast-slot-value slot-definition 'internal-slotd) internal-slotd)
283 (defmethod compute-effective-slot-definition-initargs :around
284 ((class structure-class) direct-slotds)
285 (let ((slotd (car direct-slotds)))
286 (list* :defstruct-accessor-symbol (slot-definition-defstruct-accessor-symbol slotd)
287 :internal-reader-function (slot-definition-internal-reader-function slotd)
288 :internal-writer-function (slot-definition-internal-writer-function slotd)
289 (call-next-method))))
291 (defmethod make-optimized-reader-method-function ((class structure-class)
293 reader-method-prototype
295 (declare (ignore generic-function reader-method-prototype))
296 (make-structure-instance-reader-method-function slot-name))
298 (defmethod make-optimized-writer-method-function ((class structure-class)
300 writer-method-prototype
302 (declare (ignore generic-function writer-method-prototype))
303 (make-structure-instance-writer-method-function slot-name))
305 (defmethod make-optimized-boundp-method-function ((class structure-class)
307 boundp-method-prototype
309 (declare (ignore generic-function boundp-method-prototype))
310 (make-structure-instance-boundp-method-function slot-name))
312 (defun make-structure-instance-reader-method-function (slot-name)
313 (declare #.*optimize-speed*)
315 (structure-instance-slot-value instance slot-name)))
317 (defun make-structure-instance-writer-method-function (slot-name)
318 (declare #.*optimize-speed*)
319 #'(lambda (nv instance)
320 (setf (structure-instance-slot-value instance slot-name) nv)))
322 (defun make-structure-instance-boundp-method-function (slot-name)
323 (declare #.*optimize-speed*)
325 (structure-instance-slot-boundp instance slot-name)))
327 (defmethod wrapper-fetcher ((class structure-class))
328 'wrapper-for-structure)
330 (defmethod slots-fetcher ((class structure-class))