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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5