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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5