Many resources are needed to download a project. Please understand that we have to compensate our server costs. Thank you in advance.
Project price only 1 $
You can buy this project and download/modify it how often you want.
org.armedbear.lisp.defstruct.lisp Maven / Gradle / Ivy
;;; defstruct.lisp
;;;
;;; Copyright (C) 2003-2007 Peter Graves
;;; $Id$
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
;;;
;;; As a special exception, the copyright holders of this library give you
;;; permission to link this library with independent modules to produce an
;;; executable, regardless of the license terms of these independent
;;; modules, and to copy and distribute the resulting executable under
;;; terms of your choice, provided that you also meet, for each linked
;;; independent module, the terms and conditions of the license of that
;;; module. An independent module is a module which is not derived from
;;; or based on this library. If you modify this library, you may extend
;;; this exception to your version of the library, but you are not
;;; obligated to do so. If you do not wish to do so, delete this
;;; exception statement from your version.
(in-package "SYSTEM")
(export 'compiler-defstruct)
;;; DEFSTRUCT-DESCRIPTION
(defmacro dd-name (x) `(aref ,x 0))
(defmacro dd-conc-name (x) `(aref ,x 1))
(defmacro dd-default-constructor (x) `(aref ,x 2))
(defmacro dd-constructors (x) `(aref ,x 3))
(defmacro dd-copier (x) `(aref ,x 4))
(defmacro dd-include (x) `(aref ,x 5))
(defmacro dd-type (x) `(aref ,x 6))
(defmacro dd-named (x) `(aref ,x 7))
(defmacro dd-initial-offset (x) `(aref ,x 8))
(defmacro dd-predicate (x) `(aref ,x 9))
(defmacro dd-print-function (x) `(aref ,x 10))
(defmacro dd-print-object (x) `(aref ,x 11))
(defmacro dd-direct-slots (x) `(aref ,x 12))
(defmacro dd-slots (x) `(aref ,x 13))
(defmacro dd-inherited-accessors (x) `(aref ,x 14))
(defun make-defstruct-description (&key name
conc-name
default-constructor
constructors
copier
include
type
named
initial-offset
predicate
print-function
print-object
direct-slots
slots
inherited-accessors)
(let ((dd (make-array 15)))
(setf (dd-name dd) name
(dd-conc-name dd) conc-name
(dd-default-constructor dd) default-constructor
(dd-constructors dd) constructors
(dd-copier dd) copier
(dd-include dd) include
(dd-type dd) type
(dd-named dd) named
(dd-initial-offset dd) initial-offset
(dd-predicate dd) predicate
(dd-print-function dd) print-function
(dd-print-object dd) print-object
(dd-direct-slots dd) direct-slots
(dd-slots dd) slots
(dd-inherited-accessors dd) inherited-accessors)
dd))
;;; DEFSTRUCT-SLOT-DESCRIPTION
(defmacro dsd-name (x) `(aref ,x 1))
(defmacro dsd-index (x) `(aref ,x 2))
(defmacro dsd-reader (x) `(aref ,x 3))
(defmacro dsd-initform (x) `(aref ,x 4))
(defmacro dsd-type (x) `(aref ,x 5))
(defmacro dsd-read-only (x) `(aref ,x 6))
(defun make-defstruct-slot-description (&key name
index
reader
initform
(type t)
read-only)
(let ((dsd (make-array 7)))
(setf (aref dsd 0) 'defstruct-slot-description
(dsd-name dsd) name
(dsd-index dsd) index
(dsd-reader dsd) reader
(dsd-initform dsd) initform
(dsd-type dsd) type
(dsd-read-only dsd) read-only)
dsd))
(defvar *dd-name*)
(defvar *dd-conc-name*)
(defvar *dd-default-constructor*)
(defvar *dd-constructors*)
(defvar *dd-copier*)
(defvar *dd-include*)
(defvar *dd-type*)
(defvar *dd-default-slot-type* t)
(defvar *dd-named*)
(defvar *dd-initial-offset*)
(defvar *dd-predicate*)
(defvar *dd-print-function*)
(defvar *dd-print-object*)
(defvar *dd-direct-slots*)
(defvar *dd-slots*)
(defvar *dd-inherited-accessors*)
(defvar *dd-documentation*)
(defun keywordify (symbol)
(intern (symbol-name symbol) +keyword-package+))
(defun define-keyword-constructor (constructor)
(let* ((constructor-name (car constructor))
(keys ())
(values ()))
(dolist (slot *dd-slots*)
(let ((name (dsd-name slot))
(initform (dsd-initform slot)))
(if (or name (dsd-reader slot))
(let ((dummy (gensym)))
(push (list (list (keywordify name) dummy) initform) keys)
(push dummy values))
(push initform values))))
(setf keys (cons '&key (nreverse keys))
values (nreverse values))
(cond ((eq *dd-type* 'list)
`((defun ,constructor-name ,keys
(list ,@values))))
((or (eq *dd-type* 'vector)
(and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
(let ((element-type (if (consp *dd-type*) (cadr *dd-type*) t)))
`((defun ,constructor-name ,keys
(make-array ,(length values)
:element-type ',element-type
:initial-contents (list ,@values))))))
((<= 1 (length values) 6)
`((defun ,constructor-name ,keys
(make-structure (truly-the symbol ',*dd-name*) ,@values))))
(t
`((defun ,constructor-name ,keys
(%make-structure (truly-the symbol ',*dd-name*) (list ,@values))))))))
(defun find-dsd (name)
(dolist (dsd *dd-slots*)
(when (string= name (dsd-name dsd))
(return dsd))))
(defun get-slot (name)
;; (let ((res (find name (dd-slots defstruct) :test #'string= :key #'dsd-name)))
(let ((res nil))
(dolist (dsd *dd-slots*)
(when (string= name (dsd-name dsd))
(setf res dsd)
(return)))
(if res
(values (dsd-type res) (dsd-initform res))
(values t nil))))
(defun define-boa-constructor (constructor)
(multiple-value-bind (req opt restp rest keyp keys allowp auxp aux)
(parse-lambda-list (cadr constructor))
(let ((arglist ())
(vars ())
(types ())
(skipped-vars ()))
(dolist (arg req)
(push arg arglist)
(push arg vars)
(push (get-slot arg) types))
(when opt
(push '&optional arglist)
(dolist (arg opt)
(cond ((consp arg)
(destructuring-bind
(name
&optional
(def (nth-value 1 (get-slot name)))
(supplied-test nil supplied-test-p))
arg
(push `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil)) arglist)
(push name vars)
(push (get-slot name) types)))
(t
(multiple-value-bind (type default) (get-slot arg)
(push `(,arg ,default) arglist)
(push arg vars)
(push type types))))))
(when restp
(push '&rest arglist)
(push rest arglist)
(push rest vars)
(push 'list types))
(when keyp
(push '&key arglist)
(dolist (key keys)
(if (consp key)
(destructuring-bind (wot
&optional
(def nil def-p)
(supplied-test nil supplied-test-p))
key
(let ((name (if (consp wot)
(destructuring-bind (key var) wot
(declare (ignore key))
var)
wot)))
(multiple-value-bind (type slot-def)
(get-slot name)
(push `(,wot ,(if def-p def slot-def)
,@(if supplied-test-p `(,supplied-test) nil))
arglist)
(push name vars)
(push type types))))
(multiple-value-bind (type default) (get-slot key)
(push `(,key ,default) arglist)
(push key vars)
(push type types)))))
(when allowp
(push '&allow-other-keys arglist))
(when auxp
(push '&aux arglist)
(dolist (arg aux)
(push arg arglist)
(if (and (consp arg) (eql (length arg) 2))
(let ((var (first arg)))
(push var vars)
(push (get-slot var) types))
(push (if (consp arg) (first arg) arg) skipped-vars))))
(setq arglist (nreverse arglist))
(setq vars (nreverse vars))
(setq types (nreverse types))
(setq skipped-vars (nreverse skipped-vars))
(let ((values ()))
(dolist (dsd *dd-slots*)
(let ((name (dsd-name dsd))
var)
(cond ((find name skipped-vars :test #'string=)
(push nil values))
((setf var (find name vars :test #'string=))
(push var values))
(t
(push (dsd-initform dsd) values)))))
(setf values (nreverse values))
(let* ((constructor-name (car constructor)))
(cond ((eq *dd-type* 'list)
`((defun ,constructor-name ,arglist
(list ,@values))))
((or (eq *dd-type* 'vector)
(and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
(let ((element-type (if (consp *dd-type*) (cadr *dd-type*) t)))
`((defun ,constructor-name ,arglist
(make-array ,(length values)
:element-type ',element-type
:initial-contents (list ,@values))))))
((<= 1 (length values) 6)
`((declaim (inline ,constructor-name))
(defun ,constructor-name ,arglist
(make-structure (truly-the symbol ',*dd-name*) ,@values))))
(t
`((declaim (inline ,constructor-name))
(defun ,constructor-name ,arglist
(%make-structure (truly-the symbol ',*dd-name*) (list ,@values)))))))))))
(defun default-constructor-name ()
(intern (concatenate 'string "MAKE-" (symbol-name *dd-name*))))
(defun define-constructors ()
(if *dd-constructors*
(let ((results ()))
(dolist (constructor *dd-constructors*)
(when (car constructor)
(setf results (nconc results
(if (cadr constructor)
(define-boa-constructor constructor)
(define-keyword-constructor constructor))))))
results)
(define-keyword-constructor (cons (default-constructor-name) nil))))
(defun name-index ()
(dolist (dsd *dd-slots*)
(let ((name (dsd-name dsd))
(initform (dsd-initform dsd)))
(when (and (null name)
(equal initform (list 'quote *dd-name*)))
(return-from name-index (dsd-index dsd)))))
;; We shouldn't get here.
nil)
(defun define-predicate ()
(when (and *dd-predicate*
(or *dd-named* (null *dd-type*)))
(let ((pred (if (symbolp *dd-predicate*)
*dd-predicate*
(intern *dd-predicate*))))
(cond ((eq *dd-type* 'list)
(let ((index (name-index)))
`((defun ,pred (object)
(and (consp object)
(> (length object) ,index)
(eq (nth ,index object) ',*dd-name*))))))
((or (eq *dd-type* 'vector)
(and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
(let ((index (name-index)))
`((defun ,pred (object)
(and (vectorp object)
(> (length object) ,index)
(eq (aref object ,index) ',*dd-name*))))))
(t
`((defun ,pred (object)
(simple-typep object ',*dd-name*))))))))
(defun make-list-reader (index)
#'(lambda (instance)
(elt instance index)))
(defun make-vector-reader (index)
#'(lambda (instance)
(aref instance index)))
(defun make-structure-reader (index structure-type)
(declare (ignore structure-type))
#'(lambda (instance)
;; (unless (typep instance structure-type)
;; (error 'type-error
;; :datum instance
;; :expected-type structure-type))
(structure-ref instance index)))
(defun define-reader (slot)
(let ((accessor-name (dsd-reader slot))
(index (dsd-index slot))
(type (dsd-type slot)))
(cond ((eq *dd-type* 'list)
`((declaim (ftype (function * ,type) ,accessor-name))
(record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
(setf (symbol-function ',accessor-name)
(make-list-reader ,index))))
((or (eq *dd-type* 'vector)
(and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
`((declaim (ftype (function * ,type) ,accessor-name))
(record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
(setf (symbol-function ',accessor-name)
(make-vector-reader ,index))
(record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
(define-source-transform ,accessor-name (instance)
`(aref (truly-the ,',*dd-type* ,instance) ,,index))))
(t
`((declaim (ftype (function * ,type) ,accessor-name))
(setf (symbol-function ',accessor-name)
(make-structure-reader ,index ',*dd-name*))
(record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
(define-source-transform ,accessor-name (instance)
,(if (eq type 't)
``(structure-ref (the ,',*dd-name* ,instance) ,,index)
``(the ,',type
(structure-ref (the ,',*dd-name* ,instance) ,,index)))))))))
(defun make-list-writer (index)
#'(lambda (value instance)
(%set-elt instance index value)))
(defun make-vector-writer (index)
#'(lambda (value instance)
(aset instance index value)))
(defun make-structure-writer (index structure-type)
(declare (ignore structure-type))
#'(lambda (value instance)
;; (unless (typep instance structure-type)
;; (error 'type-error
;; :datum instance
;; :expected-type structure-type))
(structure-set instance index value)))
(defun define-writer (slot)
(let ((accessor-name (dsd-reader slot))
(index (dsd-index slot)))
(cond ((eq *dd-type* 'list)
`((record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
(setf (get ',accessor-name 'setf-function)
(make-list-writer ,index))))
((or (eq *dd-type* 'vector)
(and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
`((setf (get ',accessor-name 'setf-function)
(make-vector-writer ,index))
(record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
(define-source-transform (setf ,accessor-name) (value instance)
`(aset (truly-the ,',*dd-type* ,instance) ,,index ,value))))
(t
`((setf (get ',accessor-name 'setf-function)
(make-structure-writer ,index ',*dd-name*))
(record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
(define-source-transform (setf ,accessor-name) (value instance)
`(structure-set (the ,',*dd-name* ,instance)
,,index ,value)))))))
(defun define-access-functions ()
(let ((result ()))
(dolist (slot *dd-slots*)
(let ((accessor-name (dsd-reader slot)))
(unless (null accessor-name)
(unless (assoc accessor-name *dd-inherited-accessors*)
(setf result (nconc result (define-reader slot)))
(unless (dsd-read-only slot)
(setf result (nconc result (define-writer slot))))))))
result))
(defun define-copier ()
(when *dd-copier*
(cond ((eq *dd-type* 'list)
`((declaim (ftype (function (list) list) ,*dd-copier*))
(setf (fdefinition ',*dd-copier*) #'copy-list)))
((or (eq *dd-type* 'vector)
(and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
`((declaim (ftype (function (vector) vector) ,*dd-copier*))
(setf (fdefinition ',*dd-copier*) #'copy-seq)))
(t
`((declaim (ftype (function (T) T) ,*dd-copier*))
(setf (fdefinition ',*dd-copier*) #'copy-structure))))))
(defun define-print-function ()
(cond (*dd-print-function*
(if (cadr *dd-print-function*)
`((defmethod print-object ((instance ,*dd-name*) stream)
(funcall (function ,(cadr *dd-print-function*))
instance stream *current-print-level*)))
`((defmethod print-object ((instance ,*dd-name*) stream)
(write-string (%write-to-string instance) stream)))))
(*dd-print-object*
(if (cadr *dd-print-object*)
`((defmethod print-object ((instance ,*dd-name*) stream)
(funcall (function ,(cadr *dd-print-object*))
instance stream)))
`((defmethod print-object ((instance ,*dd-name*) stream)
(write-string (%write-to-string instance) stream)))))
(t
nil)))
(defun parse-1-option (option)
(case (car option)
(:conc-name
(setf *dd-conc-name* (if (symbolp (cadr option))
(cadr option)
(make-symbol (string (cadr option))))))
(:constructor
(let* ((args (cdr option))
(numargs (length args)))
(case numargs
(0 ; Use default name.
(push (list (default-constructor-name) nil) *dd-constructors*))
(1
(push (list (car args) nil) *dd-constructors*))
(2
(push args *dd-constructors*)))))
(:copier
(when (eql (length option) 2)
(setf *dd-copier* (cadr option))))
(:include
(setf *dd-include* (cdr option)))
(:initial-offset
(setf *dd-initial-offset* (cadr option)))
(:predicate
(when (eql (length option) 2)
(setf *dd-predicate* (cadr option))))
(:print-function
(setf *dd-print-function* option))
(:print-object
(setf *dd-print-object* option))
(:type
(setf *dd-type* (cadr option))
(when (and (consp *dd-type*) (eq (car *dd-type*) 'vector))
(unless (eq (second *dd-type*) '*)
(setf *dd-default-slot-type* (second *dd-type*)))))))
(defun parse-name-and-options (name-and-options)
(setf *dd-name* (the symbol (car name-and-options)))
(setf *dd-conc-name* (make-symbol (concatenate 'string (symbol-name *dd-name*) "-")))
(setf *dd-copier* (intern (concatenate 'string "COPY-" (symbol-name *dd-name*))))
(setf *dd-predicate* (concatenate 'string (symbol-name *dd-name*) "-P"))
(let ((options (cdr name-and-options)))
(dolist (option options)
(cond ((consp option)
(parse-1-option option))
((eq option :named)
(setf *dd-named* t))
((member option '(:constructor :copier :predicate :named :conc-name))
(parse-1-option (list option)))
(t
(error "Unrecognized DEFSTRUCT option: ~S." option))))))
(defun compiler-defstruct (name &key
conc-name
default-constructor
constructors
copier
include
type
named
initial-offset
predicate
print-function
print-object
direct-slots
slots
inherited-accessors
documentation)
(let ((description
(make-defstruct-description :name name
:conc-name conc-name
:default-constructor default-constructor
:constructors constructors
:copier copier
:include include
:type type
:named named
:initial-offset initial-offset
:predicate predicate
:print-function print-function
:print-object print-object
:direct-slots direct-slots
:slots slots
:inherited-accessors inherited-accessors))
(old (get name 'structure-definition)))
(when old
(unless
;; Assert that the structure definitions are exactly the same
;; we need to support this type of redefinition during bootstrap
;; building ourselves
(and (equalp (aref old 0) (aref description 0))
;; the CONC-NAME slot is an uninterned symbol if not supplied
;; thus different on each redefinition round. Check that the
;; names are equal, because it produces the same end result
;; when they are.
(string= (aref old 1) (aref description 1))
(equalp (aref old 5) (aref description 5))
(equalp (aref old 6) (aref description 6))
(equalp (aref old 7) (aref description 7))
(equalp (aref old 8) (aref description 8))
(every (lambda (x y)
(and (equalp (dsd-name x) (dsd-name y))
(equalp (dsd-index x) (dsd-index y))
(equalp (dsd-type x) (dsd-type y))))
(append (aref old 12) (aref old 13))
(append (aref description 12)
(aref description 13))))
(error 'program-error
:format-control "Structure redefinition not supported ~
in DEFSTRUCT for ~A"
:format-arguments (list name)))
;; Since they're the same, continue with the old one.
(setf description old))
(setf (get name 'structure-definition) description))
(%set-documentation name 'structure documentation)
(when (or (null type) named)
(let ((structure-class
(make-structure-class name direct-slots slots (car include))))
(%set-documentation name 'type documentation)
(%set-documentation structure-class t documentation)))
(when default-constructor
(proclaim `(ftype (function * t) ,default-constructor))))
(defmacro defstruct (name-and-options &rest slots)
(let ((*dd-name* nil)
(*dd-conc-name* nil)
(*dd-default-constructor* nil)
(*dd-constructors* nil)
(*dd-copier* nil)
(*dd-include* nil)
(*dd-type* nil)
(*dd-default-slot-type* t)
(*dd-named* nil)
(*dd-initial-offset* nil)
(*dd-predicate* nil)
(*dd-print-function* nil)
(*dd-print-object* nil)
(*dd-direct-slots* ())
(*dd-slots* ())
(*dd-inherited-accessors* ())
(*dd-documentation* nil))
(parse-name-and-options (if (atom name-and-options)
(list name-and-options)
name-and-options))
(check-declaration-type *dd-name*)
(if *dd-constructors*
(dolist (constructor *dd-constructors*)
(unless (cadr constructor)
(setf *dd-default-constructor* (car constructor))
(return)))
(setf *dd-default-constructor* (default-constructor-name)))
(when (stringp (car slots))
(setf *dd-documentation* (pop slots)))
(dolist (slot slots)
(let* ((name (if (atom slot) slot (car slot)))
(reader (if *dd-conc-name*
(intern (concatenate 'string
(symbol-name *dd-conc-name*)
(symbol-name name)))
name))
(initform (if (atom slot) nil (cadr slot)))
(dsd (apply #'make-defstruct-slot-description
:name name
:reader reader
:initform initform
(cond
((atom slot)
(list :type *dd-default-slot-type*))
((getf (cddr slot) :type)
(cddr slot))
(t
(list* :type *dd-default-slot-type* (cddr slot)))))))
(push dsd *dd-direct-slots*)))
(setf *dd-direct-slots* (nreverse *dd-direct-slots*))
(let ((index 0))
(when *dd-include*
(let ((dd (get (car *dd-include*) 'structure-definition)))
(unless dd
(error 'simple-error
:format-control "Class ~S is undefined."
:format-arguments (list (car *dd-include*))))
(dolist (dsd (dd-slots dd))
;; MUST COPY SLOT DESCRIPTION!
(setf dsd (copy-seq dsd))
(setf (dsd-index dsd) index
(dsd-reader dsd)
(if *dd-conc-name*
(intern (concatenate 'string
(symbol-name *dd-conc-name*)
(symbol-name (dsd-name dsd))))
(dsd-name dsd)))
(push dsd *dd-slots*)
(incf index))
(setf *dd-inherited-accessors* (dd-inherited-accessors dd))
(dolist (dsd (dd-direct-slots dd))
(push (cons (dsd-reader dsd) (dsd-name dsd))
*dd-inherited-accessors*)))
(when (cdr *dd-include*)
(dolist (slot (cdr *dd-include*))
(let* ((name (if (atom slot) slot (car slot)))
(initform (if (atom slot) nil (cadr slot)))
(dsd (find-dsd name)))
(when dsd
(setf (dsd-initform dsd) initform))))))
(when *dd-initial-offset*
(dotimes (i *dd-initial-offset*)
(push (make-defstruct-slot-description :name nil
:index index
:reader nil
:initform nil
:type t
:read-only t)
*dd-slots*)
(incf index)))
(when *dd-named*
(push (make-defstruct-slot-description :name nil
:index index
:reader nil
:initform (list 'quote *dd-name*)
:type t
:read-only t)
*dd-slots*)
(incf index))
(dolist (dsd *dd-direct-slots*)
(setf (dsd-index dsd) index)
(push dsd *dd-slots*)
(incf index)))
(setf *dd-slots* (nreverse *dd-slots*))
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(compiler-defstruct ',*dd-name*
:conc-name ',*dd-conc-name*
:default-constructor ',*dd-default-constructor*
,@(if *dd-constructors* `(:constructors ',*dd-constructors*))
:copier ',*dd-copier*
,@(if *dd-include* `(:include ',*dd-include*))
,@(if *dd-type* `(:type ',*dd-type*))
,@(if *dd-named* `(:named ,*dd-named*))
,@(if *dd-initial-offset* `(:initial-offset ,*dd-initial-offset*))
:predicate ',*dd-predicate*
,@(if *dd-print-function* `(:print-function ',*dd-print-function*))
,@(if *dd-print-object* `(:print-object ',*dd-print-object*))
:direct-slots ',*dd-direct-slots*
:slots ',*dd-slots*
:inherited-accessors ',*dd-inherited-accessors*
:documentation ',*dd-documentation*))
(record-source-information-for-type ',*dd-name* :structure)
,@(define-constructors)
,@(define-predicate)
,@(define-access-functions)
,@(define-copier)
,@(when (or *dd-print-function* *dd-print-object*)
`((require "PRINT-OBJECT")))
,@(define-print-function)
',*dd-name*)))
(defun defstruct-default-constructor (arg)
(let ((type (cond ((symbolp arg)
arg)
((classp arg)
(class-name arg))
(t
(type-of arg)))))
(when type
(let ((dd (get type 'structure-definition)))
(and dd (dd-default-constructor dd))))))
