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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5