Commit 05654828 authored by Lars Brinkhoff's avatar Lars Brinkhoff
Browse files

Make cl-defstruct use records.

* lisp/emacs-lisp/cl-extra.el (cl--describe-class)
(cl--describe-class-slots): Use the new `type-of'.

* lisp/emacs-lisp/cl-generic.el (cl--generic-struct-tag): Use type-of.
(cl--generic-struct-specializers): Adjust to new tag.

* lisp/emacs-lisp/cl-macs.el (cl-defstruct): When type is nil, use records.
Use the type symbol as the tag.  Use copy-record to copy structs.
(cl--defstruct-predicate): New function.
(cl--pcase-mutually-exclusive-p): Use it.
(cl-struct-sequence-type): Can now return `record'.

* lisp/emacs-lisp/cl-preloaded.el (cl--make-slot-desc): Adjust ad-hoc
code to new format.
(cl--struct-register-child): Work with records.
(cl-struct-define): Don't touch the tag's symbol-value and
symbol-function slots when we use the type as tag.

* lisp/emacs-lisp/cl-print.el (cl-print-object): Adjust to new tag.

* test/lisp/emacs-lisp/cl-lib-tests.el (cl-lib-defstruct-record):
New test.

* doc/lispref/records.texi, doc/misc/cl.texi: Update for records.
parent a2c33430
......@@ -8,7 +8,8 @@
@cindex record
The purpose of records is to allow programmers to create objects
with new types that are not built into Emacs.
with new types that are not built into Emacs. They are used as the
underlying representation of @code{cl-defstruct} instances.
Internally, a record object is much like a vector; its slots can be
accessed using @code{aref}. However, the first slot is used to hold
......
......@@ -4012,10 +4012,7 @@ Given a @code{person}, @code{(copy-person @var{p})} makes a new
object of the same type whose slots are @code{eq} to those of @var{p}.
Given any Lisp object @var{x}, @code{(person-p @var{x})} returns
true if @var{x} looks like a @code{person}, and false otherwise. (Again,
in Common Lisp this predicate would be exact; in Emacs Lisp the
best it can do is verify that @var{x} is a vector of the correct
length that starts with the correct tag symbol.)
true if @var{x} is a @code{person}, and false otherwise.
Accessors like @code{person-name} normally check their arguments
(effectively using @code{person-p}) and signal an error if the
......@@ -4221,16 +4218,16 @@ allow for such a feature, so this package simply ignores
@code{:print-function}.
@item :type
The argument should be one of the symbols @code{vector} or @code{list}.
This tells which underlying Lisp data type should be used to implement
the new structure type. Vectors are used by default, but
@code{(:type list)} will cause structure objects to be stored as
lists instead.
The argument should be one of the symbols @code{vector} or
@code{list}. This tells which underlying Lisp data type should be
used to implement the new structure type. Records are used by
default, but @code{(:type vector)} will cause structure objects to be
stored as vectors and @code{(:type list)} lists instead.
The vector representation for structure objects has the advantage
that all structure slots can be accessed quickly, although creating
vectors is a bit slower in Emacs Lisp. Lists are easier to create,
but take a relatively long time accessing the later slots.
The record and vector representations for structure objects have the
advantage that all structure slots can be accessed quickly, although
creating them are a bit slower in Emacs Lisp. Lists are easier to
create, but take a relatively long time accessing the later slots.
@item :named
This option, which takes no arguments, causes a characteristic ``tag''
......@@ -4239,21 +4236,24 @@ symbol to be stored at the front of the structure object. Using
structure type stored as plain vectors or lists with no identifying
features.
The default, if you don't specify @code{:type} explicitly, is to
use named vectors. Therefore, @code{:named} is only useful in
conjunction with @code{:type}.
The default, if you don't specify @code{:type} explicitly, is to use
records, which are always tagged. Therefore, @code{:named} is only
useful in conjunction with @code{:type}.
@example
(cl-defstruct (person1) name age sex)
(cl-defstruct (person2 (:type list) :named) name age sex)
(cl-defstruct (person3 (:type list)) name age sex)
(cl-defstruct (person4 (:type vector)) name age sex)
(setq p1 (make-person1))
@result{} [cl-struct-person1 nil nil nil]
@result{} #s(person1 nil nil nil)
(setq p2 (make-person2))
@result{} (person2 nil nil nil)
(setq p3 (make-person3))
@result{} (nil nil nil)
(setq p4 (make-person4))
@result{} [nil nil nil]
(person1-p p1)
@result{} t
......@@ -4293,9 +4293,9 @@ introspection functions.
@defun cl-struct-sequence-type struct-type
This function returns the underlying data structure for
@code{struct-type}, which is a symbol. It returns @code{vector} or
@code{list}, or @code{nil} if @code{struct-type} is not actually a
structure.
@code{struct-type}, which is a symbol. It returns @code{record},
@code{vector} or @code{list}, or @code{nil} if @code{struct-type} is
not actually a structure.
@end defun
@defun cl-struct-slot-info struct-type
......@@ -4562,9 +4562,8 @@ set down in Steele's book.
The variable @code{cl--gensym-counter} starts out with zero.
The @code{cl-defstruct} facility is compatible, except that structures
are of type @code{:type vector :named} by default rather than some
special, distinct type. Also, the @code{:type} slot option is ignored.
The @code{cl-defstruct} facility is compatible, except that the
@code{:type} slot option is ignored.
The second argument of @code{cl-check-type} is treated differently.
......@@ -4713,9 +4712,9 @@ Lisp. Rational numbers and complex numbers are not present,
nor are large integers (all integers are ``fixnums''). All
arrays are one-dimensional. There are no readtables or pathnames;
streams are a set of existing data types rather than a new data
type of their own. Hash tables, random-states, structures, and
packages (obarrays) are built from Lisp vectors or lists rather
than being distinct types.
type of their own. Hash tables, random-states, and packages
(obarrays) are built from Lisp vectors or lists rather than being
distinct types.
@item
The Common Lisp Object System (CLOS) is not implemented,
......
......@@ -775,8 +775,7 @@ including `cl-block' and `cl-eval-when'."
(defun cl--describe-class (type &optional class)
(unless class (setq class (cl--find-class type)))
(let ((location (find-lisp-object-file-name type 'define-type))
;; FIXME: Add a `cl-class-of' or `cl-typeof' or somesuch.
(metatype (cl--class-name (symbol-value (aref class 0)))))
(metatype (type-of class)))
(insert (symbol-name type)
(substitute-command-keys " is a type (of kind `"))
(help-insert-xref-button (symbol-name metatype)
......@@ -901,8 +900,7 @@ including `cl-block' and `cl-eval-when'."
"Print help description for the slots in CLASS.
Outputs to the current buffer."
(let* ((slots (cl--class-slots class))
;; FIXME: Add a `cl-class-of' or `cl-typeof' or somesuch.
(metatype (cl--class-name (symbol-value (aref class 0))))
(metatype (type-of class))
;; ¡For EIEIO!
(cslots (condition-case nil
(cl-struct-slot-value metatype 'class-slots class)
......
......@@ -1082,24 +1082,8 @@ These match if the argument is `eql' to VAL."
;;; Support for cl-defstructs specializers.
(defun cl--generic-struct-tag (name &rest _)
;; It's tempting to use (and (vectorp ,name) (aref ,name 0))
;; but that would suffer from some problems:
;; - the vector may have size 0.
;; - when called on an actual vector (rather than an object), we'd
;; end up returning an arbitrary value, possibly colliding with
;; other tagcode's values.
;; - it can also result in returning all kinds of irrelevant
;; values which would end up filling up the method-cache with
;; lots of irrelevant/redundant entries.
;; FIXME: We could speed this up by introducing a dedicated
;; vector type at the C level, so we could do something like
;; (and (vector-objectp ,name) (aref ,name 0))
`(and (vectorp ,name)
(> (length ,name) 0)
(let ((tag (aref ,name 0)))
(and (symbolp tag)
(eq (symbol-function tag) :quick-object-witness-check)
tag))))
;; Use exactly the same code as for `typeof'.
`(if ,name (type-of ,name) 'null))
(defun cl--generic-class-parents (class)
(let ((parents ())
......@@ -1113,8 +1097,8 @@ These match if the argument is `eql' to VAL."
(nreverse parents)))
(defun cl--generic-struct-specializers (tag &rest _)
(and (symbolp tag) (boundp tag)
(let ((class (symbol-value tag)))
(and (symbolp tag)
(let ((class (get tag 'cl--class)))
(when (cl-typep class 'cl-structure-class)
(cl--generic-class-parents class)))))
......
......@@ -2604,11 +2604,24 @@ non-nil value, that slot cannot be set via `setf'.
(print-func nil) (print-auto nil)
(safety (if (cl--compiling-file) cl--optimize-safety 3))
(include nil)
(tag (intern (format "cl-struct-%s" name)))
;; 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)
(type nil) ;nil here means not specified explicitly.
(named nil)
(forms nil)
(docstring (if (stringp (car descs)) (pop descs)))
......@@ -2648,7 +2661,9 @@ non-nil value, that slot cannot be set via `setf'.
((eq opt :print-function)
(setq print-func (car args)))
((eq opt :type)
(setq type (car args)))
(setq type (car args))
(unless (memq type '(vector list))
(error "Invalid :type specifier: %s" type)))
((eq opt :named)
(setq named t))
((eq opt :initial-offset)
......@@ -2680,13 +2695,11 @@ non-nil value, that slot cannot be set via `setf'.
(pop include-descs)))
(setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs))
type inc-type
named (if type (assq 'cl-tag-slot descs) 'true))
(if (cl--struct-class-named include) (setq tag name named t)))
(if type
(progn
(or (memq type '(vector list))
(error "Invalid :type specifier: %s" type))
(if named (setq tag name)))
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)
......@@ -2696,7 +2709,9 @@ non-nil value, that slot cannot be set via `setf'.
(length (memq (assq 'cl-tag-slot descs)
descs)))))
(cond
((memq type '(nil vector))
((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)))
......@@ -2793,7 +2808,9 @@ non-nil value, that slot cannot be set via `setf'.
(setq slots (nreverse slots)
defaults (nreverse defaults))
(and copier
(push `(defalias ',copier #'copy-sequence) forms))
(push `(defalias ',copier
,(if (null type) '#'copy-record '#'copy-sequence))
forms))
(if constructor
(push (list constructor
(cons '&key (delq nil (copy-sequence slots))))
......@@ -2808,7 +2825,7 @@ non-nil value, that slot cannot be set via `setf'.
(format "Constructor for objects of type `%s'." name))
,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs)))
'((declare (side-effect-free t))))
(,(or type #'vector) ,@make))
(,(or type #'record) ,@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
......@@ -2866,6 +2883,15 @@ is a shorthand for (NAME NAME)."
,pat)))
fields)))
(defun cl--defstruct-predicate (type)
(let ((cons (assq (cl-struct-sequence-type type)
`((list . consp)
(vector . vectorp)
(nil . recordp)))))
(if cons
(cdr cons)
'recordp)))
(defun cl--pcase-mutually-exclusive-p (orig pred1 pred2)
"Extra special cases for `cl-typep' predicates."
(let* ((x1 pred1) (x2 pred2)
......@@ -2888,14 +2914,12 @@ is a shorthand for (NAME NAME)."
(memq c2 (cl--struct-all-parents c1)))))))
(let ((c1 (and (symbolp t1) (cl--find-class t1))))
(and c1 (cl--struct-class-p c1)
(funcall orig (if (eq 'list (cl-struct-sequence-type t1))
'consp 'vectorp)
(funcall orig (cl--defstruct-predicate t1)
pred2)))
(let ((c2 (and (symbolp t2) (cl--find-class t2))))
(and c2 (cl--struct-class-p c2)
(funcall orig pred1
(if (eq 'list (cl-struct-sequence-type t2))
'consp 'vectorp))))
(cl--defstruct-predicate t2))))
(funcall orig pred1 pred2))))
(advice-add 'pcase--mutually-exclusive-p
:around #'cl--pcase-mutually-exclusive-p)
......@@ -2903,8 +2927,8 @@ is a shorthand for (NAME NAME)."
(defun cl-struct-sequence-type (struct-type)
"Return the sequence used to build STRUCT-TYPE.
STRUCT-TYPE is a symbol naming a struct type. Return `vector' or
`list', or nil if STRUCT-TYPE is not a struct type. "
STRUCT-TYPE is a symbol naming a struct type. Return `record',
`vector`, or `list' if STRUCT-TYPE is a struct type, nil otherwise."
(declare (side-effect-free t) (pure t))
(cl--struct-class-type (cl--struct-get-class struct-type)))
......
......@@ -64,7 +64,7 @@
;; cl--slot-descriptor.
;; BEWARE: Obviously, it's important to keep the two in sync!
(lambda (name &optional initform type props)
(vector 'cl-struct-cl-slot-descriptor
(record 'cl-slot-descriptor
name initform type props)))
(defun cl--struct-get-class (name)
......@@ -101,7 +101,7 @@
(defun cl--struct-register-child (parent tag)
;; Can't use (cl-typep parent 'cl-structure-class) at this stage
;; because `cl-structure-class' is defined later.
(while (vectorp parent)
(while (recordp parent)
(add-to-list (cl--struct-class-children-sym parent) tag)
;; Only register ourselves as a child of the leftmost parent since structs
;; can only only have one parent.
......@@ -150,7 +150,7 @@
parent name))))
(add-to-list 'current-load-list `(define-type . ,name))
(cl--struct-register-child parent-class tag)
(unless (eq named t)
(unless (or (eq named t) (eq tag name))
;; We used to use `defconst' instead of `set' but that
;; has a side-effect of purecopying during the dump, so that the
;; class object stored in the tag ends up being a *copy* of the
......
......@@ -137,7 +137,7 @@ call other entry points instead, such as `cl-prin1'."
(cl-defmethod cl-print-object ((object cl-structure-object) stream)
(princ "#s(" stream)
(let* ((class (symbol-value (aref object 0)))
(let* ((class (cl-find-class (type-of object)))
(slots (cl--struct-class-slots class)))
(princ (cl--struct-class-name class) stream)
(dotimes (i (length slots))
......
......@@ -519,4 +519,11 @@
(ert-deftest cl-lib-symbol-macrolet-2 ()
(should (equal (cl-lib-symbol-macrolet-4+5) (+ 4 5))))
(ert-deftest cl-lib-defstruct-record ()
(cl-defstruct foo x)
(let ((x (make-foo :x 42)))
(should (recordp x))
(should (eq (type-of x) 'foo))
(should (eql (foo-x x) 42))))
;;; cl-lib.el ends here
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment