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

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5