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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5