diff options
| -rw-r--r-- | doc/lispref/records.texi | 3 | ||||
| -rw-r--r-- | doc/misc/cl.texi | 51 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-extra.el | 6 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-generic.el | 24 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 62 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-preloaded.el | 6 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-print.el | 2 | ||||
| -rw-r--r-- | test/lisp/emacs-lisp/cl-lib-tests.el | 7 |
8 files changed, 87 insertions, 74 deletions
diff --git a/doc/lispref/records.texi b/doc/lispref/records.texi index aeba77a70e7..618f30a72ce 100644 --- a/doc/lispref/records.texi +++ b/doc/lispref/records.texi @@ -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 diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi index 079f534168c..2339d576319 100644 --- a/doc/misc/cl.texi +++ b/doc/misc/cl.texi @@ -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, diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 021ef232749..3852ceb6c31 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -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) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 8c6d3d5d51f..e15c94242fb 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -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))))) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 58bcdd52acf..c282938a9bf 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -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))) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 482b579f11a..7432dd4978d 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -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 diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index 8a8d4a4c1af..65c86d2b65e 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -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)) diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index 093cb3476c1..6b930a8d17a 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -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 |