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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.16 - (hide annotations)
Wed Oct 17 03:47:59 1990 UTC (23 years, 6 months ago) by ram
Branch: MAIN
Changes since 1.15: +10 -4 lines
Changed %REDEFINE-DEFSTRUCT to copy the old INCLUDED-BY into the new
DD when the redefinition is not incompatible.  This precents
recompiling and loading of DEFSTRUCT STREAM from blowing the system
out of the water, etc.
1 ram 1.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 ram 1.16 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/defstruct.lisp,v 1.16 1990/10/17 03:47:59 ram Exp $
11 wlott 1.9 ;;;
12 ram 1.1 ;;; 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 wlott 1.13
19     ;;;; Structure frobbing primitives.
20    
21 wlott 1.9 ;;; Note: STRUCTURIFY is defined in struct.lisp. It converts a simple-vector
22 wlott 1.13 ;;; into a structure. It should go away when we have a real structure
23     ;;; allocation primitive.
24 ram 1.1
25 wlott 1.13 (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 wlott 1.14 (structure-ref struct index))
35 wlott 1.13
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 ram 1.1
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 ram 1.5
63    
64 ram 1.1
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 ram 1.15 (%defstruct ',defstruct)
82 ram 1.1 (%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 ram 1.15 ,@(let ((pf (dd-print-function defstruct)))
89     (when pf
90     `((setf (info type printer ',name)
91     ,(if (symbolp pf)
92     `',pf
93     `#',pf)))))
94 ram 1.1 ',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 ram 1.6 (print-function nil)
117 ram 1.5 (pf-supplied-p)
118 ram 1.1 (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 ram 1.5 (setq constructor
168     (or (car args)
169     (concat-pnames 'make- name))))))
170 ram 1.1 (:copier (setq copier (car args)))
171     (:predicate (setq predicate (car args)))
172 ram 1.5 (:include
173     (setf include args)
174     (let* ((name (car include))
175     (included-structure
176 ram 1.7 (info type structure-info name))
177 ram 1.5 (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 ram 1.6 (setf print-function (car args))
188 ram 1.5 (setf pf-supplied-p t))
189     (:type (setf saw-type t type (car args)))
190 ram 1.1 (:named (error "The Defstruct option :NAMED takes no arguments."))
191 ram 1.5 (:initial-offset (setf offset (car args)))
192 ram 1.1 (t (error "~S is an unknown Defstruct option." option)))))))
193 ram 1.5
194    
195 ram 1.1
196 ram 1.5 ;;;; Stuff to parse slot descriptions.
197    
198     ;;; PARSE-SLOT-DESCRIPTIONS parses the slot descriptions (surprise) and does
199 ram 1.1 ;;; any structure inclusion that needs to be done.
200 ram 1.5 ;;;
201 ram 1.1 (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 ram 1.5 (index (+ (dd-offset defstruct) (if (dd-named defstruct) 1 0))
250     (1+ index))
251     (descriptions ()))
252 ram 1.1 ((null slots)
253     (setf (dd-length defstruct) index)
254     (setf (dd-slots defstruct) (nreverse descriptions)))
255 ram 1.5 (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 ram 1.1 (push
262     (if (atom slot)
263 ram 1.5 (make-defstruct-slot-description
264     :%name (string name)
265     :index index
266     :accessor (concat-pnames (dd-conc-name defstruct) name)
267     :type t)
268 ram 1.1 (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 wlott 1.9 #+new-compiler
304 ram 1.1 (proclaim '(inline typep-to-structure))
305 wlott 1.9 #+new-compiler
306 ram 1.1 (defun typep-to-structure (obj info)
307     (declare (type defstruct-description info) (inline member))
308     (and (structurep obj)
309 wlott 1.13 (let ((name (structure-ref obj 0)))
310 ram 1.1 (or (eq name (dd-name info))
311     (member name (dd-included-by info) :test #'eq)))))
312    
313 ram 1.15
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 ram 1.16 ;;; include this one. If proceeded, we FMAKUNBOUND all the old accessors. If
320     ;;; the redefinition is not incompatible, we make the INCLUDED-BY of the new
321     ;;; definition be the same as the old one.
322 ram 1.15 ;;;
323     (defun %redefine-defstruct (old new)
324     (declare (type defstruct-description old new))
325 ram 1.16 (cond
326     ((and (equalp (dd-slots old) (dd-slots new))
327     (equal (dd-includes old) (dd-includes new)))
328     (setf (dd-included-by new) (dd-included-by old)))
329     (t
330 ram 1.15 (let ((name (dd-name old))
331     (included-by (dd-included-by old)))
332     (cerror
333     "Recklessly proceed with wanton disregard for Lisp and limb."
334     "Structure ~S is being incompatibly redefined. If proceeded, you must~@
335     recompile all uses this structure's accessors.~:[~;~@
336     ~S is included by these structures:~
337     ~% ~S~@
338     You must also recompile these DEFSTRUCTs and all the uses of their ~
339     accessors.~]"
340     name included-by name included-by)
341    
342     (dolist (slot (dd-slots old))
343     (fmakunbound (dsd-accessor slot))
344     (unless (dsd-read-only slot)
345 ram 1.16 (fmakunbound `(setf ,(dsd-accessor slot))))))))
346 ram 1.15
347     (undefined-value))
348    
349 ram 1.1 #+new-compiler
350     ;;; %Defstruct -- Internal
351     ;;;
352     ;;; Do miscellaneous load-time actions for the structure described by Info.
353     ;;; Define setters, accessors, copier, predicate, documentation, instantiate
354     ;;; definition in load-time env. This is only called for default structures.
355     ;;;
356     (defun %defstruct (info)
357     (declare (type defstruct-description info))
358 ram 1.15 (let* ((name (dd-name info))
359     (old (info type defined-structure-info name)))
360     ;;
361     ;; Don't flame about dd structures, since they are hackishly defined in
362     ;; type-boot...
363     (when (and old
364     (not (member name '(defstruct-description
365     defstruct-slot-description))))
366     (%redefine-defstruct old info))
367    
368     (setf (info type defined-structure-info name) info)
369     (dolist (include (dd-includes info))
370     (let ((iinfo (info type defined-structure-info include)))
371     (unless iinfo
372     (error "~S includes ~S, but it is not defined." name include))
373     (pushnew name (dd-included-by iinfo)))))
374    
375 ram 1.1 (dolist (slot (dd-slots info))
376     (let ((dsd slot))
377     (setf (symbol-function (dsd-accessor slot))
378     #'(lambda (structure)
379     (declare (optimize (speed 3) (safety 0)))
380     (unless (typep-to-structure structure info)
381     (error "Structure for accessor ~S is not a ~S:~% ~S"
382     (dsd-accessor dsd) (dd-name info) structure))
383 wlott 1.13 (structure-ref structure (dsd-index dsd))))
384 ram 1.1
385     (unless (dsd-read-only slot)
386     (setf (fdefinition `(setf ,(dsd-accessor slot)))
387 wlott 1.10 #'(lambda (new-value structure)
388 ram 1.1 (declare (optimize (speed 3) (safety 0)))
389     (unless (typep-to-structure structure info)
390     (error "Structure for setter ~S is not a ~S:~% ~S"
391     `(setf ,(dsd-accessor dsd)) (dd-name info)
392     structure))
393     (unless (typep new-value (dsd-type dsd))
394     (error "New-Value for setter ~S is not a ~S:~% ~S."
395     `(setf ,(dsd-accessor dsd)) (dsd-type dsd)
396     new-value))
397 wlott 1.13 (setf (structure-ref structure (dsd-index dsd))
398     new-value))))))
399 ram 1.1
400     (when (dd-predicate info)
401     (setf (symbol-function (dd-predicate info))
402     #'(lambda (object)
403     (declare (optimize (speed 3) (safety 0)))
404     (if (typep-to-structure object info) t nil))))
405    
406     (when (dd-copier info)
407     (setf (symbol-function (dd-copier info))
408     #'(lambda (structure)
409     (declare (optimize (speed 3) (safety 0)))
410     (unless (typep-to-structure structure info)
411     (error "Structure for copier ~S is not a ~S:~% ~S"
412     (dd-copier info) (dd-name info) structure))
413    
414     (let ((len (dd-length info)))
415     (declare (fixnum len))
416     (do ((i 1 (1+ i))
417 wlott 1.13 (res (structurify (%primitive alloc-g-vector len nil))))
418 ram 1.1 ((= i len)
419 wlott 1.13 (setf (structure-ref res 0) (dd-name info))
420     res)
421 ram 1.1 (declare (fixnum i))
422 wlott 1.13 (setf (structure-ref res i)
423     (structure-ref structure i)))))))
424 ram 1.1 (when (dd-doc info)
425     (setf (documentation (dd-name info) 'type) (dd-doc info))))
426    
427    
428     ;;; Define-Accessors returns a list of function definitions for accessing and
429     ;;; setting the slots of the a typed Defstruct. The functions are proclaimed
430     ;;; to be inline, and the types of their arguments and results are declared as
431     ;;; well. We count on the compiler to do clever things with Elt.
432    
433     (defun define-accessors (defstruct)
434     (do ((slots (dd-slots defstruct) (cdr slots))
435     (stuff '())
436     (type (dd-lisp-type defstruct)))
437     ((null slots) stuff)
438     (let* ((slot (car slots))
439     (name (dsd-accessor slot))
440     (index (dsd-index slot))
441     (slot-type (dsd-type slot)))
442     (push
443     `(progn
444     (proclaim '(inline ,name (setf ,name)))
445     (defun ,name (structure)
446     (declare (type ,type structure))
447     (the ,slot-type (elt structure ,index)))
448     ,@(unless (dsd-read-only slot)
449 wlott 1.9 `((defun (setf ,name) (new-value structure)
450 ram 1.1 (declare (type ,type structure) (type ,slot-type new-value))
451     (setf (elt structure ,index) new-value)))))
452     stuff))))
453    
454    
455     ;;; Define-Constructor returns a definition for the constructor function of the
456     ;;; given Defstruct. If the structure is implemented as a vector and is named,
457     ;;; we structurify it. If the structure is a vector of some specialized type,
458     ;;; we can't use the Vector function.
459     ;;;
460     ;;; If we are defining safe accessors, we also check the types of the values to
461     ;;; make sure that they are legal.
462     ;;;
463     (defun define-constructor (defstruct)
464     (let ((name (dd-constructor defstruct)))
465     (when name
466     (let* ((initial-cruft
467     (if (dd-named defstruct)
468     (make-list (1+ (dd-offset defstruct))
469     :initial-element `',(dd-name defstruct))
470     (make-list (dd-offset defstruct))))
471     (slots (dd-slots defstruct))
472     (names (mapcar #'dsd-name slots))
473     (args (mapcar #'(lambda (slot)
474     `(,(dsd-name slot) ,(dsd-default slot)))
475     slots)))
476     `((defun ,name ,(if args `(&key ,@args))
477     (declare
478     ,@(mapcar #'(lambda (slot)
479     `(type ,(dsd-type slot) ,(dsd-name slot)))
480     slots))
481     ,(case (dd-type defstruct)
482     (list
483     `(list ,@initial-cruft ,@names))
484     (structure
485     `(truly-the ,(dd-name defstruct)
486     (structurify
487     (vector ,@initial-cruft ,@names))))
488     (vector
489     `(vector ,@initial-cruft ,@names))
490     (t
491     (do ((sluts slots (cdr sluts))
492     (sets '())
493     (temp (gensym)))
494     ((null sluts)
495     `(let ((,temp (make-array
496     ,(dd-length defstruct)
497     :element-type
498     ',(cadr (dd-lisp-type defstruct)))))
499     ,@(when (dd-named defstruct)
500     `(setf (aref ,temp ,(dd-offset defstruct))
501     ',(dd-name defstruct)))
502     ,@sets
503     ,temp))
504     (let ((slot (car sluts)))
505     (push `(setf (aref ,temp ,(dsd-index slot))
506     ,(dsd-name slot))
507     sets)))))))))))
508 ram 1.5
509    
510 ram 1.1
511 ram 1.5 ;;;; Support for By-Order-Argument Constructors.
512    
513     ;;; FIND-LEGAL-SLOT -- Internal
514 ram 1.1 ;;;
515     ;;; Given a defstruct description and a slot name, return the corresponding
516     ;;; slot if it exists, or signal an error if not.
517     ;;;
518     (defun find-legal-slot (defstruct name)
519     (or (find name (dd-slots defstruct) :key #'dsd-name :test #'string=)
520     (error "~S is not a defined slot name in the ~S structure."
521     name (dd-name defstruct))))
522    
523 ram 1.5
524     ;;; Define-Boa-Constructors defines positional constructor functions. We
525     ;;; generate code to set each variable not specified in the arglist to the
526     ;;; default given in the Defstruct. We just slap required args in, as with
527     ;;; rest args and aux args. Optionals are treated a little differently. Those
528     ;;; that aren't supplied with a default in the arg list are mashed so that
529     ;;; their default in the arglist is the corresponding default from the
530     ;;; Defstruct.
531 ram 1.1 ;;;
532     (defun define-boa-constructors (defstruct)
533     (do* ((boas (dd-boa-constructors defstruct) (cdr boas))
534     (name (car (car boas)) (car (car boas)))
535     (args (copy-list (cadr (car boas))) (copy-list (cadr (car boas))))
536     (slots (dd-slots defstruct) (dd-slots defstruct))
537     (slots-in-arglist '() '())
538     (defuns '()))
539     ((null boas) defuns)
540     ;; Find the slots in the arglist and hack the defaultless optionals.
541     (do ((args args (cdr args))
542     (arg-kind 'required))
543     ((null args))
544     (let ((arg (car args)))
545 ram 1.5 (cond ((not (atom arg))
546     (push (find-legal-slot defstruct (car arg)) slots-in-arglist))
547 wlott 1.9 ((member arg '(&optional &rest &aux &key) :test #'eq)
548 ram 1.5 (setq arg-kind arg))
549     (t
550     (case arg-kind
551     ((required &rest &aux)
552     (push (find-legal-slot defstruct arg) slots-in-arglist))
553     ((&optional &key)
554     (let ((dsd (find-legal-slot defstruct arg)))
555     (push dsd slots-in-arglist)
556     (rplaca args (list arg (dsd-default dsd))))))))))
557 ram 1.1
558 ram 1.5 ;; Then make a list that can be used with a (list ...) or (vector...).
559 ram 1.1 (let ((initial-cruft
560     (if (dd-named defstruct)
561     (make-list (1+ (dd-offset defstruct))
562     :initial-element `',(dd-name defstruct))
563     (make-list (dd-offset defstruct))))
564     (thing (mapcar #'(lambda (slot)
565 wlott 1.9 (if (member slot slots-in-arglist
566     :test #'eq)
567 ram 1.1 (dsd-name slot)
568     (dsd-default slot)))
569     slots)))
570     (push
571     `(defun ,name ,args
572     (declare
573     ,@(mapcar #'(lambda (slot)
574     `(type ,(dsd-type slot) ,(dsd-name slot)))
575     slots-in-arglist))
576     ,(case (dd-type defstruct)
577     (list
578     `(list ,@initial-cruft ,@thing))
579     (structure
580     `(truly-the ,(dd-name defstruct)
581     (structurify (vector ,@initial-cruft ,@thing))))
582     (vector
583     `(vector ,@initial-cruft ,@thing))
584     (t
585     (do ((things thing (cdr things))
586     (index 0 (1+ index))
587     (sets '())
588     (temp (gensym)))
589     ((null things)
590     `(let ((,temp (make-array
591     ,(dd-length defstruct)
592     :element-type
593     ',(cadr (dd-lisp-type defstruct)))))
594     ,@(when (dd-named defstruct)
595     `(setf (aref ,temp ,(dd-offset defstruct))
596     ',(dd-name defstruct)))
597     ,@sets
598     ,temp))
599     (push `(setf (aref ,temp index) ,(car things))
600     sets)))))
601     defuns))))
602    
603     ;;; Define-Copier returns the definition for a copier function of a typed
604     ;;; Defstruct if one is desired.
605    
606     (defun define-copier (defstruct)
607     (when (dd-copier defstruct)
608     `((defun ,(dd-copier defstruct) (structure)
609     (declare (type ,(dd-lisp-type defstruct) structure))
610     (subseq structure 0 ,(dd-length defstruct))))))
611    
612    
613     ;;; Define-Predicate returns a definition for a predicate function if one is
614     ;;; desired. This is only called for typed structures, since the default
615     ;;; structure predicate is implemented as a closure.
616    
617 ram 1.7 (defun define-predicate (defstruct)
618 ram 1.1 (let ((name (dd-name defstruct))
619     (pred (dd-predicate defstruct)))
620     (when (and pred (dd-named defstruct))
621     (let ((ltype (dd-lisp-type defstruct)))
622     `((defun ,pred (object)
623     (and (typep object ',ltype)
624     (eq (elt (the ,ltype object) ,(dd-offset defstruct))
625     ',name))))))))
626    
627    
628     ;;; Structure-Predicate -- Internal
629     ;;;
630     ;;; The typep transform in typetran calls this function when it encounters
631     ;;; an unknown symbol type specifier. If the referred-to type is in fact a
632     ;;; structure type that has a predicate, then we open-code the normal case of
633     ;;; an exact match, and otherwise call the predicate.
634     ;;;
635     (defun structure-predicate (object type)
636     (let ((def (info type structure-info type)))
637     (if (and def (eq (dd-type def) 'structure) (dd-predicate def))
638     `(and (structurep ,object)
639 wlott 1.13 (if (eq (structure-ref ,object 0) ',type)
640 ram 1.8 t
641 ram 1.1 (,(dd-predicate def) ,object)))
642     `(lisp::structure-typep ,object ',type))))
643    
644    
645     ;;; Random sorts of stuff.
646    
647     (defun default-structure-print (structure stream depth)
648     (declare (ignore depth))
649 wlott 1.13 (let* ((type (structure-ref structure 0))
650 wlott 1.11 (dd (info type defined-structure-info type)))
651     (cond (*print-pretty*
652     (let ((index 0))
653     (declare (type index index))
654     (xp:pprint-logical-block (stream (cons type (dd-slots dd))
655     :prefix "#S("
656     :suffix ")")
657     (prin1 (xp:pprint-pop) stream)
658     (xp:pprint-exit-if-list-exhausted)
659     (write-char #\space stream)
660     (xp:pprint-indent :current 0 stream)
661     (loop
662     (prin1 (dsd-name (xp:pprint-pop)) stream)
663     (write-char #\space stream)
664     (xp:pprint-newline :miser stream)
665 wlott 1.13 (prin1 (structure-ref structure (incf index)) stream)
666 wlott 1.11 (xp:pprint-exit-if-list-exhausted)
667     (write-char #\space stream)
668     (xp:pprint-newline :linear stream)))))
669     (t
670     (write-string "#S(" stream)
671     (prin1 type stream)
672     (do ((index 1 (1+ index))
673 wlott 1.13 (length (structure-length structure))
674 wlott 1.11 (slots (dd-slots dd) (cdr slots)))
675     ((or (= index length)
676     (and *print-length*
677     (= index *print-length*)))
678     (if (= index length)
679     (write-string ")" stream)
680     (write-string "...)" stream)))
681     (declare (type index index))
682     (write-char #\space stream)
683     (prin1 (dsd-name (car slots)) stream)
684     (write-char #\space stream)
685 wlott 1.13 (prin1 (structure-ref structure index) stream))))))

  ViewVC Help
Powered by ViewVC 1.1.5