1 ;;;; This software is part of the SBCL system. See the README file for
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 #!+(or sb-eval sb-fasteval
)
37 (defun %make-structure-instance
(dd slot-specs
&rest slot-values
)
38 (let ((instance (%make-instance
(dd-length dd
)))) ; length = sans header word
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 ()
45 (setf (%instance-ref instance index
) value
))
48 `(,(raw-slot-data-raw-type rsd
)
49 (setf (,(raw-slot-data-accessor-name rsd
)
54 slot-specs slot-values
)
57 (defun %instance-layout
(instance)
58 (%instance-layout instance
))
60 (defun %set-instance-layout
(instance new-value
)
61 (%set-instance-layout instance new-value
))
63 (defun %make-funcallable-instance
(len)
64 (%make-funcallable-instance len
))
66 (defun funcallable-instance-p (x)
67 (funcallable-instance-p x
))
69 (defun %funcallable-instance-info
(fin i
)
70 (%funcallable-instance-info fin i
))
72 (defun %set-funcallable-instance-info
(fin i new-value
)
73 (%set-funcallable-instance-info fin i new-value
))
75 (defun funcallable-instance-fun (fin)
76 (%funcallable-instance-function fin
))
78 (defun (setf funcallable-instance-fun
) (new-value fin
)
79 (setf (%funcallable-instance-function fin
) new-value
))
81 ;;;; target-only parts of the DEFSTRUCT top level code
83 ;;; A list of hooks designating functions of one argument, the
84 ;;; classoid, to be called when a defstruct is evaluated.
85 (!defvar
*defstruct-hooks
* nil
)
87 ;;; the part of %DEFSTRUCT which makes sense only on the target SBCL
89 (defun %target-defstruct
(dd)
90 (declare (type defstruct-description dd
))
92 (/show0
"entering %TARGET-DEFSTRUCT")
95 (setf (fdocumentation (dd-name dd
) 'structure
)
98 (let* ((classoid (find-classoid (dd-name dd
)))
99 (layout (classoid-layout classoid
)))
100 (when (eq (dd-pure dd
) t
)
101 (setf (layout-pure layout
) t
))
102 ;; Make a vector of EQUALP slots comparators, indexed by (- word-index data-start).
103 ;; This has to be assigned to something regardless of whether there are
104 ;; raw slots just in case someone mutates a layout which had raw
105 ;; slots into one which does not - although that would probably crash
106 ;; unless no instances exist or all raw slots miraculously contained
107 ;; bits which were the equivalent of valid Lisp descriptors.
108 (setf (layout-equalp-tests layout
)
109 (if (zerop (layout-bitmap layout
))
111 ;; The initial element of NIL means "do not compare".
112 ;; Ignored words (comparator = NIL) fall into two categories:
113 ;; - pseudo-ignored, which get compared by their
114 ;; predecessor word, as for complex-double-float,
115 ;; - internal padding words which are truly ignored.
116 ;; Other words are compared as tagged if the comparator is 0,
117 ;; or as untagged if the comparator is a type-specific function.
119 ;; If data-start is 1, subtract 1 because we don't need
120 ;; a comparator for the LAYOUT slot.
121 (make-array (- (dd-length dd
) sb
!vm
:instance-data-start
)
122 :initial-element nil
)))
123 (dolist (slot (dd-slots dd
) comparators
)
124 ;; -1 because LAYOUT (slot index 0) has no comparator stored.
125 (setf (aref comparators
126 (- (dsd-index slot
) sb
!vm
:instance-data-start
))
127 (let ((rsd (dsd-raw-slot-data slot
)))
129 0 ; means recurse using EQUALP
130 (raw-slot-data-comparer rsd
))))))))
132 (dolist (fun *defstruct-hooks
*)
133 (funcall fun classoid
)))
135 (/show0
"leaving %TARGET-DEFSTRUCT")
138 ;;; Copy any old kind of structure.
139 (defun copy-structure (structure)
141 "Return a copy of STRUCTURE with the same (EQL) slot values."
142 (declare (type structure-object structure
))
143 (let ((layout (%instance-layout structure
)))
144 (when (layout-invalid layout
)
145 (error "attempt to copy an obsolete structure:~% ~S" structure
))
146 ;; Previously this had to used LAYOUT-LENGTH in the allocation,
147 ;; to avoid copying random bits from the stack to the heap if you had a
148 ;; padding word in a stack-allocated instance. This is no longer an issue.
149 ;; %INSTANCE-LENGTH returns the number of words that are logically in the
150 ;; instance, with no padding. Using %INSTANCE-LENGTH allows potentially
151 ;; interesting nonstandard things like variable-length structures.
152 (let* ((len (%instance-length structure
))
153 (res (%make-instance len
)))
154 (declare (type index len
))
155 (let ((bitmap (layout-bitmap layout
)))
156 ;; Don't assume that %INSTANCE-REF can access the layout.
157 (setf (%instance-layout res
) (%instance-layout structure
))
158 ;; On backends which don't segregate descriptor vs. non-descriptor
159 ;; registers, we could speed up this code in an obvious way.
160 (macrolet ((copy-loop (raw-p &optional step
)
161 `(do ((i sb
!vm
:instance-data-start
(1+ i
)))
165 (setf (%raw-instance-ref
/word res i
)
166 (%raw-instance-ref
/word structure i
))
167 (setf (%instance-ref res i
)
168 (%instance-ref structure i
)))
170 (cond ((zerop bitmap
) ; no untagged slots.
172 ;; The fixnum case uses fixnum operations for ODDP and ASH.
173 ((fixnump bitmap
) ; shift and mask is faster than logbitp
174 (copy-loop (oddp (truly-the fixnum bitmap
))
175 (setq bitmap
(ash bitmap -
1))))
176 (t ; bignum - use LOGBITP to avoid consing more bignums
177 (copy-loop (logbitp i bitmap
))))))
180 ;;; default PRINT-OBJECT method
182 ;;; Printing formerly called the auto-generated accessor functions,
183 ;;; but reading the slots more primitively confers several advantages:
184 ;;; - it works even if the user clobbered an accessor
185 ;;; - it works if the slot fails a type-check and the reader was SAFE-P,
186 ;; i.e. was required to perform a check. This is a feature, not a bug.
187 (macrolet ((access-fn (dsd)
188 `(acond ((dsd-raw-slot-data ,dsd
)
189 (symbol-function (raw-slot-data-accessor-name it
)))
190 (t #'%instance-ref
))))
192 (defun %default-structure-pretty-print
(structure stream name dd
)
193 (pprint-logical-block (stream nil
:prefix
"#S(" :suffix
")")
195 (let ((remaining-slots (dd-slots dd
)))
196 (when remaining-slots
197 (write-char #\space stream
)
198 ;; CMU CL had (PPRINT-INDENT :BLOCK 2 STREAM) here,
199 ;; but I can't see why. -- WHN 20000205
200 (pprint-newline :linear stream
)
202 (let ((slot (pop remaining-slots
)))
203 (write-char #\
: stream
)
204 (output-symbol-name (symbol-name (dsd-name slot
)) stream
)
205 (write-char #\space stream
)
206 (pprint-newline :miser stream
)
207 (output-object (funcall (access-fn slot
) structure
(dsd-index slot
))
209 (when (null remaining-slots
)
211 (write-char #\space stream
)
212 (pprint-newline :linear stream
)))))))
214 (defun %default-structure-ugly-print
(structure stream name dd
)
215 (descend-into (stream)
216 (write-string "#S(" stream
)
218 (do ((index 0 (1+ index
))
219 (limit (or (and (not *print-readably
*) *print-length
*)
220 most-positive-fixnum
))
221 (remaining-slots (dd-slots dd
) (cdr remaining-slots
)))
222 ((or (null remaining-slots
) (>= index limit
))
223 (write-string (if remaining-slots
" ...)" ")") stream
))
224 (declare (type index index
))
225 (write-string " :" stream
)
226 (let ((slot (first remaining-slots
)))
227 (output-symbol-name (symbol-name (dsd-name slot
)) stream
)
228 (write-char #\space stream
)
229 (output-object (funcall (access-fn slot
) structure
(dsd-index slot
))
233 (defun default-structure-print (structure stream depth
)
234 (declare (ignore depth
))
235 (if (funcallable-instance-p structure
)
236 (print-unreadable-object (structure stream
:identity t
:type t
))
237 (let* ((layout (%instance-layout structure
))
238 (dd (layout-info layout
))
239 (name (classoid-name (layout-classoid layout
))))
241 ;; FIXME? this branch may be unnecessary as a consequence
242 ;; of change f02bee325920166b69070e4735a8a3f295f8edfd which
243 ;; stopped the badness is a stronger way. It should be the case
244 ;; that absence of a DD can't happen unless the classoid is absent.
245 ;; KLUDGE: during PCL build debugging, we can sometimes
246 ;; attempt to print out a PCL object (with null LAYOUT-INFO).
247 (pprint-logical-block (stream nil
:prefix
"#<" :suffix
">")
249 (write-char #\space stream
)
250 (write-string "(no LAYOUT-INFO)" stream
)))
252 ;; the structure type doesn't count as a component for *PRINT-LEVEL*
253 ;; processing. We can likewise elide the logical block processing,
254 ;; since all we have to print is the type name. -- CSR, 2004-10-05
255 (write-string "#S(" stream
)
257 (write-char #\
) stream
))
259 (funcall (if *print-pretty
*
260 #'%default-structure-pretty-print
261 #'%default-structure-ugly-print
)
262 structure stream name dd
))))))
264 (defmethod print-object ((x structure-object
) stream
)
265 (default-structure-print x stream
*current-level-in-print
*))
267 (/show0
"target-defstruct.lisp end of file")