/[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 - (hide 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 ram 1.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 wlott 1.2.1.1 ;;; $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 ram 1.1 ;;; 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 ram 1.2 ;;;
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 ram 1.1
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 wlott 1.2.1.1 (let ((name (%primitive structure-ref obj 0)))
265 ram 1.1 (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 wlott 1.2.1.1 (%primitive structure-set res 0 (dd-name info))
322 ram 1.1 (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 wlott 1.2.1.1 (or (eq (%primitive structure-ref ,object 0) ',type)
540 ram 1.1 (,(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