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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5