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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5