source: trunk/abcl/src/org/armedbear/lisp/defstruct.lisp @ 13451

Last change on this file since 13451 was 13451, checked in by ehuelsmann, 10 years ago

Use pre-compiled closures to populate the reader/writer accessors
for structures. In order to make sure they are pre-compiled in our
build too, compile defstruct.lisp earlier in the compilation phase.

(Saves roughly 20s on my compilation runs.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 27.7 KB
Line 
1;;; defstruct.lisp
2;;;
3;;; Copyright (C) 2003-2007 Peter Graves <peter@armedbear.org>
4;;; $Id: defstruct.lisp 13451 2011-08-07 22:11:31Z ehuelsmann $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package "SYSTEM")
33
34(export 'compiler-defstruct)
35
36;;; DEFSTRUCT-DESCRIPTION
37
38(defmacro dd-name (x)                `(aref ,x  0))
39(defmacro dd-conc-name (x)           `(aref ,x  1))
40(defmacro dd-default-constructor (x) `(aref ,x  2))
41(defmacro dd-constructors (x)        `(aref ,x  3))
42(defmacro dd-copier (x)              `(aref ,x  4))
43(defmacro dd-include (x)             `(aref ,x  5))
44(defmacro dd-type (x)                `(aref ,x  6))
45(defmacro dd-named (x)               `(aref ,x  7))
46(defmacro dd-initial-offset (x)      `(aref ,x  8))
47(defmacro dd-predicate (x)           `(aref ,x  9))
48(defmacro dd-print-function (x)      `(aref ,x 10))
49(defmacro dd-print-object (x)        `(aref ,x 11))
50(defmacro dd-direct-slots (x)        `(aref ,x 12))
51(defmacro dd-slots (x)               `(aref ,x 13))
52(defmacro dd-inherited-accessors (x) `(aref ,x 14))
53
54(defun make-defstruct-description (&key name
55                                        conc-name
56                                        default-constructor
57                                        constructors
58                                        copier
59                                        include
60                                        type
61                                        named
62                                        initial-offset
63                                        predicate
64                                        print-function
65                                        print-object
66                                        direct-slots
67                                        slots
68                                        inherited-accessors)
69  (let ((dd (make-array 15)))
70    (setf (dd-name dd) name
71          (dd-conc-name dd) conc-name
72          (dd-default-constructor dd) default-constructor
73          (dd-constructors dd) constructors
74          (dd-copier dd) copier
75          (dd-include dd) include
76          (dd-type dd) type
77          (dd-named dd) named
78          (dd-initial-offset dd) initial-offset
79          (dd-predicate dd) predicate
80          (dd-print-function dd) print-function
81          (dd-print-object dd) print-object
82          (dd-direct-slots dd) direct-slots
83          (dd-slots dd) slots
84          (dd-inherited-accessors dd) inherited-accessors)
85    dd))
86
87;;; DEFSTRUCT-SLOT-DESCRIPTION
88
89(defmacro dsd-name (x)      `(aref ,x 1))
90(defmacro dsd-index (x)     `(aref ,x 2))
91(defmacro dsd-reader (x)    `(aref ,x 3))
92(defmacro dsd-initform (x)  `(aref ,x 4))
93(defmacro dsd-type (x)      `(aref ,x 5))
94(defmacro dsd-read-only (x) `(aref ,x 6))
95
96(defun make-defstruct-slot-description (&key name
97                                             index
98                                             reader
99                                             initform
100                                             (type t)
101                                             read-only)
102  (let ((dsd (make-array 7)))
103    (setf (aref dsd 0) 'defstruct-slot-description
104          (dsd-name dsd) name
105          (dsd-index dsd) index
106          (dsd-reader dsd) reader
107          (dsd-initform dsd) initform
108          (dsd-type dsd) type
109          (dsd-read-only dsd) read-only)
110    dsd))
111
112(defvar *dd-name*)
113(defvar *dd-conc-name*)
114(defvar *dd-default-constructor*)
115(defvar *dd-constructors*)
116(defvar *dd-copier*)
117(defvar *dd-include*)
118(defvar *dd-type*)
119(defvar *dd-default-slot-type* t)
120(defvar *dd-named*)
121(defvar *dd-initial-offset*)
122(defvar *dd-predicate*)
123(defvar *dd-print-function*)
124(defvar *dd-print-object*)
125(defvar *dd-direct-slots*)
126(defvar *dd-slots*)
127(defvar *dd-inherited-accessors*)
128
129(defun keywordify (symbol)
130  (intern (symbol-name symbol) +keyword-package+))
131
132(defun define-keyword-constructor (constructor)
133  (let* ((constructor-name (car constructor))
134         (keys ())
135         (values ()))
136    (dolist (slot *dd-slots*)
137      (let ((name (dsd-name slot))
138            (initform (dsd-initform slot)))
139        (if (or name (dsd-reader slot))
140            (let ((dummy (gensym)))
141              (push (list (list (keywordify name) dummy) initform) keys)
142              (push dummy values))
143            (push initform values))))
144    (setf keys (cons '&key (nreverse keys))
145          values (nreverse values))
146    (cond ((eq *dd-type* 'list)
147           `((defun ,constructor-name ,keys
148               (list ,@values))))
149          ((or (eq *dd-type* 'vector)
150               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
151           (let ((element-type (if (consp *dd-type*) (cadr *dd-type*) t)))
152             `((defun ,constructor-name ,keys
153                 (make-array ,(length values)
154                             :element-type ',element-type
155                             :initial-contents (list ,@values))))))
156          ((<= 1 (length values) 6)
157           `((defun ,constructor-name ,keys
158               (make-structure (truly-the symbol ',*dd-name*) ,@values))))
159          (t
160           `((defun ,constructor-name ,keys
161               (%make-structure (truly-the symbol ',*dd-name*) (list ,@values))))))))
162
163(defun find-dsd (name)
164  (dolist (dsd *dd-slots*)
165    (when (string= name (dsd-name dsd))
166      (return dsd))))
167
168(defun get-slot (name)
169;;   (let ((res (find name (dd-slots defstruct) :test #'string= :key #'dsd-name)))
170  (let ((res nil))
171    (dolist (dsd *dd-slots*)
172      (when (string= name (dsd-name dsd))
173        (setf res dsd)
174        (return)))
175    (if res
176        (values (dsd-type res) (dsd-initform res))
177        (values t nil))))
178
179(defun define-boa-constructor (constructor)
180  (multiple-value-bind (req opt restp rest keyp keys allowp auxp aux)
181    (parse-lambda-list (cadr constructor))
182    (let ((arglist ())
183          (vars ())
184          (types ())
185          (skipped-vars ()))
186      (dolist (arg req)
187        (push arg arglist)
188        (push arg vars)
189        (push (get-slot arg) types))
190      (when opt
191        (push '&optional arglist)
192        (dolist (arg opt)
193          (cond ((consp arg)
194                 (destructuring-bind
195                  (name
196                   &optional
197                   (def (nth-value 1 (get-slot name)))
198                   (supplied-test nil supplied-test-p))
199                  arg
200                  (push `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil)) arglist)
201                  (push name vars)
202                  (push (get-slot name) types)))
203                (t
204                 (multiple-value-bind (type default) (get-slot arg)
205                   (push `(,arg ,default) arglist)
206                   (push arg vars)
207                   (push type types))))))
208      (when restp
209        (push '&rest arglist)
210        (push rest arglist)
211        (push rest vars)
212        (push 'list types))
213      (when keyp
214        (push '&key arglist)
215        (dolist (key keys)
216          (if (consp key)
217              (destructuring-bind (wot
218                                   &optional
219                                   (def nil def-p)
220                                   (supplied-test nil supplied-test-p))
221                                  key
222                                  (let ((name (if (consp wot)
223                                                  (destructuring-bind (key var) wot
224                                                                      (declare (ignore key))
225                                                                      var)
226                                                  wot)))
227                                    (multiple-value-bind (type slot-def)
228                                      (get-slot name)
229                                      (push `(,wot ,(if def-p def slot-def)
230                                                   ,@(if supplied-test-p `(,supplied-test) nil))
231                                            arglist)
232                                      (push name vars)
233                                      (push type types))))
234              (multiple-value-bind (type default) (get-slot key)
235                (push `(,key ,default) arglist)
236                (push key vars)
237                (push type types)))))
238      (when allowp
239        (push '&allow-other-keys arglist))
240      (when auxp
241        (push '&aux arglist)
242        (dolist (arg aux)
243          (push arg arglist)
244          (if (and (consp arg) (eql (length arg) 2))
245              (let ((var (first arg)))
246                (push var vars)
247                (push (get-slot var) types))
248              (push (if (consp arg) (first arg) arg) skipped-vars))))
249      (setq arglist (nreverse arglist))
250      (setq vars (nreverse vars))
251      (setq types (nreverse types))
252      (setq skipped-vars (nreverse skipped-vars))
253      (let ((values ()))
254        (dolist (dsd *dd-slots*)
255          (let ((name (dsd-name dsd))
256                var)
257            (cond ((find name skipped-vars :test #'string=)
258                   (push nil values))
259                  ((setf var (find name vars :test #'string=))
260                   (push var values))
261                  (t
262                   (push (dsd-initform dsd) values)))))
263        (setf values (nreverse values))
264        (let* ((constructor-name (car constructor)))
265          (cond ((eq *dd-type* 'list)
266                 `((defun ,constructor-name ,arglist
267                     (list ,@values))))
268                ((or (eq *dd-type* 'vector)
269                     (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
270                 (let ((element-type (if (consp *dd-type*) (cadr *dd-type*) t)))
271                   `((defun ,constructor-name ,arglist
272                       (make-array ,(length values)
273                                   :element-type ',element-type
274                                   :initial-contents (list ,@values))))))
275                ((<= 1 (length values) 6)
276                 `((declaim (inline ,constructor-name))
277                   (defun ,constructor-name ,arglist
278                     (make-structure (truly-the symbol ',*dd-name*) ,@values))))
279                (t
280                 `((declaim (inline ,constructor-name))
281                   (defun ,constructor-name ,arglist
282                     (%make-structure (truly-the symbol ',*dd-name*) (list ,@values)))))))))))
283
284(defun default-constructor-name ()
285  (intern (concatenate 'string "MAKE-" (symbol-name *dd-name*))))
286
287(defun define-constructors ()
288  (if *dd-constructors*
289      (let ((results ()))
290        (dolist (constructor *dd-constructors*)
291          (when (car constructor)
292            (setf results (nconc results
293                                 (if (cadr constructor)
294                                     (define-boa-constructor constructor)
295                                     (define-keyword-constructor constructor))))))
296        results)
297      (define-keyword-constructor (cons (default-constructor-name) nil))))
298
299(defun name-index ()
300  (dolist (dsd *dd-slots*)
301    (let ((name (dsd-name dsd))
302          (initform (dsd-initform dsd)))
303      (when (and (null name)
304                 (equal initform (list 'quote *dd-name*)))
305        (return-from name-index (dsd-index dsd)))))
306  ;; We shouldn't get here.
307  nil)
308
309(defun define-predicate ()
310  (when (and *dd-predicate*
311             (or *dd-named* (null *dd-type*)))
312    (let ((pred (if (symbolp *dd-predicate*)
313                    *dd-predicate*
314                    (intern *dd-predicate*))))
315      (cond ((eq *dd-type* 'list)
316             (let ((index (name-index)))
317               `((defun ,pred (object)
318                   (and (consp object)
319                        (> (length object) ,index)
320                        (eq (nth ,index object) ',*dd-name*))))))
321            ((or (eq *dd-type* 'vector)
322                 (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
323             (let ((index (name-index)))
324               `((defun ,pred (object)
325                   (and (vectorp object)
326                        (> (length object) ,index)
327                        (eq (aref object ,index) ',*dd-name*))))))
328            (t
329             `((defun ,pred (object)
330                 (simple-typep object ',*dd-name*))))))))
331
332(defun make-list-reader (index)
333  #'(lambda (instance)
334      (elt instance index)))
335
336(defun make-vector-reader (index)
337  #'(lambda (instance)
338      (aref instance index)))
339
340(defun make-structure-reader (index structure-type)
341  (declare (ignore structure-type))
342  #'(lambda (instance)
343      ;; (unless (typep instance structure-type)
344      ;;   (error 'type-error
345      ;;          :datum instance
346      ;;          :expected-type structure-type))
347      (structure-ref instance index)))
348
349(defun define-reader (slot)
350  (let ((accessor-name (dsd-reader slot))
351        (index (dsd-index slot))
352        (type (dsd-type slot)))
353    (cond ((eq *dd-type* 'list)
354           `((declaim (ftype (function * ,type) ,accessor-name))
355             (setf (symbol-function ',accessor-name)
356                   (make-list-reader ,index))))
357          ((or (eq *dd-type* 'vector)
358               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
359           `((declaim (ftype (function * ,type) ,accessor-name))
360             (setf (symbol-function ',accessor-name)
361                   (make-vector-reader ,index))
362             (define-source-transform ,accessor-name (instance)
363               `(aref (truly-the ,',*dd-type* ,instance) ,,index))))
364          (t
365           `((declaim (ftype (function * ,type) ,accessor-name))
366             (setf (symbol-function ',accessor-name)
367                   (make-structure-reader ,index ',*dd-name*))
368             (define-source-transform ,accessor-name (instance)
369               ,(if (eq type 't)
370                    ``(structure-ref (the ,',*dd-name* ,instance) ,,index)
371                    ``(the ,',type
372                        (structure-ref (the ,',*dd-name* ,instance) ,,index)))))))))
373
374(defun make-list-writer (index)
375  #'(lambda (value instance)
376      (%set-elt instance index value)))
377
378(defun make-vector-writer (index)
379  #'(lambda (value instance)
380      (aset instance index value)))
381
382(defun make-structure-writer (index structure-type)
383  (declare (ignore structure-type))
384  #'(lambda (value instance)
385      ;; (unless (typep instance structure-type)
386      ;;   (error 'type-error
387      ;;          :datum instance
388      ;;          :expected-type structure-type))
389      (structure-set instance index value)))
390
391
392
393(defun define-writer (slot)
394  (let ((accessor-name (dsd-reader slot))
395        (index (dsd-index slot)))
396    (cond ((eq *dd-type* 'list)
397           `((setf (get ',accessor-name 'setf-function)
398                   (make-list-writer ,index))))
399          ((or (eq *dd-type* 'vector)
400               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
401           `((setf (get ',accessor-name 'setf-function)
402                   (make-vector-writer ,index))
403             (define-source-transform (setf ,accessor-name) (value instance)
404               `(aset (truly-the ,',*dd-type* ,instance) ,,index ,value))))
405          (t
406           `((setf (get ',accessor-name 'setf-function)
407                   (make-structure-writer ,index ',*dd-name*))
408             (define-source-transform (setf ,accessor-name) (value instance)
409               `(structure-set (the ,',*dd-name* ,instance)
410                               ,,index ,value)))))))
411
412(defun define-access-functions ()
413  (let ((result ()))
414    (dolist (slot *dd-slots*)
415      (let ((accessor-name (dsd-reader slot)))
416        (unless (null accessor-name)
417          (unless (assoc accessor-name *dd-inherited-accessors*)
418            (setf result (nconc result (define-reader slot)))
419            (unless (dsd-read-only slot)
420              (setf result (nconc result (define-writer slot))))))))
421    result))
422
423(defun define-copier ()
424  (when *dd-copier*
425    (cond ((eq *dd-type* 'list)
426           `((setf (fdefinition ',*dd-copier*) #'copy-list)))
427          ((or (eq *dd-type* 'vector)
428               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
429           `((setf (fdefinition ',*dd-copier*) #'copy-seq)))
430          (t
431           `((setf (fdefinition ',*dd-copier*) #'copy-structure))))))
432
433(defun define-print-function ()
434  (cond (*dd-print-function*
435         (if (cadr *dd-print-function*)
436             `((defmethod print-object ((instance ,*dd-name*) stream)
437                 (funcall (function ,(cadr *dd-print-function*))
438                          instance stream *current-print-level*)))
439             `((defmethod print-object ((instance ,*dd-name*) stream)
440                 (write-string (%write-to-string instance) stream)))))
441        (*dd-print-object*
442         (if (cadr *dd-print-object*)
443             `((defmethod print-object ((instance ,*dd-name*) stream)
444                 (funcall (function ,(cadr *dd-print-object*))
445                          instance stream)))
446             `((defmethod print-object ((instance ,*dd-name*) stream)
447                 (write-string (%write-to-string instance) stream)))))
448        (t
449         nil)))
450
451(defun parse-1-option (option)
452  (case (car option)
453    (:conc-name
454     (setf *dd-conc-name* (if (symbolp (cadr option))
455                              (cadr option)
456                              (make-symbol (string (cadr option))))))
457    (:constructor
458     (let* ((args (cdr option))
459            (numargs (length args)))
460       (case numargs
461         (0 ; Use default name.
462          (push (list (default-constructor-name) nil) *dd-constructors*))
463         (1
464          (push (list (car args) nil) *dd-constructors*))
465         (2
466          (push args *dd-constructors*)))))
467    (:copier
468     (when (eql (length option) 2)
469       (setf *dd-copier* (cadr option))))
470    (:include
471     (setf *dd-include* (cdr option)))
472    (:initial-offset
473     (setf *dd-initial-offset* (cadr option)))
474    (:predicate
475     (when (eql (length option) 2)
476       (setf *dd-predicate* (cadr option))))
477    (:print-function
478     (setf *dd-print-function* option))
479    (:print-object
480     (setf *dd-print-object* option))
481    (:type
482     (setf *dd-type* (cadr option))
483     (when (and (consp *dd-type*) (eq (car *dd-type*) 'vector))
484       (unless (eq (second *dd-type*) '*)
485         (setf *dd-default-slot-type* (second *dd-type*)))))))
486
487(defun parse-name-and-options (name-and-options)
488  (setf *dd-name* (the symbol (car name-and-options)))
489  (setf *dd-conc-name* (make-symbol (concatenate 'string (symbol-name *dd-name*) "-")))
490  (setf *dd-copier* (intern (concatenate 'string "COPY-" (symbol-name *dd-name*))))
491  (setf *dd-predicate* (concatenate 'string (symbol-name *dd-name*) "-P"))
492  (let ((options (cdr name-and-options)))
493    (dolist (option options)
494      (cond ((consp option)
495             (parse-1-option option))
496            ((eq option :named)
497             (setf *dd-named* t))
498            ((member option '(:constructor :copier :predicate :named :conc-name))
499             (parse-1-option (list option)))
500            (t
501             (error "Unrecognized DEFSTRUCT option: ~S." option))))))
502
503(defun compiler-defstruct (name &key
504                                conc-name
505                                default-constructor
506                                constructors
507                                copier
508                                include
509                                type
510                                named
511                                initial-offset
512                                predicate
513                                print-function
514                                print-object
515                                direct-slots
516                                slots
517                                inherited-accessors)
518  (setf (get name 'structure-definition)
519        (make-defstruct-description :name name
520                                    :conc-name conc-name
521                                    :default-constructor default-constructor
522                                    :constructors constructors
523                                    :copier copier
524                                    :include include
525                                    :type type
526                                    :named named
527                                    :initial-offset initial-offset
528                                    :predicate predicate
529                                    :print-function print-function
530                                    :print-object print-object
531                                    :direct-slots direct-slots
532                                    :slots slots
533                                    :inherited-accessors inherited-accessors))
534  (when (or (null type) named)
535    (make-structure-class name direct-slots slots (car include)))
536  (when default-constructor
537    (proclaim `(ftype (function * t) ,default-constructor))))
538
539(defmacro defstruct (name-and-options &rest slots)
540  (let ((*dd-name* nil)
541        (*dd-conc-name* nil)
542        (*dd-default-constructor* nil)
543        (*dd-constructors* nil)
544        (*dd-copier* nil)
545        (*dd-include* nil)
546        (*dd-type* nil)
547        (*dd-default-slot-type* t)
548        (*dd-named* nil)
549        (*dd-initial-offset* nil)
550        (*dd-predicate* nil)
551        (*dd-print-function* nil)
552        (*dd-print-object* nil)
553        (*dd-direct-slots* ())
554        (*dd-slots* ())
555        (*dd-inherited-accessors* ()))
556    (parse-name-and-options (if (atom name-and-options)
557                                (list name-and-options)
558                                name-and-options))
559    (check-declaration-type *dd-name*)
560    (if *dd-constructors*
561        (dolist (constructor *dd-constructors*)
562          (unless (cadr constructor)
563            (setf *dd-default-constructor* (car constructor))
564            (return)))
565        (setf *dd-default-constructor* (default-constructor-name)))
566    (when (stringp (car slots))
567      (%set-documentation *dd-name* 'structure (pop slots)))
568    (dolist (slot slots)
569      (let* ((name (if (atom slot) slot (car slot)))
570             (reader (if *dd-conc-name*
571                         (intern (concatenate 'string
572                                              (symbol-name *dd-conc-name*)
573                                              (symbol-name name)))
574                         name))
575             (initform (if (atom slot) nil (cadr slot)))
576             (dsd (apply #'make-defstruct-slot-description
577                         :name name
578                         :reader reader
579                         :initform initform
580                         (cond
581                           ((atom slot)
582                            (list :type *dd-default-slot-type*))
583                           ((getf (cddr slot) :type)
584                            (cddr slot))
585                           (t
586                            (list* :type *dd-default-slot-type* (cddr slot)))))))
587        (push dsd *dd-direct-slots*)))
588    (setf *dd-direct-slots* (nreverse *dd-direct-slots*))
589    (let ((index 0))
590      (when *dd-include*
591        (let ((dd (get (car *dd-include*) 'structure-definition)))
592          (unless dd
593            (error 'simple-error
594                   :format-control "Class ~S is undefined."
595                   :format-arguments (list (car *dd-include*))))
596          (dolist (dsd (dd-slots dd))
597            ;; MUST COPY SLOT DESCRIPTION!
598            (setf dsd (copy-seq dsd))
599            (setf (dsd-index dsd) index
600                  (dsd-reader dsd)
601                  (if *dd-conc-name*
602                      (intern (concatenate 'string
603                                           (symbol-name *dd-conc-name*)
604                                           (symbol-name (dsd-name dsd))))
605                      (dsd-name dsd)))
606            (push dsd *dd-slots*)
607            (incf index))
608          (setf *dd-inherited-accessors* (dd-inherited-accessors dd))
609          (dolist (dsd (dd-direct-slots dd))
610            (push (cons (dsd-reader dsd) (dsd-name dsd))
611                  *dd-inherited-accessors*)))
612        (when (cdr *dd-include*)
613          (dolist (slot (cdr *dd-include*))
614            (let* ((name (if (atom slot) slot (car slot)))
615                   (initform (if (atom slot) nil (cadr slot)))
616                   (dsd (find-dsd name)))
617              (when dsd
618                (setf (dsd-initform dsd) initform))))))
619      (when *dd-initial-offset*
620        (dotimes (i *dd-initial-offset*)
621          (push (make-defstruct-slot-description :name nil
622                                                 :index index
623                                                 :reader nil
624                                                 :initform nil
625                                                 :type t
626                                                 :read-only t)
627                *dd-slots*)
628          (incf index)))
629      (when *dd-named*
630        (push (make-defstruct-slot-description :name nil
631                                               :index index
632                                               :reader nil
633                                               :initform (list 'quote *dd-name*)
634                                               :type t
635                                               :read-only t)
636              *dd-slots*)
637        (incf index))
638      (dolist (dsd *dd-direct-slots*)
639        (setf (dsd-index dsd) index)
640        (push dsd *dd-slots*)
641        (incf index)))
642    (setf *dd-slots* (nreverse *dd-slots*))
643    `(progn
644       (eval-when (:compile-toplevel :load-toplevel :execute)
645         (compiler-defstruct ',*dd-name*
646                             :conc-name ',*dd-conc-name*
647                             :default-constructor ',*dd-default-constructor*
648                             ,@(if *dd-constructors* `(:constructors ',*dd-constructors*))
649                             :copier ',*dd-copier*
650                             ,@(if *dd-include* `(:include ',*dd-include*))
651                             ,@(if *dd-type* `(:type ',*dd-type*))
652                             ,@(if *dd-named* `(:named ,*dd-named*))
653                             ,@(if *dd-initial-offset* `(:initial-offset ,*dd-initial-offset*))
654                             :predicate ',*dd-predicate*
655                             ,@(if *dd-print-function* `(:print-function ',*dd-print-function*))
656                             ,@(if *dd-print-object* `(:print-object ',*dd-print-object*))
657                             :direct-slots ',*dd-direct-slots*
658                             :slots ',*dd-slots*
659                             :inherited-accessors ',*dd-inherited-accessors*))
660       ,@(define-constructors)
661       ,@(define-predicate)
662       ,@(define-access-functions)
663       ,@(define-copier)
664       ,@(define-print-function)
665       ',*dd-name*)))
666
667(defun defstruct-default-constructor (arg)
668  (let ((type (cond ((symbolp arg)
669                     arg)
670                    ((classp arg)
671                     (class-name arg))
672                    (t
673                     (type-of arg)))))
674    (when type
675      (let ((dd (get type 'structure-definition)))
676        (and dd (dd-default-constructor dd))))))
Note: See TracBrowser for help on using the repository browser.