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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5