/[cmucl]/src/code/defstruct.lisp
ViewVC logotype

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.33 - (show annotations)
Thu Apr 2 02:28:34 1992 UTC (22 years ago) by wlott
Branch: MAIN
Changes since 1.32: +5 -3 lines
Changed the default structure printer to print slot names as keywords
instead of unqualified symbols as per X3J13 cleanup STRUCTURE-READ-PRINT-
SYNTAX:KEYWORDS.
1 ;;; -*- Log: code.log; Package: C -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/defstruct.lisp,v 1.33 1992/04/02 02:28:34 wlott Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; Defstruct structure definition package (Mark II).
15 ;;; Written by Skef Wholey and Rob MacLachlan.
16 ;;;
17 (in-package 'c)
18 (export '(lisp::defstruct) "LISP")
19
20 (export '(structure-index make-structure structure-length
21 structure-ref structure-set))
22
23 ;;; Always compile safe. This code isn't very careful about protecting itself.
24 ;;;
25 (eval-when (compile)
26 (declaim (optimize (safety 1))))
27
28
29
30 ;;;; Structure frobbing primitives.
31
32 (defun make-structure (length)
33 "Allocate a new structure with LENGTH data slots."
34 (declare (type index length))
35 (make-structure length))
36
37 (defun structure-length (structure)
38 "Given a structure, return its length."
39 (declare (type structure structure))
40 (structure-length structure))
41
42 (defun structure-ref (struct index)
43 "Return the value from the INDEXth slot of STRUCT. 0 corresponds to the
44 type. This is SETFable."
45 (structure-ref struct index))
46
47 (defun structure-set (struct index new-value)
48 "Set the INDEXth slot of STRUCT to NEW-VALUE."
49 (setf (structure-ref struct index) new-value))
50
51 (defsetf structure-ref structure-set)
52
53
54
55 ;;; This version of Defstruct is implemented using Defstruct, and is free of
56 ;;; Maclisp compatability nonsense. For bootstrapping, you're on your own.
57
58 (defun print-defstruct-description (structure stream depth)
59 (declare (ignore depth))
60 (format stream "#<Defstruct-Description for ~S>" (dd-name structure)))
61
62 ;;; DSD-Name -- Internal
63 ;;;
64 ;;; Return the the name of a defstruct slot as a symbol. We store it
65 ;;; as a string to avoid creating lots of worthless symbols at load time.
66 ;;;
67 (defun dsd-name (dsd)
68 (intern (string (dsd-%name dsd))
69 (if (dsd-accessor dsd)
70 (symbol-package (dsd-accessor dsd))
71 *package*)))
72
73 (defun print-defstruct-slot-description (structure stream depth)
74 (declare (ignore depth))
75 (format stream "#<Defstruct-Slot-Description for ~S>" (dsd-name structure)))
76
77
78
79 ;;; The legendary macro itself.
80
81 (defmacro defstruct (name-and-options &rest slot-descriptions)
82 "Defstruct {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)}
83 Define the structure type Name. See the manual for details."
84 (let* ((defstruct (parse-name-and-options name-and-options))
85 (name (dd-name defstruct)))
86 (parse-slot-descriptions defstruct slot-descriptions)
87 (if (eq (dd-type defstruct) 'structure)
88 `(progn
89 (%defstruct ',defstruct)
90 (%compiler-defstruct ',defstruct)
91 ,@(define-constructors defstruct)
92 ,@(define-boa-constructors defstruct)
93 ;;
94 ;; So the print function is in the right lexical environment, and
95 ;; can be compiled...
96 ,@(let ((pf (dd-print-function defstruct)))
97 (when pf
98 `((setf (info type printer ',name)
99 ,(if (symbolp pf)
100 `',pf
101 `#',pf)))))
102 ,@(let ((mlff (dd-make-load-form-fun defstruct)))
103 (when mlff
104 `((setf (info type load-form-maker ',name)
105 ,(if (symbolp mlff)
106 `',mlff
107 `#',mlff)))))
108 ',name)
109 `(progn
110 (eval-when (compile load eval)
111 (setf (info type kind ',name) nil)
112 (setf (info type structure-info ',name) ',defstruct))
113 ,@(define-constructors defstruct)
114 ,@(define-boa-constructors defstruct)
115 ,@(define-predicate defstruct)
116 ,@(define-accessors defstruct)
117 ,@(define-copier defstruct)
118 ',name))))
119
120
121 ;;;; Parsing:
122
123 (defun parse-name-and-options (name-and-options)
124 (if (atom name-and-options)
125 (setq name-and-options (list name-and-options)))
126 (do* ((options (cdr name-and-options) (cdr options))
127 (name (car name-and-options))
128 (print-function nil)
129 (pf-supplied-p)
130 (conc-name (concat-pnames name '-))
131 (constructors '())
132 (constructor-opt-p nil)
133 (boa-constructors '())
134 (copier (concat-pnames 'copy- name))
135 (predicate (concat-pnames name '-p))
136 (include)
137 (saw-type)
138 (type 'structure)
139 (saw-named)
140 (offset 0)
141 (make-load-form-fun nil)
142 (make-load-form-fun-p nil))
143 ((null options)
144 (let ((named (if saw-type saw-named t)))
145 (make-defstruct-description
146 :name name
147 :conc-name conc-name
148 :constructors
149 (if constructor-opt-p
150 (nreverse constructors)
151 (list (concat-pnames 'make- name)))
152 :boa-constructors boa-constructors
153 :copier copier
154 :predicate predicate
155 :include include
156 :print-function print-function
157 :type type
158 :length (if named 1 0)
159 :lisp-type (cond ((eq type 'structure) 'simple-vector)
160 ((eq type 'vector) 'simple-vector)
161 ((eq type 'list) 'list)
162 ((and (listp type) (eq (car type) 'vector))
163 (cons 'simple-array (cdr type)))
164 (t (error "~S is a bad :TYPE for Defstruct." type)))
165 :named named
166 :offset offset
167 :make-load-form-fun make-load-form-fun)))
168 (if (atom (car options))
169 (case (car options)
170 (:constructor
171 (setf constructor-opt-p t)
172 (setf constructors (list (concat-pnames 'make- name))))
173 (:copier)
174 (:predicate)
175 (:named (setq saw-named t))
176 (t (error "The Defstruct option ~S cannot be used with 0 arguments."
177 (car options))))
178 (let ((option (caar options))
179 (args (cdar options)))
180 (case option
181 (:conc-name
182 (setq conc-name (car args))
183 (unless (symbolp conc-name)
184 (setq conc-name (make-symbol (string conc-name)))))
185 (:constructor
186 (setf constructor-opt-p t)
187 (let ((lambda-list (cdr args))
188 (constructor-name (car args))
189 (no-explicit-nil-name (not args)))
190 ;; Constructor-name may be nil because args has one element, the
191 ;; explicit name of nil. In this situation, don't make a
192 ;; default constructor. If args itself is nil, then we make a
193 ;; default constructor.
194 (cond (lambda-list
195 (push args boa-constructors))
196 (constructor-name
197 (push constructor-name constructors))
198 (no-explicit-nil-name
199 (push (concat-pnames 'make- name) constructors)))))
200 (:copier (setq copier (car args)))
201 (:predicate (setq predicate (car args)))
202 (:include
203 (setf include args)
204 (let* ((name (car include))
205 (included-structure
206 (info type structure-info name)))
207 (unless included-structure
208 (error "Cannot find description of structure ~S to use for ~
209 inclusion."
210 name))
211 (unless pf-supplied-p
212 (setf print-function
213 (dd-print-function included-structure)))
214 (unless make-load-form-fun-p
215 (setf make-load-form-fun
216 (dd-make-load-form-fun included-structure)))))
217 (:print-function
218 (setf print-function (car args))
219 (setf pf-supplied-p t))
220 (:type (setf saw-type t type (car args)))
221 (:named (error "The Defstruct option :NAMED takes no arguments."))
222 (:initial-offset (setf offset (car args)))
223 (:make-load-form-fun
224 (setf make-load-form-fun (car args))
225 (setf make-load-form-fun-p t))
226 (t (error "~S is an unknown Defstruct option." option)))))))
227
228
229
230 ;;;; Stuff to parse slot descriptions.
231
232 ;;; PARSE-1-DSD -- Internal
233 ;;;
234 ;;; Parse a slot description for DEFSTRUCT and add it to the description.
235 ;;; If supplied, ISLOT is a pre-initialized DSD that we modify to get the new
236 ;;; slot. This is supplied when handling included slots. If the new accessor
237 ;;; name is already an accessor for same slot in some included structure, then
238 ;;; set the DSD-ACCESSOR to NIL so that we don't clobber the more general
239 ;;; accessor.
240 ;;;
241 (defun parse-1-dsd (defstruct spec &optional
242 (islot (make-defstruct-slot-description
243 :%name "" :index 0 :type t)))
244 (multiple-value-bind
245 (name default default-p type type-p read-only ro-p)
246 (cond
247 ((listp spec)
248 (destructuring-bind (name &optional (default nil default-p)
249 &key (type nil type-p) (read-only nil ro-p))
250 spec
251 (values name default default-p type type-p read-only ro-p)))
252 (t
253 (when (keywordp spec)
254 (warn "Keyword slot name indicates possible syntax ~
255 error in DEFSTRUCT -- ~S."
256 spec))
257 spec))
258 (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name)
259 (error "Duplicate slot name ~S." name))
260 (setf (dsd-%name islot) (string name))
261 (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot)))
262
263 (let* ((aname (concat-pnames (dd-conc-name defstruct) name))
264 (existing (info function accessor-for aname)))
265 (if (and existing
266 (string= (dsd-name (find aname (dd-slots existing)
267 :key #'dsd-accessor))
268 name)
269 (member (dd-name existing) (dd-includes defstruct)))
270 (setf (dsd-accessor islot) nil)
271 (setf (dsd-accessor islot) aname)))
272
273 (when default-p
274 (setf (dsd-default islot) default))
275 (when type-p
276 (setf (dsd-type islot) type))
277 (when ro-p
278 (setf (dsd-read-only islot) read-only))
279 (setf (dsd-index islot) (dd-length defstruct))
280 (incf (dd-length defstruct)))
281 (undefined-value))
282
283
284 ;;; PARSE-SLOT-DESCRIPTIONS parses the slot descriptions (surprise) and does
285 ;;; any structure inclusion that needs to be done.
286 ;;;
287 (defun parse-slot-descriptions (defstruct slots)
288 ;; First strip off any doc string and stash it in the Defstruct.
289 (when (stringp (car slots))
290 (setf (dd-doc defstruct) (car slots))
291 (setq slots (cdr slots)))
292 ;; Then include stuff. We add unparsed items to the start of the Slots.
293 (when (dd-include defstruct)
294 (destructuring-bind (included-name &rest modified-slots)
295 (dd-include defstruct)
296 (let ((included-thing
297 (or (info type structure-info included-name)
298 (error "Cannot find description of structure ~S ~
299 to use for inclusion."
300 included-name))))
301 (setf (dd-includes defstruct)
302 (cons (dd-name included-thing) (dd-includes included-thing)))
303 (incf (dd-offset defstruct) (dd-offset included-thing))
304 (incf (dd-length defstruct) (dd-offset defstruct))
305 (dolist (islot (dd-slots included-thing))
306 (let* ((iname (dsd-name islot))
307 (modified (or (find iname modified-slots
308 :key #'(lambda (x) (if (atom x) x (car x)))
309 :test #'string=)
310 `(,iname))))
311 (parse-1-dsd defstruct modified
312 (copy-defstruct-slot-description islot)))))))
313
314 ;; Finally parse the slots into Slot-Description objects.
315 (dolist (slot slots)
316 (parse-1-dsd defstruct slot))
317 (undefined-value))
318
319
320 ;;;; Default structure access and copiers:
321 ;;;
322 ;;; In the normal case of structures that have a real type (i.e. no :Type
323 ;;; option was specified), we want to optimize things for space as well as
324 ;;; speed, since there can be thousands of defined slot accesors.
325 ;;;
326 ;;; What we do is defined the accessors and copier as closures over
327 ;;; general-case code. Since the compiler will normally open-code accesors,
328 ;;; the (minor) efficiency penalty is not a concern.
329
330 ;;; Typep-To-Structure -- Internal
331 ;;;
332 ;;; Return true if Obj is an object of the structure type specified by Info.
333 ;;; This is called by the accessor closures, which have a handle on the type's
334 ;;; Defstruct-Description.
335 ;;;
336 #+new-compiler
337 (proclaim '(inline typep-to-structure))
338 #+new-compiler
339 (defun typep-to-structure (obj info)
340 (declare (type defstruct-description info) (inline member))
341 (and (structurep obj)
342 (let ((name (structure-ref obj 0)))
343 (or (eq name (dd-name info))
344 (member name (dd-included-by info) :test #'eq)))))
345
346
347 ;;; %REDEFINE-DEFSTRUCT -- Internal
348 ;;;
349 ;;; This function is called when we are redefining a structure from Old to
350 ;;; New. If the slots are different, we flame loudly, but give the luser a
351 ;;; chance to proceed. We flame especially loudly if there are structures that
352 ;;; include this one. If proceeded, we FMAKUNBOUND all the old accessors. If
353 ;;; the redefinition is not incompatible, we make the INCLUDED-BY of the new
354 ;;; definition be the same as the old one.
355 ;;;
356 (defun %redefine-defstruct (old new)
357 (declare (type defstruct-description old new))
358 (cond
359 ((and (equalp (dd-slots old) (dd-slots new))
360 (equal (dd-includes old) (dd-includes new)))
361 (setf (dd-included-by new) (dd-included-by old)))
362 (t
363 (let ((name (dd-name old))
364 (included-by (dd-included-by old)))
365 (cerror
366 "Recklessly proceed with wanton disregard for Lisp and limb."
367 "Structure ~S is being incompatibly redefined. If proceeded, you must~@
368 recompile all uses of this structure's accessors.~:[~;~@
369 ~S is included by these structures:~
370 ~% ~S~@
371 You must also recompile these DEFSTRUCTs and all the uses of their ~
372 accessors.~]"
373 name included-by name included-by)
374
375 (dolist (slot (dd-slots old))
376 (fmakunbound (dsd-accessor slot))
377 (unless (dsd-read-only slot)
378 (fmakunbound `(setf ,(dsd-accessor slot))))))))
379
380 (undefined-value))
381
382 #+new-compiler
383 ;;; %Defstruct -- Internal
384 ;;;
385 ;;; Do miscellaneous load-time actions for the structure described by Info.
386 ;;; Define setters, accessors, copier, predicate, documentation, instantiate
387 ;;; definition in load-time env. This is only called for default structures.
388 ;;;
389 (defun %defstruct (info)
390 (declare (type defstruct-description info))
391 (let* ((name (dd-name info))
392 (old (info type defined-structure-info name)))
393 ;;
394 ;; Don't flame about dd structures, since they are hackishly defined in
395 ;; type-boot...
396 (when (and old
397 (not (member name '(defstruct-description
398 defstruct-slot-description))))
399 (%redefine-defstruct old info))
400
401 (setf (info type defined-structure-info name) info)
402 (dolist (include (dd-includes info))
403 (let ((iinfo (info type defined-structure-info include)))
404 (unless iinfo
405 (error "~S includes ~S, but it is not defined." name include))
406 (pushnew name (dd-included-by iinfo)))))
407
408 (dolist (slot (dd-slots info))
409 (let ((dsd slot))
410 (when (dsd-accessor slot)
411 (setf (symbol-function (dsd-accessor slot))
412 #'(lambda (structure)
413 (declare (optimize (speed 3) (safety 0)))
414 (unless (typep-to-structure structure info)
415 (error "Structure for accessor ~S is not a ~S:~% ~S"
416 (dsd-accessor dsd) (dd-name info) structure))
417 (structure-ref structure (dsd-index dsd))))
418
419 (unless (dsd-read-only slot)
420 (setf (fdefinition `(setf ,(dsd-accessor slot)))
421 #'(lambda (new-value structure)
422 (declare (optimize (speed 3) (safety 0)))
423 (unless (typep-to-structure structure info)
424 (error "Structure for setter ~S is not a ~S:~% ~S"
425 `(setf ,(dsd-accessor dsd)) (dd-name info)
426 structure))
427 (unless (typep new-value (dsd-type dsd))
428 (error "New-Value for setter ~S is not a ~S:~% ~S."
429 `(setf ,(dsd-accessor dsd)) (dsd-type dsd)
430 new-value))
431 (setf (structure-ref structure (dsd-index dsd))
432 new-value)))))))
433
434 (when (dd-predicate info)
435 (setf (symbol-function (dd-predicate info))
436 #'(lambda (object)
437 (declare (optimize (speed 3) (safety 0)))
438 (if (typep-to-structure object info) t nil))))
439
440 (when (dd-copier info)
441 (setf (symbol-function (dd-copier info))
442 #'(lambda (structure)
443 (declare (optimize (speed 3) (safety 0)))
444 (unless (typep-to-structure structure info)
445 (error "Structure for copier ~S is not a ~S:~% ~S"
446 (dd-copier info) (dd-name info) structure))
447
448 (let* ((len (dd-length info))
449 (res (make-structure len)))
450 (declare (type structure-index len))
451 (dotimes (i len)
452 (declare (type structure-index i))
453 (setf (structure-ref res i)
454 (structure-ref structure i)))
455 res))))
456 (when (dd-doc info)
457 (setf (documentation (dd-name info) 'type) (dd-doc info))))
458
459
460 ;;; Define-Accessors returns a list of function definitions for accessing and
461 ;;; setting the slots of the a typed Defstruct. The functions are proclaimed
462 ;;; to be inline, and the types of their arguments and results are declared as
463 ;;; well. We count on the compiler to do clever things with Elt.
464
465 (defun define-accessors (defstruct)
466 (do ((slots (dd-slots defstruct) (cdr slots))
467 (stuff '())
468 (type (dd-lisp-type defstruct)))
469 ((null slots) stuff)
470 (let* ((slot (car slots))
471 (name (dsd-accessor slot))
472 (index (dsd-index slot))
473 (slot-type (dsd-type slot)))
474 (push
475 `(progn
476 (proclaim '(inline ,name (setf ,name)))
477 (defun ,name (structure)
478 (declare (type ,type structure))
479 (the ,slot-type (elt structure ,index)))
480 ,@(unless (dsd-read-only slot)
481 `((defun (setf ,name) (new-value structure)
482 (declare (type ,type structure) (type ,slot-type new-value))
483 (setf (elt structure ,index) new-value)))))
484 stuff))))
485
486
487 ;;; Define-Constructors returns a definition for the constructor function of
488 ;;; the given Defstruct. If the structure is implemented as a vector and is
489 ;;; named, we structurify it. If the structure is a vector of some specialized
490 ;;; type, we can't use the Vector function.
491 ;;;
492 (defun define-constructors (defstruct)
493 (let ((cons-names (dd-constructors defstruct)))
494 (when cons-names
495 (let* ((name (first cons-names))
496 (initial-cruft
497 (if (dd-named defstruct)
498 (make-list (1+ (dd-offset defstruct))
499 :initial-element `',(dd-name defstruct))
500 (make-list (dd-offset defstruct))))
501 (slots (dd-slots defstruct))
502 (names (mapcar #'dsd-name slots))
503 (args (mapcar #'(lambda (slot)
504 `(,(dsd-name slot) ,(dsd-default slot)))
505 slots)))
506 `((defun ,name ,(if args `(&key ,@args))
507 (declare
508 ,@(mapcar #'(lambda (slot)
509 `(type ,(dsd-type slot) ,(dsd-name slot)))
510 slots))
511 ,(case (dd-type defstruct)
512 (list
513 `(list ,@initial-cruft ,@names))
514 (structure
515 (let ((temp (gensym)))
516 `(let ((,temp (make-structure ,(dd-length defstruct))))
517 (declare (type structure ,temp))
518 (setf (structure-ref ,temp 0) ',(dd-name defstruct))
519 ,@(mapcar #'(lambda (slot)
520 `(setf (structure-ref ,temp
521 ,(dsd-index slot))
522 ,(dsd-name slot)))
523 slots)
524 (truly-the ,(dd-name defstruct) ,temp))))
525 (vector
526 `(vector ,@initial-cruft ,@names))
527 (t
528 (do ((sluts slots (cdr sluts))
529 (sets '())
530 (temp (gensym)))
531 ((null sluts)
532 `(let ((,temp (make-array
533 ,(dd-length defstruct)
534 :element-type
535 ',(cadr (dd-lisp-type defstruct)))))
536 ,@(when (dd-named defstruct)
537 `(setf (aref ,temp ,(dd-offset defstruct))
538 ',(dd-name defstruct)))
539 ,@sets
540 ,temp))
541 (let ((slot (car sluts)))
542 (push `(setf (aref ,temp ,(dsd-index slot))
543 ,(dsd-name slot))
544 sets))))))
545 ,@(mapcar #'(lambda (other-name)
546 `(setf (fdefinition ',other-name) #',name))
547 (rest cons-names)))))))
548
549
550 ;;;; Support for By-Order-Argument Constructors.
551
552 ;;; FIND-LEGAL-SLOT -- Internal
553 ;;;
554 ;;; Given a defstruct description and a slot name, return the corresponding
555 ;;; slot if it exists, or signal an error if not.
556 ;;;
557 (defun find-legal-slot (defstruct name)
558 (or (find name (dd-slots defstruct) :key #'dsd-name :test #'string=)
559 (error "~S is not a defined slot name in the ~S structure."
560 name (dd-name defstruct))))
561
562
563 ;;; Define-Boa-Constructors defines positional constructor functions. We
564 ;;; generate code to set each variable not specified in the arglist to the
565 ;;; default given in the Defstruct. We just slap required args in, as with
566 ;;; rest args and aux args. Optionals are treated a little differently. Those
567 ;;; that aren't supplied with a default in the arg list are mashed so that
568 ;;; their default in the arglist is the corresponding default from the
569 ;;; Defstruct.
570 ;;;
571 (defun define-boa-constructors (defstruct)
572 (do* ((boas (dd-boa-constructors defstruct) (cdr boas))
573 (name (car (car boas)) (car (car boas)))
574 (args (copy-list (cadr (car boas))) (copy-list (cadr (car boas))))
575 (slots (dd-slots defstruct) (dd-slots defstruct))
576 (slots-in-arglist '() '())
577 (defuns '()))
578 ((null boas) defuns)
579 ;; Find the slots in the arglist and hack the defaultless optionals.
580 (do ((args args (cdr args))
581 (arg-kind 'required))
582 ((null args))
583 (let ((arg (car args)))
584 (cond ((not (atom arg))
585 (push (find-legal-slot defstruct (car arg)) slots-in-arglist))
586 ((member arg '(&optional &rest &aux &key) :test #'eq)
587 (setq arg-kind arg))
588 (t
589 (case arg-kind
590 ((required &rest &aux)
591 (push (find-legal-slot defstruct arg) slots-in-arglist))
592 ((&optional &key)
593 (let ((dsd (find-legal-slot defstruct arg)))
594 (push dsd slots-in-arglist)
595 (rplaca args (list arg (dsd-default dsd))))))))))
596
597 ;; Then make a list that can be used with a (list ...) or (vector...).
598 (let ((initial-cruft
599 (if (dd-named defstruct)
600 (make-list (1+ (dd-offset defstruct))
601 :initial-element `',(dd-name defstruct))
602 (make-list (dd-offset defstruct))))
603 (thing (mapcar #'(lambda (slot)
604 (if (member slot slots-in-arglist
605 :test #'eq)
606 (dsd-name slot)
607 (dsd-default slot)))
608 slots)))
609 (push
610 `(defun ,name ,args
611 (declare
612 ,@(mapcar #'(lambda (slot)
613 `(type ,(dsd-type slot) ,(dsd-name slot)))
614 slots-in-arglist))
615 ,(case (dd-type defstruct)
616 (list
617 `(list ,@initial-cruft ,@thing))
618 (structure
619 (let ((temp (gensym)))
620 `(let ((,temp (make-structure ,(dd-length defstruct))))
621 (declare (type structure ,temp))
622 (setf (structure-ref ,temp 0) ',(dd-name defstruct))
623 ,@(mapcar #'(lambda (slot thing)
624 `(setf (structure-ref ,temp
625 ,(dsd-index slot))
626 ,thing))
627 slots thing)
628 (truly-the ,(dd-name defstruct) ,temp))))
629 (vector
630 `(vector ,@initial-cruft ,@thing))
631 (t
632 (do ((things thing (cdr things))
633 (index 0 (1+ index))
634 (sets '())
635 (temp (gensym)))
636 ((null things)
637 `(let ((,temp (make-array
638 ,(dd-length defstruct)
639 :element-type
640 ',(cadr (dd-lisp-type defstruct)))))
641 ,@(when (dd-named defstruct)
642 `(setf (aref ,temp ,(dd-offset defstruct))
643 ',(dd-name defstruct)))
644 ,@sets
645 ,temp))
646 (push `(setf (aref ,temp index) ,(car things))
647 sets)))))
648 defuns))))
649
650 ;;; Define-Copier returns the definition for a copier function of a typed
651 ;;; Defstruct if one is desired.
652
653 (defun define-copier (defstruct)
654 (when (dd-copier defstruct)
655 `((defun ,(dd-copier defstruct) (structure)
656 (declare (type ,(dd-lisp-type defstruct) structure))
657 (subseq structure 0 ,(dd-length defstruct))))))
658
659
660 ;;; Define-Predicate returns a definition for a predicate function if one is
661 ;;; desired. This is only called for typed structures, since the default
662 ;;; structure predicate is implemented as a closure.
663
664 (defun define-predicate (defstruct)
665 (let ((name (dd-name defstruct))
666 (pred (dd-predicate defstruct)))
667 (when (and pred (dd-named defstruct))
668 (let ((ltype (dd-lisp-type defstruct)))
669 `((defun ,pred (object)
670 (and (typep object ',ltype)
671 (eq (elt (the ,ltype object) ,(dd-offset defstruct))
672 ',name))))))))
673
674
675 ;;; Random sorts of stuff.
676
677 (defun default-structure-print (structure stream depth)
678 (declare (ignore depth))
679 (let* ((type (structure-ref structure 0))
680 (dd (info type defined-structure-info type)))
681 (cond (*print-pretty*
682 (pprint-logical-block (stream structure :allow-atoms t
683 :prefix "#S(" :suffix ")")
684 (prin1 type stream)
685 (let ((slots (dd-slots dd)))
686 (when slots
687 (write-char #\space stream)
688 (pprint-indent :block 2 stream)
689 (pprint-newline :linear stream)
690 (loop
691 (pprint-pop)
692 (let ((slot (pop slots)))
693 (write-char #\: stream)
694 (output-symbol-name (dsd-%name slot) stream)
695 (write-char #\space stream)
696 (pprint-newline :miser stream)
697 (output-object (structure-ref structure (dsd-index slot))
698 stream)
699 (when (null slots)
700 (return))
701 (write-char #\space stream)
702 (pprint-newline :linear stream)))))))
703 (t
704 (write-string "#S(" stream)
705 (prin1 type stream)
706 (do ((index 1 (1+ index))
707 (length (structure-length structure))
708 (slots (dd-slots dd) (cdr slots)))
709 ((or (= index length)
710 (and *print-length*
711 (= index *print-length*)))
712 (if (= index length)
713 (write-string ")" stream)
714 (write-string "...)" stream)))
715 (declare (type index index))
716 (write-char #\space stream)
717 (write-char #\: stream)
718 (output-symbol-name (dsd-%name (car slots)) stream)
719 (write-char #\space stream)
720 (output-object (structure-ref structure index) stream))))))
721
722
723 (defun make-structure-load-form (structure)
724 (declare (type structure structure))
725 (let* ((type (structure-ref structure 0))
726 (fun (info type load-form-maker type)))
727 (etypecase fun
728 ((member :just-dump-it-normally :ignore-it)
729 fun)
730 (null
731 (error "Structures of type ~S cannot be dumped as constants." type))
732 (function
733 (funcall fun structure))
734 (symbol
735 (funcall (symbol-function fun) structure)))))

  ViewVC Help
Powered by ViewVC 1.1.5