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

Last change on this file since 14914 was 14914, checked in by Mark Evenson, 5 years ago

Dramatically improve source recording on SYS::SOURCE plist for a symbol (Alan Ruttenberg)

The interface to recording information on the SYS:%SOURCE plist for a
symbol is now deprecated and will be removed with abcl-1.7.

Implementation


Source information for ABCL is now recorded on the SYS::SOURCE
property. The appropiate information for type is recorded by the
SYS::RECORD-SOURCE-INFORMATION-BY-TYPE function:

record-source-information-by-type (name type &optional source-pathname source-position)

TYPE is either a symbol or list.

Source information for functions, methods, and generic functions are
represented as lists of the following form:

(:generic-function function-name)
(:function function-name)
(:method method-name qualifiers specializers)

Where FUNCTION-NAME or METHOD-NAME can be a either be of the form
'symbol or '(setf symbol).

Source information for all other forms have a symbol for TYPE which is
one of the following:

:class, :variable, :condition, :constant, :compiler-macro, :macro
:package, :structure, :type, :setf-expander, :source-transform

These values follow SBCL'S implemenation in SLIME
c.f. <https://github.com/slime/slime/blob/bad2acf672c33b913aabc1a7facb9c3c16a4afe9/swank/sbcl.lisp#L748>

Modifications are in two places, one at the definitions, calling
record-source-information-by-type and then again in the file-compiler,
which writes forms like

(put 'source name (cons (list type pathname position) (get 'source name)))

In theory this can lead to redundancy if a fasl is loaded again and
again. I'm not sure how to fix this yet. Forms in the loader get
called early in build when many of the sequence functions aren't
present. Will probably just filter when presenting in slime.

<> :closes <http://abcl.org/trac/ticket/421> .
<> :merges <https://github.com/armedbear/abcl/pull/5> .

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 30.4 KB
Line 
1;;; defstruct.lisp
2;;;
3;;; Copyright (C) 2003-2007 Peter Graves <peter@armedbear.org>
4;;; $Id: defstruct.lisp 14914 2016-11-24 10:31:17Z mevenson $
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(defvar *dd-documentation*)
129
130(defun keywordify (symbol)
131  (intern (symbol-name symbol) +keyword-package+))
132
133(defun define-keyword-constructor (constructor)
134  (let* ((constructor-name (car constructor))
135         (keys ())
136         (values ()))
137    (dolist (slot *dd-slots*)
138      (let ((name (dsd-name slot))
139            (initform (dsd-initform slot)))
140        (if (or name (dsd-reader slot))
141            (let ((dummy (gensym)))
142              (push (list (list (keywordify name) dummy) initform) keys)
143              (push dummy values))
144            (push initform values))))
145    (setf keys (cons '&key (nreverse keys))
146          values (nreverse values))
147    (cond ((eq *dd-type* 'list)
148           `((defun ,constructor-name ,keys
149               (list ,@values))))
150          ((or (eq *dd-type* 'vector)
151               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
152           (let ((element-type (if (consp *dd-type*) (cadr *dd-type*) t)))
153             `((defun ,constructor-name ,keys
154                 (make-array ,(length values)
155                             :element-type ',element-type
156                             :initial-contents (list ,@values))))))
157          ((<= 1 (length values) 6)
158           `((defun ,constructor-name ,keys
159               (make-structure (truly-the symbol ',*dd-name*) ,@values))))
160          (t
161           `((defun ,constructor-name ,keys
162               (%make-structure (truly-the symbol ',*dd-name*) (list ,@values))))))))
163
164(defun find-dsd (name)
165  (dolist (dsd *dd-slots*)
166    (when (string= name (dsd-name dsd))
167      (return dsd))))
168
169(defun get-slot (name)
170;;   (let ((res (find name (dd-slots defstruct) :test #'string= :key #'dsd-name)))
171  (let ((res nil))
172    (dolist (dsd *dd-slots*)
173      (when (string= name (dsd-name dsd))
174        (setf res dsd)
175        (return)))
176    (if res
177        (values (dsd-type res) (dsd-initform res))
178        (values t nil))))
179
180(defun define-boa-constructor (constructor)
181  (multiple-value-bind (req opt restp rest keyp keys allowp auxp aux)
182    (parse-lambda-list (cadr constructor))
183    (let ((arglist ())
184          (vars ())
185          (types ())
186          (skipped-vars ()))
187      (dolist (arg req)
188        (push arg arglist)
189        (push arg vars)
190        (push (get-slot arg) types))
191      (when opt
192        (push '&optional arglist)
193        (dolist (arg opt)
194          (cond ((consp arg)
195                 (destructuring-bind
196                  (name
197                   &optional
198                   (def (nth-value 1 (get-slot name)))
199                   (supplied-test nil supplied-test-p))
200                  arg
201                  (push `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil)) arglist)
202                  (push name vars)
203                  (push (get-slot name) types)))
204                (t
205                 (multiple-value-bind (type default) (get-slot arg)
206                   (push `(,arg ,default) arglist)
207                   (push arg vars)
208                   (push type types))))))
209      (when restp
210        (push '&rest arglist)
211        (push rest arglist)
212        (push rest vars)
213        (push 'list types))
214      (when keyp
215        (push '&key arglist)
216        (dolist (key keys)
217          (if (consp key)
218              (destructuring-bind (wot
219                                   &optional
220                                   (def nil def-p)
221                                   (supplied-test nil supplied-test-p))
222                                  key
223                                  (let ((name (if (consp wot)
224                                                  (destructuring-bind (key var) wot
225                                                                      (declare (ignore key))
226                                                                      var)
227                                                  wot)))
228                                    (multiple-value-bind (type slot-def)
229                                      (get-slot name)
230                                      (push `(,wot ,(if def-p def slot-def)
231                                                   ,@(if supplied-test-p `(,supplied-test) nil))
232                                            arglist)
233                                      (push name vars)
234                                      (push type types))))
235              (multiple-value-bind (type default) (get-slot key)
236                (push `(,key ,default) arglist)
237                (push key vars)
238                (push type types)))))
239      (when allowp
240        (push '&allow-other-keys arglist))
241      (when auxp
242        (push '&aux arglist)
243        (dolist (arg aux)
244          (push arg arglist)
245          (if (and (consp arg) (eql (length arg) 2))
246              (let ((var (first arg)))
247                (push var vars)
248                (push (get-slot var) types))
249              (push (if (consp arg) (first arg) arg) skipped-vars))))
250      (setq arglist (nreverse arglist))
251      (setq vars (nreverse vars))
252      (setq types (nreverse types))
253      (setq skipped-vars (nreverse skipped-vars))
254      (let ((values ()))
255        (dolist (dsd *dd-slots*)
256          (let ((name (dsd-name dsd))
257                var)
258            (cond ((find name skipped-vars :test #'string=)
259                   (push nil values))
260                  ((setf var (find name vars :test #'string=))
261                   (push var values))
262                  (t
263                   (push (dsd-initform dsd) values)))))
264        (setf values (nreverse values))
265        (let* ((constructor-name (car constructor)))
266          (cond ((eq *dd-type* 'list)
267                 `((defun ,constructor-name ,arglist
268                     (list ,@values))))
269                ((or (eq *dd-type* 'vector)
270                     (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
271                 (let ((element-type (if (consp *dd-type*) (cadr *dd-type*) t)))
272                   `((defun ,constructor-name ,arglist
273                       (make-array ,(length values)
274                                   :element-type ',element-type
275                                   :initial-contents (list ,@values))))))
276                ((<= 1 (length values) 6)
277                 `((declaim (inline ,constructor-name))
278                   (defun ,constructor-name ,arglist
279                     (make-structure (truly-the symbol ',*dd-name*) ,@values))))
280                (t
281                 `((declaim (inline ,constructor-name))
282                   (defun ,constructor-name ,arglist
283                     (%make-structure (truly-the symbol ',*dd-name*) (list ,@values)))))))))))
284
285(defun default-constructor-name ()
286  (intern (concatenate 'string "MAKE-" (symbol-name *dd-name*))))
287
288(defun define-constructors ()
289  (if *dd-constructors*
290      (let ((results ()))
291        (dolist (constructor *dd-constructors*)
292          (when (car constructor)
293            (setf results (nconc results
294                                 (if (cadr constructor)
295                                     (define-boa-constructor constructor)
296                                     (define-keyword-constructor constructor))))))
297        results)
298      (define-keyword-constructor (cons (default-constructor-name) nil))))
299
300(defun name-index ()
301  (dolist (dsd *dd-slots*)
302    (let ((name (dsd-name dsd))
303          (initform (dsd-initform dsd)))
304      (when (and (null name)
305                 (equal initform (list 'quote *dd-name*)))
306        (return-from name-index (dsd-index dsd)))))
307  ;; We shouldn't get here.
308  nil)
309
310(defun define-predicate ()
311  (when (and *dd-predicate*
312             (or *dd-named* (null *dd-type*)))
313    (let ((pred (if (symbolp *dd-predicate*)
314                    *dd-predicate*
315                    (intern *dd-predicate*))))
316      (cond ((eq *dd-type* 'list)
317             (let ((index (name-index)))
318               `((defun ,pred (object)
319                   (and (consp object)
320                        (> (length object) ,index)
321                        (eq (nth ,index object) ',*dd-name*))))))
322            ((or (eq *dd-type* 'vector)
323                 (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
324             (let ((index (name-index)))
325               `((defun ,pred (object)
326                   (and (vectorp object)
327                        (> (length object) ,index)
328                        (eq (aref object ,index) ',*dd-name*))))))
329            (t
330             `((defun ,pred (object)
331                 (simple-typep object ',*dd-name*))))))))
332
333(defun make-list-reader (index)
334  #'(lambda (instance)
335      (elt instance index)))
336
337(defun make-vector-reader (index)
338  #'(lambda (instance)
339      (aref instance index)))
340
341(defun make-structure-reader (index structure-type)
342  (declare (ignore structure-type))
343  #'(lambda (instance)
344      ;; (unless (typep instance structure-type)
345      ;;   (error 'type-error
346      ;;          :datum instance
347      ;;          :expected-type structure-type))
348      (structure-ref instance index)))
349
350(defun define-reader (slot)
351  (let ((accessor-name (dsd-reader slot))
352        (index (dsd-index slot))
353        (type (dsd-type slot)))
354    (cond ((eq *dd-type* 'list)
355           `((declaim (ftype (function * ,type) ,accessor-name))
356       (record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
357             (setf (symbol-function ',accessor-name)
358                   (make-list-reader ,index))))
359          ((or (eq *dd-type* 'vector)
360               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
361           `((declaim (ftype (function * ,type) ,accessor-name))
362       (record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
363             (setf (symbol-function ',accessor-name)
364                   (make-vector-reader ,index))
365       (record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
366             (define-source-transform ,accessor-name (instance)
367               `(aref (truly-the ,',*dd-type* ,instance) ,,index))))
368          (t
369           `((declaim (ftype (function * ,type) ,accessor-name))
370             (setf (symbol-function ',accessor-name)
371                   (make-structure-reader ,index ',*dd-name*))
372       (record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
373             (define-source-transform ,accessor-name (instance)
374               ,(if (eq type 't)
375                    ``(structure-ref (the ,',*dd-name* ,instance) ,,index)
376                    ``(the ,',type
377                        (structure-ref (the ,',*dd-name* ,instance) ,,index)))))))))
378
379(defun make-list-writer (index)
380  #'(lambda (value instance)
381      (%set-elt instance index value)))
382
383(defun make-vector-writer (index)
384  #'(lambda (value instance)
385      (aset instance index value)))
386
387(defun make-structure-writer (index structure-type)
388  (declare (ignore structure-type))
389  #'(lambda (value instance)
390      ;; (unless (typep instance structure-type)
391      ;;   (error 'type-error
392      ;;          :datum instance
393      ;;          :expected-type structure-type))
394      (structure-set instance index value)))
395
396
397
398(defun define-writer (slot)
399  (let ((accessor-name (dsd-reader slot))
400        (index (dsd-index slot)))
401    (cond ((eq *dd-type* 'list)
402           `((record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
403       (setf (get ',accessor-name 'setf-function)
404                   (make-list-writer ,index))))
405          ((or (eq *dd-type* 'vector)
406               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
407           `((setf (get ',accessor-name 'setf-function)
408                   (make-vector-writer ,index))
409       (record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
410             (define-source-transform (setf ,accessor-name) (value instance)
411               `(aset (truly-the ,',*dd-type* ,instance) ,,index ,value))))
412          (t
413           `((setf (get ',accessor-name 'setf-function)
414                   (make-structure-writer ,index ',*dd-name*))
415       (record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
416             (define-source-transform (setf ,accessor-name) (value instance)
417               `(structure-set (the ,',*dd-name* ,instance)
418                               ,,index ,value)))))))
419
420(defun define-access-functions ()
421  (let ((result ()))
422    (dolist (slot *dd-slots*)
423      (let ((accessor-name (dsd-reader slot)))
424        (unless (null accessor-name)
425          (unless (assoc accessor-name *dd-inherited-accessors*)
426            (setf result (nconc result (define-reader slot)))
427            (unless (dsd-read-only slot)
428              (setf result (nconc result (define-writer slot))))))))
429    result))
430
431(defun define-copier ()
432  (when *dd-copier*
433    (cond ((eq *dd-type* 'list)
434           `((setf (fdefinition ',*dd-copier*) #'copy-list)))
435          ((or (eq *dd-type* 'vector)
436               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
437           `((setf (fdefinition ',*dd-copier*) #'copy-seq)))
438          (t
439           `((setf (fdefinition ',*dd-copier*) #'copy-structure))))))
440
441(defun define-print-function ()
442  (cond (*dd-print-function*
443         (if (cadr *dd-print-function*)
444             `((defmethod print-object ((instance ,*dd-name*) stream)
445                 (funcall (function ,(cadr *dd-print-function*))
446                          instance stream *current-print-level*)))
447             `((defmethod print-object ((instance ,*dd-name*) stream)
448                 (write-string (%write-to-string instance) stream)))))
449        (*dd-print-object*
450         (if (cadr *dd-print-object*)
451             `((defmethod print-object ((instance ,*dd-name*) stream)
452                 (funcall (function ,(cadr *dd-print-object*))
453                          instance stream)))
454             `((defmethod print-object ((instance ,*dd-name*) stream)
455                 (write-string (%write-to-string instance) stream)))))
456        (t
457         nil)))
458
459(defun parse-1-option (option)
460  (case (car option)
461    (:conc-name
462     (setf *dd-conc-name* (if (symbolp (cadr option))
463                              (cadr option)
464                              (make-symbol (string (cadr option))))))
465    (:constructor
466     (let* ((args (cdr option))
467            (numargs (length args)))
468       (case numargs
469         (0 ; Use default name.
470          (push (list (default-constructor-name) nil) *dd-constructors*))
471         (1
472          (push (list (car args) nil) *dd-constructors*))
473         (2
474          (push args *dd-constructors*)))))
475    (:copier
476     (when (eql (length option) 2)
477       (setf *dd-copier* (cadr option))))
478    (:include
479     (setf *dd-include* (cdr option)))
480    (:initial-offset
481     (setf *dd-initial-offset* (cadr option)))
482    (:predicate
483     (when (eql (length option) 2)
484       (setf *dd-predicate* (cadr option))))
485    (:print-function
486     (setf *dd-print-function* option))
487    (:print-object
488     (setf *dd-print-object* option))
489    (:type
490     (setf *dd-type* (cadr option))
491     (when (and (consp *dd-type*) (eq (car *dd-type*) 'vector))
492       (unless (eq (second *dd-type*) '*)
493         (setf *dd-default-slot-type* (second *dd-type*)))))))
494
495(defun parse-name-and-options (name-and-options)
496  (setf *dd-name* (the symbol (car name-and-options)))
497  (setf *dd-conc-name* (make-symbol (concatenate 'string (symbol-name *dd-name*) "-")))
498  (setf *dd-copier* (intern (concatenate 'string "COPY-" (symbol-name *dd-name*))))
499  (setf *dd-predicate* (concatenate 'string (symbol-name *dd-name*) "-P"))
500  (let ((options (cdr name-and-options)))
501    (dolist (option options)
502      (cond ((consp option)
503             (parse-1-option option))
504            ((eq option :named)
505             (setf *dd-named* t))
506            ((member option '(:constructor :copier :predicate :named :conc-name))
507             (parse-1-option (list option)))
508            (t
509             (error "Unrecognized DEFSTRUCT option: ~S." option))))))
510
511(defun compiler-defstruct (name &key
512                                conc-name
513                                default-constructor
514                                constructors
515                                copier
516                                include
517                                type
518                                named
519                                initial-offset
520                                predicate
521                                print-function
522                                print-object
523                                direct-slots
524                                slots
525                                inherited-accessors
526                                documentation)
527  (let ((description
528         (make-defstruct-description :name name
529                                    :conc-name conc-name
530                                    :default-constructor default-constructor
531                                    :constructors constructors
532                                    :copier copier
533                                    :include include
534                                    :type type
535                                    :named named
536                                    :initial-offset initial-offset
537                                    :predicate predicate
538                                    :print-function print-function
539                                    :print-object print-object
540                                    :direct-slots direct-slots
541                                    :slots slots
542                                    :inherited-accessors inherited-accessors))
543        (old (get name 'structure-definition)))
544    (when old
545      (unless
546          ;; Assert that the structure definitions are exactly the same
547          ;; we need to support this type of redefinition during bootstrap
548          ;; building ourselves
549          (and (equalp (aref old 0) (aref description 0))
550               ;; the CONC-NAME slot is an uninterned symbol if not supplied
551               ;; thus different on each redefinition round. Check that the
552               ;; names are equal, because it produces the same end result
553               ;; when they are.
554               (string= (aref old 1) (aref description 1))
555               (equalp (aref old 5) (aref description 5))
556               (equalp (aref old 6) (aref description 6))
557               (equalp (aref old 7) (aref description 7))
558               (equalp (aref old 8) (aref description 8))
559               (every (lambda (x y)
560                        (and (equalp (dsd-name x) (dsd-name y))
561                             (equalp (dsd-index x) (dsd-index y))
562                             (equalp (dsd-type x) (dsd-type y))))
563                      (append (aref old 12) (aref old 13))
564                      (append (aref description 12)
565                              (aref description 13))))
566        (error 'program-error
567               :format-control "Structure redefinition not supported ~
568                              in DEFSTRUCT for ~A"
569               :format-arguments (list name)))
570      ;; Since they're the same, continue with the old one.
571      (setf description old))
572    (setf (get name 'structure-definition) description))
573  (%set-documentation name 'structure documentation)
574  (when (or (null type) named)
575    (let ((structure-class
576            (make-structure-class name direct-slots slots (car include))))
577      (%set-documentation name 'type documentation)
578      (%set-documentation structure-class t documentation)))
579  (when default-constructor
580    (proclaim `(ftype (function * t) ,default-constructor))))
581
582(defmacro defstruct (name-and-options &rest slots)
583  (let ((*dd-name* nil)
584        (*dd-conc-name* nil)
585        (*dd-default-constructor* nil)
586        (*dd-constructors* nil)
587        (*dd-copier* nil)
588        (*dd-include* nil)
589        (*dd-type* nil)
590        (*dd-default-slot-type* t)
591        (*dd-named* nil)
592        (*dd-initial-offset* nil)
593        (*dd-predicate* nil)
594        (*dd-print-function* nil)
595        (*dd-print-object* nil)
596        (*dd-direct-slots* ())
597        (*dd-slots* ())
598        (*dd-inherited-accessors* ())
599        (*dd-documentation* nil))
600    (parse-name-and-options (if (atom name-and-options)
601                                (list name-and-options)
602                                name-and-options))
603    (check-declaration-type *dd-name*)
604    (if *dd-constructors*
605        (dolist (constructor *dd-constructors*)
606          (unless (cadr constructor)
607            (setf *dd-default-constructor* (car constructor))
608            (return)))
609        (setf *dd-default-constructor* (default-constructor-name)))
610    (when (stringp (car slots))
611      (setf *dd-documentation* (pop slots)))
612    (dolist (slot slots)
613      (let* ((name (if (atom slot) slot (car slot)))
614             (reader (if *dd-conc-name*
615                         (intern (concatenate 'string
616                                              (symbol-name *dd-conc-name*)
617                                              (symbol-name name)))
618                         name))
619             (initform (if (atom slot) nil (cadr slot)))
620             (dsd (apply #'make-defstruct-slot-description
621                         :name name
622                         :reader reader
623                         :initform initform
624                         (cond
625                           ((atom slot)
626                            (list :type *dd-default-slot-type*))
627                           ((getf (cddr slot) :type)
628                            (cddr slot))
629                           (t
630                            (list* :type *dd-default-slot-type* (cddr slot)))))))
631        (push dsd *dd-direct-slots*)))
632    (setf *dd-direct-slots* (nreverse *dd-direct-slots*))
633    (let ((index 0))
634      (when *dd-include*
635        (let ((dd (get (car *dd-include*) 'structure-definition)))
636          (unless dd
637            (error 'simple-error
638                   :format-control "Class ~S is undefined."
639                   :format-arguments (list (car *dd-include*))))
640          (dolist (dsd (dd-slots dd))
641            ;; MUST COPY SLOT DESCRIPTION!
642            (setf dsd (copy-seq dsd))
643            (setf (dsd-index dsd) index
644                  (dsd-reader dsd)
645                  (if *dd-conc-name*
646                      (intern (concatenate 'string
647                                           (symbol-name *dd-conc-name*)
648                                           (symbol-name (dsd-name dsd))))
649                      (dsd-name dsd)))
650            (push dsd *dd-slots*)
651            (incf index))
652          (setf *dd-inherited-accessors* (dd-inherited-accessors dd))
653          (dolist (dsd (dd-direct-slots dd))
654            (push (cons (dsd-reader dsd) (dsd-name dsd))
655                  *dd-inherited-accessors*)))
656        (when (cdr *dd-include*)
657          (dolist (slot (cdr *dd-include*))
658            (let* ((name (if (atom slot) slot (car slot)))
659                   (initform (if (atom slot) nil (cadr slot)))
660                   (dsd (find-dsd name)))
661              (when dsd
662                (setf (dsd-initform dsd) initform))))))
663      (when *dd-initial-offset*
664        (dotimes (i *dd-initial-offset*)
665          (push (make-defstruct-slot-description :name nil
666                                                 :index index
667                                                 :reader nil
668                                                 :initform nil
669                                                 :type t
670                                                 :read-only t)
671                *dd-slots*)
672          (incf index)))
673      (when *dd-named*
674        (push (make-defstruct-slot-description :name nil
675                                               :index index
676                                               :reader nil
677                                               :initform (list 'quote *dd-name*)
678                                               :type t
679                                               :read-only t)
680              *dd-slots*)
681        (incf index))
682      (dolist (dsd *dd-direct-slots*)
683        (setf (dsd-index dsd) index)
684        (push dsd *dd-slots*)
685        (incf index)))
686    (setf *dd-slots* (nreverse *dd-slots*))
687    `(progn
688       (eval-when (:compile-toplevel :load-toplevel :execute)
689         (compiler-defstruct ',*dd-name*
690                             :conc-name ',*dd-conc-name*
691                             :default-constructor ',*dd-default-constructor*
692                             ,@(if *dd-constructors* `(:constructors ',*dd-constructors*))
693                             :copier ',*dd-copier*
694                             ,@(if *dd-include* `(:include ',*dd-include*))
695                             ,@(if *dd-type* `(:type ',*dd-type*))
696                             ,@(if *dd-named* `(:named ,*dd-named*))
697                             ,@(if *dd-initial-offset* `(:initial-offset ,*dd-initial-offset*))
698                             :predicate ',*dd-predicate*
699                             ,@(if *dd-print-function* `(:print-function ',*dd-print-function*))
700                             ,@(if *dd-print-object* `(:print-object ',*dd-print-object*))
701                             :direct-slots ',*dd-direct-slots*
702                             :slots ',*dd-slots*
703                             :inherited-accessors ',*dd-inherited-accessors*
704                             :documentation ',*dd-documentation*))
705       (record-source-information-for-type ',*dd-name* :structure)
706       ,@(define-constructors)
707       ,@(define-predicate)
708       ,@(define-access-functions)
709       ,@(define-copier)
710       ,@(when (or *dd-print-function* *dd-print-object*)
711               `((require "PRINT-OBJECT")))
712       ,@(define-print-function)
713       ',*dd-name*)))
714
715(defun defstruct-default-constructor (arg)
716  (let ((type (cond ((symbolp arg)
717                     arg)
718                    ((classp arg)
719                     (class-name arg))
720                    (t
721                     (type-of arg)))))
722    (when type
723      (let ((dd (get type 'structure-definition)))
724        (and dd (dd-default-constructor dd))))))
Note: See TracBrowser for help on using the repository browser.