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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5