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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5