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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5