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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5