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

Last change on this file since 12113 was 12113, checked in by ehuelsmann, 12 years ago

Fix types used in THE type-checking for structure access.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 26.1 KB
Line 
1;;; defstruct.lisp
2;;;
3;;; Copyright (C) 2003-2007 Peter Graves <peter@armedbear.org>
4;;; $Id: defstruct.lisp 12113 2009-08-23 17:39:56Z 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
53(defun make-defstruct-description (&key name
54                                        conc-name
55                                        default-constructor
56                                        constructors
57                                        copier
58                                        include
59                                        type
60                                        named
61                                        initial-offset
62                                        predicate
63                                        print-function
64                                        print-object
65                                        direct-slots
66                                        slots)
67  (let ((dd (make-array 14)))
68    (setf (dd-name dd) name
69          (dd-conc-name dd) conc-name
70          (dd-default-constructor dd) default-constructor
71          (dd-constructors dd) constructors
72          (dd-copier dd) copier
73          (dd-include dd) include
74          (dd-type dd) type
75          (dd-named dd) named
76          (dd-initial-offset dd) initial-offset
77          (dd-predicate dd) predicate
78          (dd-print-function dd) print-function
79          (dd-print-object dd) print-object
80          (dd-direct-slots dd) direct-slots
81          (dd-slots dd) slots)
82    dd))
83
84;;; DEFSTRUCT-SLOT-DESCRIPTION
85
86(defmacro dsd-name (x)      `(aref ,x 1))
87(defmacro dsd-index (x)     `(aref ,x 2))
88(defmacro dsd-reader (x)    `(aref ,x 3))
89(defmacro dsd-initform (x)  `(aref ,x 4))
90(defmacro dsd-type (x)      `(aref ,x 5))
91(defmacro dsd-read-only (x) `(aref ,x 6))
92
93(defun make-defstruct-slot-description (&key name
94                                             index
95                                             reader
96                                             initform
97                                             (type t)
98                                             read-only)
99  (let ((dsd (make-array 7)))
100    (setf (aref dsd 0) 'defstruct-slot-description
101          (dsd-name dsd) name
102          (dsd-index dsd) index
103          (dsd-reader dsd) reader
104          (dsd-initform dsd) initform
105          (dsd-type dsd) type
106          (dsd-read-only dsd) read-only)
107    dsd))
108
109(defvar *dd-name*)
110(defvar *dd-conc-name*)
111(defvar *dd-default-constructor*)
112(defvar *dd-constructors*)
113(defvar *dd-copier*)
114(defvar *dd-include*)
115(defvar *dd-type*)
116(defvar *dd-default-slot-type* t)
117(defvar *dd-named*)
118(defvar *dd-initial-offset*)
119(defvar *dd-predicate*)
120(defvar *dd-print-function*)
121(defvar *dd-print-object*)
122(defvar *dd-direct-slots*)
123(defvar *dd-slots*)
124
125(defun keywordify (symbol)
126  (intern (symbol-name symbol) +keyword-package+))
127
128(defun define-keyword-constructor (constructor)
129  (let* ((constructor-name (car constructor))
130         (keys ())
131         (values ()))
132    (dolist (slot *dd-slots*)
133      (let ((name (dsd-name slot))
134            (initform (dsd-initform slot)))
135        (if (or name (dsd-reader slot))
136            (let ((dummy (gensym)))
137              (push (list (list (keywordify name) dummy) initform) keys)
138              (push dummy values))
139            (push initform values))))
140    (setf keys (cons '&key (nreverse keys))
141          values (nreverse values))
142    (cond ((eq *dd-type* 'list)
143           `((defun ,constructor-name ,keys
144               (list ,@values))))
145          ((or (eq *dd-type* 'vector)
146               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
147           (let ((element-type (if (consp *dd-type*) (cadr *dd-type*) t)))
148             `((defun ,constructor-name ,keys
149                 (make-array ,(length values)
150                             :element-type ',element-type
151                             :initial-contents (list ,@values))))))
152          ((<= 1 (length values) 6)
153           `((defun ,constructor-name ,keys
154               (make-structure (truly-the symbol ',*dd-name*) ,@values))))
155          (t
156           `((defun ,constructor-name ,keys
157               (%make-structure (truly-the symbol ',*dd-name*) (list ,@values))))))))
158
159(defun find-dsd (name)
160  (dolist (dsd *dd-slots*)
161    (when (string= name (dsd-name dsd))
162      (return dsd))))
163
164(defun get-slot (name)
165;;   (let ((res (find name (dd-slots defstruct) :test #'string= :key #'dsd-name)))
166  (let ((res nil))
167    (dolist (dsd *dd-slots*)
168      (when (string= name (dsd-name dsd))
169        (setf res dsd)
170        (return)))
171    (if res
172        (values (dsd-type res) (dsd-initform res))
173        (values t nil))))
174
175(defun define-boa-constructor (constructor)
176  (multiple-value-bind (req opt restp rest keyp keys allowp auxp aux)
177    (parse-lambda-list (cadr constructor))
178    (let ((arglist ())
179          (vars ())
180          (types ())
181          (skipped-vars ()))
182      (dolist (arg req)
183        (push arg arglist)
184        (push arg vars)
185        (push (get-slot arg) types))
186      (when opt
187        (push '&optional arglist)
188        (dolist (arg opt)
189          (cond ((consp arg)
190                 (destructuring-bind
191                  (name
192                   &optional
193                   (def (nth-value 1 (get-slot name)))
194                   (supplied-test nil supplied-test-p))
195                  arg
196                  (push `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil)) arglist)
197                  (push name vars)
198                  (push (get-slot name) types)))
199                (t
200                 (multiple-value-bind (type default) (get-slot arg)
201                   (push `(,arg ,default) arglist)
202                   (push arg vars)
203                   (push type types))))))
204      (when restp
205        (push '&rest arglist)
206        (push rest arglist)
207        (push rest vars)
208        (push 'list types))
209      (when keyp
210        (push '&key arglist)
211        (dolist (key keys)
212          (if (consp key)
213              (destructuring-bind (wot
214                                   &optional
215                                   (def nil def-p)
216                                   (supplied-test nil supplied-test-p))
217                                  key
218                                  (let ((name (if (consp wot)
219                                                  (destructuring-bind (key var) wot
220                                                                      (declare (ignore key))
221                                                                      var)
222                                                  wot)))
223                                    (multiple-value-bind (type slot-def)
224                                      (get-slot name)
225                                      (push `(,wot ,(if def-p def slot-def)
226                                                   ,@(if supplied-test-p `(,supplied-test) nil))
227                                            arglist)
228                                      (push name vars)
229                                      (push type types))))
230              (multiple-value-bind (type default) (get-slot key)
231                (push `(,key ,default) arglist)
232                (push key vars)
233                (push type types)))))
234      (when allowp
235        (push '&allow-other-keys arglist))
236      (when auxp
237        (push '&aux arglist)
238        (dolist (arg aux)
239          (push arg arglist)
240          (if (and (consp arg) (eql (length arg) 2))
241              (let ((var (first arg)))
242                (push var vars)
243                (push (get-slot var) types))
244              (push (if (consp arg) (first arg) arg) skipped-vars))))
245      (setq arglist (nreverse arglist))
246      (setq vars (nreverse vars))
247      (setq types (nreverse types))
248      (setq skipped-vars (nreverse skipped-vars))
249      (let ((values ()))
250        (dolist (dsd *dd-slots*)
251          (let ((name (dsd-name dsd))
252                var)
253            (cond ((find name skipped-vars :test #'string=)
254                   (push nil values))
255                  ((setf var (find name vars :test #'string=))
256                   (push var values))
257                  (t
258                   (push (dsd-initform dsd) values)))))
259        (setf values (nreverse values))
260        (let* ((constructor-name (car constructor)))
261          (cond ((eq *dd-type* 'list)
262                 `((defun ,constructor-name ,arglist
263                     (list ,@values))))
264                ((or (eq *dd-type* 'vector)
265                     (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
266                 (let ((element-type (if (consp *dd-type*) (cadr *dd-type*) t)))
267                   `((defun ,constructor-name ,arglist
268                       (make-array ,(length values)
269                                   :element-type ',element-type
270                                   :initial-contents (list ,@values))))))
271                ((<= 1 (length values) 6)
272                 `((declaim (inline ,constructor-name))
273                   (defun ,constructor-name ,arglist
274                     (make-structure (truly-the symbol ',*dd-name*) ,@values))))
275                (t
276                 `((declaim (inline ,constructor-name))
277                   (defun ,constructor-name ,arglist
278                     (%make-structure (truly-the symbol ',*dd-name*) (list ,@values)))))))))))
279
280(defun default-constructor-name ()
281  (intern (concatenate 'string "MAKE-" (symbol-name *dd-name*))))
282
283(defun define-constructors ()
284  (if *dd-constructors*
285      (let ((results ()))
286        (dolist (constructor *dd-constructors*)
287          (when (car constructor)
288            (setf results (nconc results
289                                 (if (cadr constructor)
290                                     (define-boa-constructor constructor)
291                                     (define-keyword-constructor constructor))))))
292        results)
293      (define-keyword-constructor (cons (default-constructor-name) nil))))
294
295(defun name-index ()
296  (dolist (dsd *dd-slots*)
297    (let ((name (dsd-name dsd))
298          (initform (dsd-initform dsd)))
299      (when (and (null name)
300                 (equal initform (list 'quote *dd-name*)))
301        (return-from name-index (dsd-index dsd)))))
302  ;; We shouldn't get here.
303  nil)
304
305(defun define-predicate ()
306  (when (and *dd-predicate*
307             (or *dd-named* (null *dd-type*)))
308    (let ((pred (if (symbolp *dd-predicate*)
309                    *dd-predicate*
310                    (intern *dd-predicate*))))
311      (cond ((eq *dd-type* 'list)
312             (let ((index (name-index)))
313               `((defun ,pred (object)
314                   (and (consp object)
315                        (> (length object) ,index)
316                        (eq (nth ,index object) ',*dd-name*))))))
317            ((or (eq *dd-type* 'vector)
318                 (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
319             (let ((index (name-index)))
320               `((defun ,pred (object)
321                   (and (vectorp object)
322                        (> (length object) ,index)
323                        (eq (aref object ,index) ',*dd-name*))))))
324            (t
325             `((defun ,pred (object)
326                 (simple-typep object ',*dd-name*))))))))
327
328(defun define-reader (slot)
329  (let ((accessor-name (if *dd-conc-name*
330                           (intern (concatenate 'string
331                                                (symbol-name *dd-conc-name*)
332                                                (symbol-name (dsd-name slot))))
333                           (dsd-name slot)))
334        (index (dsd-index slot))
335        (type (dsd-type slot)))
336    (cond ((eq *dd-type* 'list)
337           `((declaim (ftype (function * ,type) ,accessor-name))
338             (defun ,accessor-name (instance) (elt instance ,index))))
339          ((or (eq *dd-type* 'vector)
340               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
341           `((declaim (ftype (function * ,type) ,accessor-name))
342             (defun ,accessor-name (instance) (aref instance ,index))
343             (define-source-transform ,accessor-name (instance)
344               `(aref (truly-the ,',*dd-type* ,instance) ,,index))))
345          (t
346           `((declaim (ftype (function * ,type) ,accessor-name))
347             (defun ,accessor-name (instance)
348               (structure-ref (the ,*dd-name* instance) ,index))
349             (define-source-transform ,accessor-name (instance)
350               ,(if (eq type 't)
351                    ``(structure-ref (the ,',*dd-name* ,instance) ,,index)
352                    ``(the ,',type
353                        (structure-ref (the ,',*dd-name* ,instance) ,,index)))))))))
354
355(defun define-writer (slot)
356  (let ((accessor-name (if *dd-conc-name*
357                           (intern (concatenate 'string
358                                                (symbol-name *dd-conc-name*)
359                                                (symbol-name (dsd-name slot))))
360                           (dsd-name slot)))
361        (index (dsd-index slot)))
362    (cond ((eq *dd-type* 'list)
363           `((defun (setf ,accessor-name) (value instance)
364               (%set-elt instance ,index value))))
365          ((or (eq *dd-type* 'vector)
366               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
367           `((defun (setf ,accessor-name) (value instance)
368               (aset instance ,index value))
369             (define-source-transform (setf ,accessor-name) (value instance)
370               `(aset (truly-the ,',*dd-type* ,instance) ,,index ,value))))
371          (t
372           `((defun (setf ,accessor-name) (value instance)
373               (structure-set (the ,*dd-name* instance) ,index value))
374             (define-source-transform (setf ,accessor-name) (value instance)
375               `(structure-set (the ,',*dd-name* ,instance)
376                               ,,index ,value)))))))
377
378(defun define-access-functions ()
379  (let ((result ()))
380    (dolist (slot *dd-slots*)
381      (setf result (nconc result (define-reader slot)))
382      (unless (dsd-read-only slot)
383        (setf result (nconc result (define-writer slot)))))
384    result))
385
386(defun define-copier ()
387  (when *dd-copier*
388    (cond ((eq *dd-type* 'list)
389           `((setf (fdefinition ',*dd-copier*) #'copy-list)))
390          ((or (eq *dd-type* 'vector)
391               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
392           `((setf (fdefinition ',*dd-copier*) #'copy-seq)))
393          (t
394           `((setf (fdefinition ',*dd-copier*) #'copy-structure))))))
395
396(defun define-print-function ()
397  (cond (*dd-print-function*
398         (if (cadr *dd-print-function*)
399             `((defmethod print-object ((instance ,*dd-name*) stream)
400                 (funcall (function ,(cadr *dd-print-function*))
401                          instance stream *current-print-level*)))
402             `((defmethod print-object ((instance ,*dd-name*) stream)
403                 (write-string (%write-to-string instance) stream)))))
404        (*dd-print-object*
405         (if (cadr *dd-print-object*)
406             `((defmethod print-object ((instance ,*dd-name*) stream)
407                 (funcall (function ,(cadr *dd-print-object*))
408                          instance stream)))
409             `((defmethod print-object ((instance ,*dd-name*) stream)
410                 (write-string (%write-to-string instance) stream)))))
411        (t
412         nil)))
413
414(defun parse-1-option (option)
415  (case (car option)
416    (:conc-name
417     (setf *dd-conc-name* (if (symbolp (cadr option))
418                              (cadr option)
419                              (make-symbol (string (cadr option))))))
420    (:constructor
421     (let* ((args (cdr option))
422            (numargs (length args)))
423       (case numargs
424         (0 ; Use default name.
425          (push (list (default-constructor-name) nil) *dd-constructors*))
426         (1
427          (push (list (car args) nil) *dd-constructors*))
428         (2
429          (push args *dd-constructors*)))))
430    (:copier
431     (when (eql (length option) 2)
432       (setf *dd-copier* (cadr option))))
433    (:include
434     (setf *dd-include* (cdr option)))
435    (:initial-offset
436     (setf *dd-initial-offset* (cadr option)))
437    (:predicate
438     (when (eql (length option) 2)
439       (setf *dd-predicate* (cadr option))))
440    (:print-function
441     (setf *dd-print-function* option))
442    (:print-object
443     (setf *dd-print-object* option))
444    (:type
445     (setf *dd-type* (cadr option))
446     (when (and (consp *dd-type*) (eq (car *dd-type*) 'vector))
447       (unless (eq (second *dd-type*) '*)
448         (setf *dd-default-slot-type* (second *dd-type*)))))))
449
450(defun parse-name-and-options (name-and-options)
451  (setf *dd-name* (the symbol (car name-and-options)))
452  (setf *dd-conc-name* (make-symbol (concatenate 'string (symbol-name *dd-name*) "-")))
453  (setf *dd-copier* (intern (concatenate 'string "COPY-" (symbol-name *dd-name*))))
454  (setf *dd-predicate* (concatenate 'string (symbol-name *dd-name*) "-P"))
455  (let ((options (cdr name-and-options)))
456    (dolist (option options)
457      (cond ((consp option)
458             (parse-1-option option))
459            ((eq option :named)
460             (setf *dd-named* t))
461            ((member option '(:constructor :copier :predicate :named :conc-name))
462             (parse-1-option (list option)))
463            (t
464             (error "Unrecognized DEFSTRUCT option: ~S." option))))))
465
466(defun compiler-defstruct (name &key
467                                conc-name
468                                default-constructor
469                                constructors
470                                copier
471                                include
472                                type
473                                named
474                                initial-offset
475                                predicate
476                                print-function
477                                print-object
478                                direct-slots
479                                slots)
480  (setf (get name 'structure-definition)
481        (make-defstruct-description :name name
482                                    :conc-name conc-name
483                                    :default-constructor default-constructor
484                                    :constructors constructors
485                                    :copier copier
486                                    :include include
487                                    :type type
488                                    :named named
489                                    :initial-offset initial-offset
490                                    :predicate predicate
491                                    :print-function print-function
492                                    :print-object print-object
493                                    :direct-slots direct-slots
494                                    :slots slots))
495  (when (or (null type) named)
496    (make-structure-class name direct-slots slots (car include)))
497  (when default-constructor
498    (proclaim `(ftype (function * t) ,default-constructor))))
499
500(defmacro defstruct (name-and-options &rest slots)
501  (let ((*dd-name* nil)
502        (*dd-conc-name* nil)
503        (*dd-default-constructor* nil)
504        (*dd-constructors* nil)
505        (*dd-copier* nil)
506        (*dd-include* nil)
507        (*dd-type* nil)
508        (*dd-default-slot-type* t)
509        (*dd-named* nil)
510        (*dd-initial-offset* nil)
511        (*dd-predicate* nil)
512        (*dd-print-function* nil)
513        (*dd-print-object* nil)
514        (*dd-direct-slots* ())
515        (*dd-slots* ()))
516    (parse-name-and-options (if (atom name-and-options)
517                                (list name-and-options)
518                                name-and-options))
519    (check-declaration-type *dd-name*)
520    (if *dd-constructors*
521        (dolist (constructor *dd-constructors*)
522          (unless (cadr constructor)
523            (setf *dd-default-constructor* (car constructor))
524            (return)))
525        (setf *dd-default-constructor* (default-constructor-name)))
526    (when (stringp (car slots))
527      (%set-documentation *dd-name* 'structure (pop slots)))
528    (dolist (slot slots)
529      (let* ((name (if (atom slot) slot (car slot)))
530             (reader (if *dd-conc-name*
531                         (intern (concatenate 'string
532                                              (symbol-name *dd-conc-name*)
533                                              (symbol-name name)))
534                         name))
535             (initform (if (atom slot) nil (cadr slot)))
536             (dsd (apply #'make-defstruct-slot-description
537                         :name name
538                         :reader reader
539                         :initform initform
540                         (cond
541                           ((atom slot)
542                            (list :type *dd-default-slot-type*))
543                           ((getf (cddr slot) :type)
544                            (cddr slot))
545                           (t
546                            (list* :type *dd-default-slot-type* (cddr slot)))))))
547        (push dsd *dd-direct-slots*)))
548    (setf *dd-direct-slots* (nreverse *dd-direct-slots*))
549    (let ((index 0))
550      (when *dd-include*
551        (let ((dd (get (car *dd-include*) 'structure-definition)))
552          (unless dd
553            (error 'simple-error
554                   :format-control "Class ~S is undefined."
555                   :format-arguments (list (car *dd-include*))))
556          (dolist (dsd (dd-slots dd))
557            ;; MUST COPY SLOT DESCRIPTION!
558            (setf dsd (copy-seq dsd))
559            (setf (dsd-index dsd) index)
560            (push dsd *dd-slots*)
561            (incf index)))
562        (when (cdr *dd-include*)
563          (dolist (slot (cdr *dd-include*))
564            (let* ((name (if (atom slot) slot (car slot)))
565                   (initform (if (atom slot) nil (cadr slot)))
566                   (dsd (find-dsd name)))
567              (when dsd
568                (setf (dsd-initform dsd) initform))))))
569      (when *dd-initial-offset*
570        (dotimes (i *dd-initial-offset*)
571          (push (make-defstruct-slot-description :name nil
572                                                 :index index
573                                                 :reader nil
574                                                 :initform nil
575                                                 :type t
576                                                 :read-only t)
577                *dd-slots*)
578          (incf index)))
579      (when *dd-named*
580        (push (make-defstruct-slot-description :name nil
581                                               :index index
582                                               :reader nil
583                                               :initform (list 'quote *dd-name*)
584                                               :type t
585                                               :read-only t)
586              *dd-slots*)
587        (incf index))
588      (dolist (dsd *dd-direct-slots*)
589        (setf (dsd-index dsd) index)
590        (push dsd *dd-slots*)
591        (incf index)))
592    (setf *dd-slots* (nreverse *dd-slots*))
593    `(progn
594       (eval-when (:compile-toplevel :load-toplevel :execute)
595         (compiler-defstruct ',*dd-name*
596                             :conc-name ',*dd-conc-name*
597                             :default-constructor ',*dd-default-constructor*
598                             ,@(if *dd-constructors* `(:constructors ',*dd-constructors*))
599                             :copier ',*dd-copier*
600                             ,@(if *dd-include* `(:include ',*dd-include*))
601                             ,@(if *dd-type* `(:type ',*dd-type*))
602                             ,@(if *dd-named* `(:named ,*dd-named*))
603                             ,@(if *dd-initial-offset* `(:initial-offset ,*dd-initial-offset*))
604                             :predicate ',*dd-predicate*
605                             ,@(if *dd-print-function* `(:print-function ',*dd-print-function*))
606                             ,@(if *dd-print-object* `(:print-object ',*dd-print-object*))
607                             :direct-slots ',*dd-direct-slots*
608                             :slots ',*dd-slots*))
609       ,@(define-constructors)
610       ,@(define-predicate)
611       ,@(define-access-functions)
612       ,@(define-copier)
613       ,@(define-print-function)
614       ',*dd-name*)))
615
616(defun defstruct-default-constructor (arg)
617  (let ((type (cond ((symbolp arg)
618                     arg)
619                    ((classp arg)
620                     (class-name arg))
621                    (t
622                     (type-of arg)))))
623    (when type
624      (let ((dd (get type 'structure-definition)))
625        (and dd (dd-default-constructor dd))))))
Note: See TracBrowser for help on using the repository browser.