Declare EXPLICIT-CHECK on CONCATENATE, MAKE-STRING, SET-PPRINT-DISPATCH.
[sbcl.git] / src / code / target-defstruct.lisp
blob43b50527381a91766805f6337a822abcb8b8486b
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3 ;;;;
4 ;;;; This software is derived from the CMU CL system, which was
5 ;;;; written at Carnegie Mellon University and released into the
6 ;;;; public domain. The software is in the public domain and is
7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
8 ;;;; files for more information.
10 (in-package "SB!KERNEL")
12 (/show0 "target-defstruct.lisp 12")
14 ;;;; structure frobbing primitives
16 ;;; Allocate a new instance with LENGTH data slots.
17 (defun %make-instance (length)
18 (declare (type index length))
19 (%make-instance length))
21 ;;; Given an instance, return its length.
22 (defun %instance-length (instance)
23 (declare (type instance instance))
24 (%instance-length instance))
26 ;;; Return the value from the INDEXth slot of INSTANCE. This is SETFable.
27 (defun %instance-ref (instance index)
28 (%instance-ref instance index))
30 ;;; Set the INDEXth slot of INSTANCE to NEW-VALUE.
31 (defun %instance-set (instance index new-value)
32 (setf (%instance-ref instance index) new-value))
34 ;;; Normally IR2 converted, definition needed for interpreted structure
35 ;;; constructors only.
36 #!+sb-eval
37 (defun %make-structure-instance (dd slot-specs &rest slot-values)
38 (let ((instance (%make-instance (dd-instance-length dd))))
39 (setf (%instance-layout instance) (dd-layout-or-lose dd))
40 (mapc (lambda (spec value)
41 (destructuring-bind (raw-type . index) (cdr spec)
42 (macrolet ((make-case ()
43 `(ecase raw-type
44 ((t)
45 (setf (%instance-ref instance index) value))
46 ,@(mapcar
47 (lambda (rsd)
48 `(,(raw-slot-data-raw-type rsd)
49 (setf (,(raw-slot-data-accessor-name rsd)
50 instance index)
51 value)))
52 *raw-slot-data-list*))))
53 (make-case))))
54 slot-specs slot-values)
55 instance))
57 (defun %raw-instance-ref/word (instance index)
58 (declare (type index index))
59 (%raw-instance-ref/word instance index))
60 (defun %raw-instance-set/word (instance index new-value)
61 (declare (type index index)
62 (type sb!vm:word new-value))
63 (%raw-instance-set/word instance index new-value))
65 (defun %raw-instance-ref/single (instance index)
66 (declare (type index index))
67 (%raw-instance-ref/single instance index))
68 (defun %raw-instance-set/single (instance index new-value)
69 (declare (type index index)
70 (type single-float new-value))
71 (%raw-instance-set/single instance index new-value))
73 (defun %raw-instance-ref/double (instance index)
74 (declare (type index index))
75 (%raw-instance-ref/double instance index))
76 (defun %raw-instance-set/double (instance index new-value)
77 (declare (type index index)
78 (type double-float new-value))
79 (%raw-instance-set/double instance index new-value))
81 (defun %raw-instance-ref/complex-single (instance index)
82 (declare (type index index))
83 (%raw-instance-ref/complex-single instance index))
84 (defun %raw-instance-set/complex-single (instance index new-value)
85 (declare (type index index)
86 (type (complex single-float) new-value))
87 (%raw-instance-set/complex-single instance index new-value))
89 (defun %raw-instance-ref/complex-double (instance index)
90 (declare (type index index))
91 (%raw-instance-ref/complex-double instance index))
92 (defun %raw-instance-set/complex-double (instance index new-value)
93 (declare (type index index)
94 (type (complex double-float) new-value))
95 (%raw-instance-set/complex-double instance index new-value))
97 (defun %instance-layout (instance)
98 (%instance-layout instance))
100 (defun %set-instance-layout (instance new-value)
101 (%set-instance-layout instance new-value))
103 (defun %make-funcallable-instance (len)
104 (%make-funcallable-instance len))
106 (defun funcallable-instance-p (x)
107 (funcallable-instance-p x))
109 (deftype funcallable-instance ()
110 `(satisfies funcallable-instance-p))
112 (defun %funcallable-instance-info (fin i)
113 (%funcallable-instance-info fin i))
115 (defun %set-funcallable-instance-info (fin i new-value)
116 (%set-funcallable-instance-info fin i new-value))
118 (defun funcallable-instance-fun (fin)
119 (%funcallable-instance-function fin))
121 (defun (setf funcallable-instance-fun) (new-value fin)
122 (setf (%funcallable-instance-function fin) new-value))
124 ;;;; target-only parts of the DEFSTRUCT top level code
126 ;;; A list of hooks designating functions of one argument, the
127 ;;; classoid, to be called when a defstruct is evaluated.
128 (!defvar *defstruct-hooks* nil)
130 ;;; the part of %DEFSTRUCT which makes sense only on the target SBCL
132 (defun %target-defstruct (dd)
133 (declare (type defstruct-description dd))
135 (/show0 "entering %TARGET-DEFSTRUCT")
137 (when (dd-doc dd)
138 (setf (fdocumentation (dd-name dd) 'structure)
139 (dd-doc dd)))
141 (let* ((classoid (find-classoid (dd-name dd)))
142 (layout (classoid-layout classoid)))
143 (when (eq (dd-pure dd) t)
144 (setf (layout-pure layout) t))
145 #!+interleaved-raw-slots
146 ;; Make a vector of EQUALP slots comparators, indexed by (- word-index data-start).
147 ;; This has to be assigned to something regardless of whether there are
148 ;; raw slots just in case someone mutates a layout which had raw
149 ;; slots into one which does not - although that would probably crash
150 ;; unless no instances exist or all raw slots miraculously contained
151 ;; bits which were the equivalent of valid Lisp descriptors.
153 ;; It's not worth adding a #-interleaved-raw-slots case to this optimization
154 ;; because every architecture can be made to use the new approach.
155 (setf (layout-equalp-tests layout)
156 (if (zerop (layout-untagged-bitmap layout))
158 ;; The initial element of NIL means "do not compare".
159 ;; Ignored words (comparator = NIL) fall into two categories:
160 ;; - pseudo-ignored, which get compared by their
161 ;; predecessor word, as for complex-double-float,
162 ;; - internal padding words which are truly ignored.
163 ;; Other words are compared as tagged if the comparator is 0,
164 ;; or as untagged if the comparator is a type-specific function.
165 (let ((comparators
166 ;; If data-start is 1, subtract 1 because we don't need
167 ;; a comparator for the LAYOUT slot.
168 (make-array (- (dd-length dd) sb!vm:instance-data-start)
169 :initial-element nil)))
170 (dolist (slot (dd-slots dd) comparators)
171 ;; -1 because LAYOUT (slot index 0) has no comparator stored.
172 (setf (aref comparators
173 (- (dsd-index slot) sb!vm:instance-data-start))
174 (let ((raw-type (dsd-raw-type slot)))
175 (if (eq raw-type t)
176 0 ; means recurse using EQUALP
177 (raw-slot-data-comparer
178 (raw-slot-data-or-lose raw-type)))))))))
180 (dolist (fun *defstruct-hooks*)
181 (funcall fun classoid)))
183 (/show0 "leaving %TARGET-DEFSTRUCT")
184 (values))
186 ;;; Copy any old kind of structure.
187 (defun copy-structure (structure)
188 #!+sb-doc
189 "Return a copy of STRUCTURE with the same (EQL) slot values."
190 (declare (type structure-object structure))
191 (let ((layout (%instance-layout structure)))
192 (when (layout-invalid layout)
193 (error "attempt to copy an obsolete structure:~% ~S" structure))
194 (let ((res (%make-instance (%instance-length structure)))
195 (len (layout-length layout)))
196 (declare (type index len))
197 #!-interleaved-raw-slots
198 (let ((nuntagged (layout-n-untagged-slots layout)))
199 ;; Copy ordinary slots including the layout.
200 (dotimes (i (- len nuntagged))
201 (declare (type index i))
202 (setf (%instance-ref res i) (%instance-ref structure i)))
203 ;; Copy raw slots.
204 (dotimes (i nuntagged)
205 (declare (type index i))
206 (setf (%raw-instance-ref/word res i)
207 (%raw-instance-ref/word structure i))))
208 #!+interleaved-raw-slots
209 (let ((metadata (layout-untagged-bitmap layout)))
210 ;; Don't assume that %INSTANCE-REF can access the layout.
211 (setf (%instance-layout res) (%instance-layout structure))
212 ;; With interleaved slots, the only difference between %instance-ref
213 ;; and %raw-instance-ref/word is the storage class of the VOP operands.
214 ;; Since x86(-64) doesn't partition the register set, the bitmap test
215 ;; could be skipped if we wanted to copy everything as raw.
216 (macrolet ((copy-loop (raw-p &optional step)
217 `(do ((i sb!vm:instance-data-start (1+ i)))
218 ((>= i len))
219 (declare (index i))
220 (if ,raw-p
221 (setf (%raw-instance-ref/word res i)
222 (%raw-instance-ref/word structure i))
223 (setf (%instance-ref res i)
224 (%instance-ref structure i)))
225 ,step)))
226 (cond ((zerop metadata) ; no untagged slots.
227 (copy-loop nil))
228 ;; The fixnum case uses fixnum operations for ODDP and ASH.
229 ((fixnump metadata) ; shift and mask is faster than logbitp
230 (copy-loop (oddp (truly-the fixnum metadata))
231 (setq metadata (ash metadata -1))))
232 (t ; bignum - use LOGBITP to avoid consing more bignums
233 (copy-loop (logbitp i metadata))))))
234 res)))
237 ;; Do an EQUALP comparison on the raw slots (only, not the normal slots) of a
238 ;; structure.
239 #!-interleaved-raw-slots
240 (defun raw-instance-slots-equalp (layout x y)
241 ;; This implementation sucks, but hopefully EQUALP on raw structures
242 ;; won't be a major bottleneck for anyone. It'd be tempting to do
243 ;; all this with %RAW-INSTANCE-REF/WORD and bitwise comparisons, but
244 ;; that'll fail in some cases. For example -0.0 and 0.0 are EQUALP
245 ;; but have different bit patterns. -- JES, 2007-08-21
246 (loop for dsd in (dd-slots (layout-info layout))
247 for raw-type = (dsd-raw-type dsd)
248 for rsd = (unless (eql raw-type t)
249 (find raw-type
250 *raw-slot-data-list*
251 :key 'raw-slot-data-raw-type))
252 always (or (not rsd)
253 (funcall (raw-slot-data-comparer rsd) (dsd-index dsd) x y))))
255 ;;; default PRINT-OBJECT method
257 (defun %default-structure-pretty-print (structure stream name dd)
258 (pprint-logical-block (stream nil :prefix "#S(" :suffix ")")
259 (prin1 name stream)
260 (let ((remaining-slots (dd-slots dd)))
261 (when remaining-slots
262 (write-char #\space stream)
263 ;; CMU CL had (PPRINT-INDENT :BLOCK 2 STREAM) here,
264 ;; but I can't see why. -- WHN 20000205
265 (pprint-newline :linear stream)
266 (loop (pprint-pop)
267 (let ((slot (pop remaining-slots)))
268 (write-char #\: stream)
269 (output-symbol-name (symbol-name (dsd-name slot)) stream)
270 (write-char #\space stream)
271 (pprint-newline :miser stream)
272 (output-object (funcall (dsd-accessor-name slot) structure)
273 stream)
274 (when (null remaining-slots)
275 (return))
276 (write-char #\space stream)
277 (pprint-newline :linear stream)))))))
279 (defun %default-structure-ugly-print (structure stream name dd)
280 (descend-into (stream)
281 (write-string "#S(" stream)
282 (prin1 name stream)
283 (do ((index 0 (1+ index))
284 (limit (or (and (not *print-readably*) *print-length*)
285 most-positive-fixnum))
286 (remaining-slots (dd-slots dd) (cdr remaining-slots)))
287 ((or (null remaining-slots) (>= index limit))
288 (write-string (if remaining-slots " ...)" ")") stream))
289 (declare (type index index))
290 (write-string " :" stream)
291 (let ((slot (first remaining-slots)))
292 (output-symbol-name (symbol-name (dsd-name slot)) stream)
293 (write-char #\space stream)
294 (output-object (funcall (dsd-accessor-name slot) structure)
295 stream)))))
297 (defun default-structure-print (structure stream depth)
298 (declare (ignore depth))
299 (if (funcallable-instance-p structure)
300 (print-unreadable-object (structure stream :identity t :type t))
301 (let* ((layout (%instance-layout structure))
302 (dd (layout-info layout))
303 (name (classoid-name (layout-classoid layout))))
304 (cond ((not dd)
305 ;; FIXME? this branch may be unnecessary as a consequence
306 ;; of change f02bee325920166b69070e4735a8a3f295f8edfd which
307 ;; stopped the badness is a stronger way. It should be the case
308 ;; that absence of a DD can't happen unless the classoid is absent.
309 ;; KLUDGE: during PCL build debugging, we can sometimes
310 ;; attempt to print out a PCL object (with null LAYOUT-INFO).
311 (pprint-logical-block (stream nil :prefix "#<" :suffix ">")
312 (prin1 name stream)
313 (write-char #\space stream)
314 (write-string "(no LAYOUT-INFO)" stream)))
315 ((not (dd-slots dd))
316 ;; the structure type doesn't count as a component for *PRINT-LEVEL*
317 ;; processing. We can likewise elide the logical block processing,
318 ;; since all we have to print is the type name. -- CSR, 2004-10-05
319 (write-string "#S(" stream)
320 (prin1 name stream)
321 (write-char #\) stream))
323 (funcall (if *print-pretty*
324 #'%default-structure-pretty-print
325 #'%default-structure-ugly-print)
326 structure stream name dd))))))
328 (def!method print-object ((x structure-object) stream)
329 (default-structure-print x stream *current-level-in-print*))
331 ;; This generates a sexpr that can be recognized as having a particular
332 ;; shape so that the dumping mechanism can decide if it is or is not
333 ;; necessary to run that code through the main compiler - FASL operations
334 ;; can be used in the case that all slots are preserved.
335 ;; In particular, there are no gensyms in the result, so that calling this
336 ;; twice on the same object yields the same list as compared by EQUAL.
337 (defun structure-obj-slot-saving-forms (struct slot-names slot-names-p)
338 (let* ((layout (%instance-layout struct))
339 (dd (layout-info layout)))
340 (mapcan (lambda (dsd)
341 (when (or (not slot-names-p) (memq (dsd-name dsd) slot-names))
342 (let ((index (dsd-index dsd))
343 (raw-type (dsd-raw-type dsd)))
344 (if (eq raw-type t)
345 `((%instance-ref ,struct ,index)
346 ,(let ((val (%instance-ref struct index)))
347 (if (and (or (listp val) (symbolp val))
348 (not (member val '(nil t))))
349 (list 'quote val)
350 val)))
351 (let ((accessor (raw-slot-data-accessor-name
352 (raw-slot-data-or-lose raw-type))))
353 `((,accessor ,struct ,index)
354 ,(funcall accessor struct index)))))))
355 (dd-slots dd))))
357 ;; Return T if CREATION-FORM and INIT-FORM would have the identical effect
358 ;; as :SB-JUST-DUMP-IT-NORMALLY for STRUCT. MAKE-LOAD-FORM-SAVING-SLOTS can't
359 ;; merely return the magic token (when possible) because a user application
360 ;; could call MAKE-LOAD-FORM-SAVING-SLOTS to obtain forms that can be evaluated
361 ;; or otherwise examined. So instead we scan the code and detect whether it is
362 ;; identical to what was returned from a trivial use of M-L-F-S-S.
363 (defun canonical-slot-saving-forms-p (struct creation-form init-form)
364 (and (sb!c::canonical-instance-maker-form-p creation-form)
365 (typep init-form '(cons (eql setf)))
366 (eq (cadr (cadr (cadr creation-form))) (class-name (class-of struct)))
367 (= (length (dd-slots (layout-info (%instance-layout struct))))
368 (ash (list-length (cdr init-form)) -1))
369 (flet ((eq-quoted-p (a b)
370 (and (typep a '(cons (eql quote) (cons t null)))
371 (typep b '(cons (eql quote) (cons t null)))
372 (eq (cadr a) (cadr b)))))
373 ;; Naively, EQUALP would almost work to compare the slot assignments,
374 ;; but we must not get stuck in circular lists, so traverse by hand.
375 (loop for (expect-place expect-value)
376 on (structure-obj-slot-saving-forms struct nil nil) by #'cddr
377 for (actual-place actual-value) on (cdr init-form) by #'cddr
378 always (and (equal actual-place expect-place)
379 ;; Use EQL, not EQ. Values come from the identical
380 ;; struct, but reading a raw slot can create new
381 ;; pointers. For QUOTE forms, EQ is ok.
382 (or (eql actual-value expect-value)
383 (eq-quoted-p actual-value expect-value)))))))
385 (/show0 "target-defstruct.lisp end of file")