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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5