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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5