Function: cl-defstruct
cl-defstruct is an autoloaded macro defined in cl-macs.el.gz.
Signature
(cl-defstruct NAME &optional DOCSTRING &rest SLOTS)
Documentation
Define a struct type.
This macro defines a new data type called NAME that stores data
in SLOTs. It defines a make-NAME constructor, a copy-NAME
copier, a NAME-p predicate, and slot accessors named NAME-SLOT.
You can use the accessors to set the corresponding slots, via setf.
NAME is usually a symbol, but may instead take the form (NAME
OPTIONS...), where each OPTION is either a single keyword
or (KEYWORD VALUE) where KEYWORD can be one of :conc-name,
:constructor, :copier, :predicate, :type, :named,
:initial-offset, :print-function, :noinline, or :include.
See Info node (cl)Structures for the description of the
options.
The first element in SLOTS can be a doc string.
The rest of the elements in SLOTS is a list of SLOT elements, each of which should either be a symbol, or take the form (SNAME SDEFAULT SOPTIONS...), where SDEFAULT is the default value of that slot and SOPTIONS are keyword-value pairs for that slot.
Supported keywords for slots are:
- :read-only: If this has a non-nil value, that slot cannot be set via setf.
- :documentation: this is a docstring describing the slot.
- :type: the type of the field; currently only used for documentation.
To see the documentation for a defined struct type, use
C-h o (describe-symbol) or M-x cl-describe-type (cl-describe-type).
Probably introduced at or before Emacs version 26.1.
Aliases
defstruct (obsolete since 27.1)
Source Code
;; Defined in /usr/src/emacs/lisp/emacs-lisp/cl-macs.el.gz
;;;###autoload
(defmacro cl-defstruct (struct &rest descs)
"Define a struct type.
This macro defines a new data type called NAME that stores data
in SLOTs. It defines a `make-NAME' constructor, a `copy-NAME'
copier, a `NAME-p' predicate, and slot accessors named `NAME-SLOT'.
You can use the accessors to set the corresponding slots, via `setf'.
NAME is usually a symbol, but may instead take the form (NAME
OPTIONS...), where each OPTION is either a single keyword
or (KEYWORD VALUE) where KEYWORD can be one of `:conc-name',
`:constructor', `:copier', `:predicate', `:type', `:named',
`:initial-offset', `:print-function', `:noinline', or `:include'.
See Info node `(cl)Structures' for the description of the
options.
The first element in SLOTS can be a doc string.
The rest of the elements in SLOTS is a list of SLOT elements,
each of which should either be a symbol, or take the form (SNAME
SDEFAULT SOPTIONS...), where SDEFAULT is the default value of
that slot and SOPTIONS are keyword-value pairs for that slot.
Supported keywords for slots are:
- `:read-only': If this has a non-nil value, that slot cannot be set via `setf'.
- `:documentation': this is a docstring describing the slot.
- `:type': the type of the field; currently only used for documentation.
To see the documentation for a defined struct type, use
\\[describe-symbol] or \\[cl-describe-type].
\(fn NAME &optional DOCSTRING &rest SLOTS)"
(declare (doc-string 2) (indent 1)
(debug
(&define ;Makes top-level form not be wrapped.
[&or symbolp
(gate
symbolp &rest
[&or symbolp
(&or [":conc-name" symbolp]
[":constructor" symbolp &optional cl-lambda-list]
[":copier" symbolp]
[":predicate" symbolp]
[":include" symbolp &rest sexp] ;; Not finished.
[":print-function" sexp]
[":type" symbolp]
[":named"]
[":initial-offset" natnump])])]
[&optional stringp]
;; All the above is for the following def-form.
&rest &or symbolp (symbolp &optional def-form &rest sexp))))
(let* ((name (if (consp struct) (car struct) struct))
(opts (cdr-safe struct))
(slots nil)
(defaults nil)
(conc-name (concat (symbol-name name) "-"))
(constructor (intern (format "make-%s" name)))
(constrs nil)
(copier (intern (format "copy-%s" name)))
(predicate (intern (format "%s-p" name)))
(print-func nil) (print-auto nil)
(safety (if (macroexp-compiling-p) cl--optimize-safety 3))
(include nil)
;; There are 4 types of structs:
;; - `vector' type: means we should use a vector, which can come
;; with or without a tag `name', which is usually in slot 0
;; but obeys :initial-offset.
;; - `list' type: same as `vector' but using lists.
;; - `record' type: means we should use a record, which necessarily
;; comes tagged in slot 0. Currently we'll use the `name' as
;; the tag, but we may want to change it so that the class object
;; is used as the tag.
;; - nil type: this is the "pre-record default", which uses a vector
;; with a tag in slot 0 which is a symbol of the form
;; `cl-struct-NAME'. We need to still support this for backward
;; compatibility with old .elc files.
(tag name)
(tag-symbol (intern (format "cl-struct-%s-tags" name)))
(include-descs nil)
(include-name nil)
(type nil) ;nil here means not specified explicitly.
(named nil)
(cldefsym (if cl--struct-inline 'cl-defsubst 'cl-defun))
(defsym (if cl--struct-inline 'cl-defsubst 'defun))
(forms nil)
(docstring (if (stringp (car descs)) (pop descs)))
pred-form pred-check)
;; Can't use `cl-check-type' yet.
(unless (cl--struct-name-p name)
(signal 'wrong-type-argument (list 'cl-struct-name-p name 'name)))
(setq descs (cons '(cl-tag-slot)
(mapcar (lambda (x) (if (consp x) x (list x)))
descs)))
(while opts
(let ((opt (if (consp (car opts)) (caar opts) (car opts)))
(args (cdr-safe (pop opts))))
(cond ((eq opt :conc-name)
(if args
(setq conc-name (if (car args)
(symbol-name (car args)) ""))))
((eq opt :constructor)
(if (cdr args)
(progn
;; If this defines a constructor of the same name as
;; the default one, don't define the default.
(if (eq (car args) constructor)
(setq constructor nil))
(push args constrs))
(if args (setq constructor (car args)))))
((eq opt :copier)
(if args (setq copier (car args))))
((eq opt :predicate)
(if args (setq predicate (car args))))
((eq opt :include)
;; FIXME: Actually, we can include more than once as long as
;; we include EIEIO classes rather than cl-structs!
(when include-name (error "Can't :include more than once"))
(setq include-name (car args))
(setq include-descs (mapcar (lambda (x)
(if (consp x) x (list x)))
(cdr args))))
((eq opt :print-function)
(setq print-func (car args)))
((eq opt :type)
(setq type (car args))
(unless (memq type '(vector list))
(error "Invalid :type specifier: %s" type)))
((eq opt :named)
(setq named t))
((eq opt :noinline)
(setq defsym 'defun) (setq cldefsym 'cl-defun))
((eq opt :initial-offset)
(setq descs (nconc (make-list (car args) '(cl-skip-slot))
descs)))
(t
(error "Structure option %s unrecognized" opt)))))
(unless (or include-name type)
(setq include-name cl--struct-default-parent))
(when include-name (setq include (cl--struct-get-class include-name)))
(if print-func
(setq print-func
`(progn (funcall #',print-func cl-x cl-s cl-n) t))
(or type (and include (not (cl--struct-class-print include)))
(setq print-auto t
print-func (and (or (not (or include type)) (null print-func))
`(progn
(princ ,(format "#S(%s" name) cl-s))))))
(if include
(let* ((inc-type (cl--struct-class-type include))
(old-descs (cl-struct-slot-info include)))
(and type (not (eq inc-type type))
(error ":type disagrees with :include for %s" name))
(while include-descs
(setcar (memq (or (assq (caar include-descs) old-descs)
(error "No slot %s in included struct %s"
(caar include-descs) include))
old-descs)
(pop include-descs)))
(setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs))
type inc-type
named (if (memq type '(vector list))
(assq 'cl-tag-slot descs)
'true))
(if (cl--struct-class-named include) (setq named t)))
(unless type
(setq named 'true)))
(or named (setq descs (delq (assq 'cl-tag-slot descs) descs)))
(when (and (null predicate) named)
(setq predicate (intern (format "cl--struct-%s-p" name))))
(setq pred-form (and named
(let ((pos (- (length descs)
(length (memq (assq 'cl-tag-slot descs)
descs)))))
(cond
((null type) ;Record type.
`(memq (type-of cl-x) ,tag-symbol))
((eq type 'vector)
`(and (vectorp cl-x)
(>= (length cl-x) ,(length descs))
(memq (aref cl-x ,pos) ,tag-symbol)))
((= pos 0) `(memq (car-safe cl-x) ,tag-symbol))
(t `(and (consp cl-x)
(memq (nth ,pos cl-x) ,tag-symbol))))))
pred-check (and pred-form (> safety 0)
(if (and (eq (cl-caadr pred-form) 'vectorp)
(= safety 1))
(cons 'and (cl-cdddr pred-form))
`(,predicate cl-x))))
(when pred-form
(push `(,defsym ,predicate (cl-x)
(declare (side-effect-free error-free))
,(if (eq (car pred-form) 'and)
(append pred-form '(t))
`(and ,pred-form t)))
forms)
(push `(eval-and-compile
(put ',name 'cl-deftype-satisfies ',predicate))
forms))
(let ((pos 0) (descp descs))
(while descp
(let* ((desc (pop descp))
(slot (pop desc)))
(if (memq slot '(cl-tag-slot cl-skip-slot))
(progn
(push nil slots)
(push (and (eq slot 'cl-tag-slot) `',tag)
defaults))
(if (assq slot descp)
(error "Duplicate slots named %s in %s" slot name))
(let ((accessor (intern (format "%s%s" conc-name slot)))
(default-value (pop desc))
(doc (plist-get desc :documentation))
(access-body
`(progn
,@(and pred-check
(list `(or ,pred-check
(signal 'wrong-type-argument
(list ',name cl-x)))))
,(if (memq type '(nil vector)) `(aref cl-x ,pos)
(if (= pos 0) '(car cl-x)
`(nth ,pos cl-x))))))
(push slot slots)
(push default-value defaults)
;; The arg "cl-x" is referenced by name in e.g. pred-form
;; and pred-check, so changing it is not straightforward.
(push `(,defsym ,accessor (cl-x)
,(concat
;; NB. This will produce incorrect results
;; in some cases, as our coding conventions
;; says that the first line must be a full
;; sentence. However, if we don't word wrap
;; we will have byte-compiler warnings about
;; overly long docstrings. So we can't have
;; a perfect result here, and choose to avoid
;; the byte-compiler warnings.
(internal--format-docstring-line
"Access slot \"%s\" of `%s' struct CL-X." slot name)
(if doc (concat "\n" doc) ""))
(declare (side-effect-free t))
,access-body)
forms)
(when (cl-oddp (length desc))
(push
(macroexp-warn-and-return
(format "Missing value for option `%S' of slot `%s' in struct %s!"
(car (last desc)) slot name)
'nil)
forms)
(when (and (keywordp (car defaults))
(not (keywordp (car desc))))
(let ((kw (car defaults)))
(push
(macroexp-warn-and-return
(format " I'll take `%s' to be an option rather than a default value."
kw)
'nil)
forms)
(push kw desc)
(setcar defaults nil))))
(cond
((eq defsym 'defun)
(unless (plist-get desc ':read-only)
(push `(defun ,(gv-setter accessor) (val cl-x)
(setf ,access-body val))
forms)))
((plist-get desc ':read-only)
(push `(gv-define-expander ,accessor
(lambda (_cl-do _cl-x)
(error "%s is a read-only slot" ',accessor)))
forms))
(t
;; For normal slots, we don't need to define a setf-expander,
;; since gv-get can use the compiler macro to get the
;; same result.
;; (push `(gv-define-setter ,accessor (cl-val cl-x)
;; ;; If cl is loaded only for compilation,
;; ;; the call to cl--struct-setf-expander would
;; ;; cause a warning because it may not be
;; ;; defined at run time. Suppress that warning.
;; (progn
;; (declare-function
;; cl--struct-setf-expander "cl-macs"
;; (x name accessor pred-form pos))
;; (cl--struct-setf-expander
;; cl-val cl-x ',name ',accessor
;; ,(and pred-check `',pred-check)
;; ,pos)))
;; forms)
))
(if print-auto
(nconc print-func
(list `(princ ,(format " %s" slot) cl-s)
`(prin1 (,accessor cl-x) cl-s)))))))
(setq pos (1+ pos))))
(setq slots (nreverse slots)
defaults (nreverse defaults))
(and copier
(push `(defalias ',copier #'copy-sequence)
forms))
(if constructor
(push (list constructor
(cons '&key (delq nil (copy-sequence slots))))
constrs))
(pcase-dolist (`(,cname ,args ,doc) constrs)
(let* ((anames (cl--arglist-args args))
(make (cl-mapcar (lambda (s d) (if (memq s anames) s d))
slots defaults))
;; `cl-defsubst' is fundamentally broken: it substitutes
;; its arguments into the body's `sexp' much too naively
;; when inlinling, which results in various problems.
;; For example it generates broken code if your
;; argument's name happens to be the same as some
;; function used within the body.
;; E.g. (cl-defsubst sm-foo (list) (list list))
;; will expand `(sm-foo 1)' to `(1 1)' rather than to `(list t)'!
;; Try to catch this known case!
(con-fun (or type #'record))
(unsafe-cl-defsubst
(or (memq con-fun args) (assq con-fun args))))
(push `(,(if unsafe-cl-defsubst 'cl-defun cldefsym) ,cname
(&cl-defs (nil ,@descs) ,@args)
,(if (stringp doc) doc
(format "Constructor for objects of type `%s'." name))
,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs)))
'((declare (side-effect-free t))))
(,con-fun ,@make))
forms)))
(if print-auto (nconc print-func (list '(princ ")" cl-s) t)))
;; Don't bother adding to cl-custom-print-functions since it's not used
;; by anything anyway!
;;(if print-func
;; (push `(if (boundp 'cl-custom-print-functions)
;; (push
;; ;; The auto-generated function does not pay attention to
;; ;; the depth argument cl-n.
;; (lambda (cl-x cl-s ,(if print-auto '_cl-n 'cl-n))
;; (and ,pred-form ,print-func))
;; cl-custom-print-functions))
;; forms))
`(progn
(defvar ,tag-symbol)
,@(nreverse forms)
:autoload-end
;; Call cl-struct-define during compilation as well, so that
;; a subsequent cl-defstruct in the same file can correctly include this
;; struct as a parent.
(eval-and-compile
(cl-struct-define ',name ,docstring ',include-name
',(or type 'record) ,(eq named t) ',descs
',tag-symbol ',tag ',print-auto))
',name)))