From 056548283884d61b1b9637c3e56855ce3a17274d Mon Sep 17 00:00:00 2001 From: Lars Brinkhoff Date: Tue, 14 Mar 2017 13:52:40 +0100 Subject: 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. --- lisp/emacs-lisp/cl-macs.el | 62 ++++++++++++++++++++++++++++++++-------------- 1 file changed, 43 insertions(+), 19 deletions(-) (limited to 'lisp/emacs-lisp/cl-macs.el') 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))) -- cgit v1.2.3 From 2c68192c6b029bb839193c81cf2a16dad26305c6 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 24 Mar 2017 09:21:52 -0400 Subject: Backward compatibility with pre-existing struct instances. * lisp/emacs-lisp/cl-lib.el (cl--old-struct-type-of): New function. (cl-old-struct-compat-mode): New minor mode. * lisp/emacs-lisp/cl-macs.el (cl-defstruct): Pass `record' to cl-struct-define to signal use of record objects. * lisp/emacs-lisp/cl-preloaded.el (cl--struct-get-class, cl-struct-define): Enable legacy defstruct compatibility. * test/lisp/emacs-lisp/cl-lib-tests.el (cl-lib-old-struct, old-struct): New tests. * doc/lispref/elisp.texi, doc/lispref/records.texi: Document `old-struct-compat'. --- doc/lispref/elisp.texi | 1 + doc/lispref/records.texi | 17 ++++++++++++++++- lisp/emacs-lisp/cl-lib.el | 36 ++++++++++++++++++++++++++++++++++++ lisp/emacs-lisp/cl-macs.el | 4 ++-- lisp/emacs-lisp/cl-preloaded.el | 6 ++++++ test/lisp/emacs-lisp/cl-lib-tests.el | 23 +++++++++++++++++++++++ 6 files changed, 84 insertions(+), 3 deletions(-) (limited to 'lisp/emacs-lisp/cl-macs.el') diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index 0f7efb6f187..3a348aae98e 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -423,6 +423,7 @@ Sequences, Arrays, and Vectors Records * Record Functions:: Functions for records. +* Backward Compatibility:: Compatibility for cl-defstruct. Hash Tables diff --git a/doc/lispref/records.texi b/doc/lispref/records.texi index 822fd2bf36e..9a5d900cfc9 100644 --- a/doc/lispref/records.texi +++ b/doc/lispref/records.texi @@ -26,7 +26,8 @@ evaluating it is the same record. This does not evaluate or even examine the slots. @xref{Self-Evaluating Forms}. @menu -* Record Functions:: Functions for records. +* Record Functions:: Functions for records. +* Backward Compatibility:: Compatibility for cl-defstruct. @end menu @node Record Functions @@ -98,3 +99,17 @@ the copied record, are also visible in the original record. @end group @end example @end defun + +@node Backward Compatibility +@section Backward Compatibility + + Code compiled with older versions of @code{cl-defstruct} that +doesn't use records may run into problems when used in a new Emacs. +To alleviate this, Emacs detects when an old @code{cl-defstruct} is +used, and enables a mode in which @code{type-of} handles old struct +objects as if they were records. + +@defun cl-old-struct-compat-mode arg +If @var{arg} is positive, enable backward compatibility with old-style +structs. +@end defun diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 8c4455a3dad..1f8615fad3e 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -639,6 +639,42 @@ If ALIST is non-nil, the new pairs are prepended to it." (require 'cl-macs) (require 'cl-seq)) +(defun cl--old-struct-type-of (orig-fun object) + (or (and (vectorp object) + (let ((tag (aref object 0))) + (when (and (symbolp tag) + (string-prefix-p "cl-struct-" (symbol-name tag))) + (unless (eq (symbol-function tag) + :quick-object-witness-check) + ;; Old-style old-style struct: + ;; Convert to new-style old-style struct! + (let* ((type (intern (substring (symbol-name tag) + (length "cl-struct-")))) + (class (cl--struct-get-class type))) + ;; If the `cl-defstruct' was recompiled after the code + ;; which constructed `object', `cl--struct-get-class' may + ;; not have called `cl-struct-define' and setup the tag + ;; symbol for us. + (unless (eq (symbol-function tag) + :quick-object-witness-check) + (set tag class) + (fset tag :quick-object-witness-check)))) + (cl--class-name (symbol-value tag))))) + (funcall orig-fun object))) + +;;;###autoload +(define-minor-mode cl-old-struct-compat-mode + "Enable backward compatibility with old-style structs. +This can be needed when using code byte-compiled using the old +macro-expansion of `cl-defstruct' that used vectors objects instead +of record objects." + :global t + (cond + (cl-old-struct-compat-mode + (advice-add 'type-of :around #'cl--old-struct-type-of)) + (t + (advice-remove 'type-of #'cl--old-struct-type-of)))) + ;; Local variables: ;; byte-compile-dynamic: t ;; End: diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index c282938a9bf..25c9f999920 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2847,8 +2847,8 @@ non-nil value, that slot cannot be set via `setf'. ;; struct as a parent. (eval-and-compile (cl-struct-define ',name ,docstring ',include-name - ',type ,(eq named t) ',descs ',tag-symbol ',tag - ',print-auto)) + ',(or type 'record) ,(eq named t) ',descs + ',tag-symbol ',tag ',print-auto)) ',name))) ;;; Add cl-struct support to pcase diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 7432dd4978d..ab6354de7cd 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -110,6 +110,12 @@ ;;;###autoload (defun cl-struct-define (name docstring parent type named slots children-sym tag print) + (unless type + ;; Legacy defstruct, using tagged vectors. Enable backward compatibility. + (cl-old-struct-compat-mode 1)) + (if (eq type 'record) + ;; Defstruct using record objects. + (setq type nil)) (cl-assert (or type (not named))) (if (boundp children-sym) (add-to-list children-sym tag) diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index 6b930a8d17a..564ddab67db 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -526,4 +526,27 @@ (should (eq (type-of x) 'foo)) (should (eql (foo-x x) 42)))) +(ert-deftest old-struct () + (cl-defstruct foo x) + (let ((x [cl-struct-foo]) + (saved cl-old-struct-compat-mode)) + (cl-old-struct-compat-mode -1) + (should (eq (type-of x) 'vector)) + + (cl-old-struct-compat-mode 1) + (let ((cl-struct-foo (cl--struct-get-class 'foo))) + (setf (symbol-function 'cl-struct-foo) :quick-object-witness-check) + (should (eq (type-of x) 'foo)) + (should (eq (type-of [foo]) 'vector))) + + (cl-old-struct-compat-mode (if saved 1 -1)))) + +(ert-deftest cl-lib-old-struct () + (let ((saved cl-old-struct-compat-mode)) + (cl-old-struct-compat-mode -1) + (cl-struct-define 'foo "" 'cl-structure-object nil nil nil + 'cl-struct-foo-tags 'cl-struct-foo t) + (should cl-old-struct-compat-mode) + (cl-old-struct-compat-mode (if saved 1 -1)))) + ;;; cl-lib.el ends here -- cgit v1.2.3 From a2b3fea957440b8358d3632a4a05e41dee964b5d Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Fri, 7 Apr 2017 18:54:40 -0700 Subject: Deprecate copy-record in favor of copy-sequence Since copy-sequence seems to be needed anyway for records, have it work on records, and remove copy-record as being superfluous. * doc/lispref/records.texi (Records, Record Functions): * lisp/emacs-lisp/cl-macs.el (cl-defstruct): * lisp/emacs-lisp/eieio.el (make-instance, clone): * test/src/alloc-tests.el (record-3): Use copy-sequence, not copy-record, to copy records. * doc/lispref/sequences.texi (Sequence Functions) (Array Functions): Document that aref and copy-sequence work on records. * etc/NEWS: Omit copy-record. * src/alloc.c (Fcopy_record): Remove. * src/data.c (Faref): Document that arg can be a record. * src/fns.c (Fcopy_sequence): Copy records, too. --- doc/lispref/records.texi | 37 +++---------------------------------- doc/lispref/sequences.texi | 23 +++++++++++------------ etc/NEWS | 6 +++--- lisp/emacs-lisp/cl-macs.el | 3 +-- lisp/emacs-lisp/eieio.el | 6 +++--- src/alloc.c | 14 -------------- src/data.c | 4 ++-- src/fns.c | 12 +++++++++--- test/src/alloc-tests.el | 2 +- 9 files changed, 33 insertions(+), 74 deletions(-) (limited to 'lisp/emacs-lisp/cl-macs.el') diff --git a/doc/lispref/records.texi b/doc/lispref/records.texi index 2533a8a4ca1..7cc36f14068 100644 --- a/doc/lispref/records.texi +++ b/doc/lispref/records.texi @@ -13,8 +13,9 @@ underlying representation of @code{cl-defstruct} and @code{defclass} 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 -its type as returned by @code{type-of}. Also, in the current +accessed using @code{aref} and it can be copied using +@code{copy-sequence}. However, the first slot is used to hold its +type as returned by @code{type-of}. Also, in the current implementation records can have at most 4096 slots, whereas vectors can be much larger. Like arrays, records use zero-origin indexing: the first slot has index 0. @@ -74,38 +75,6 @@ This function returns a new record with type @var{type} and @end example @end defun -@defun copy-record record -This function returns a shallow copy of @var{record}. The copy is the -same type as the original record, and it has the same slots in the -same order. - - Storing a new slot into the copy does not affect the original -@var{record}, and vice versa. However, the slots of the new record -are not copies; they are identical (@code{eq}) to the slots of the -original. Therefore, changes made within these slots, as found via -the copied record, are also visible in the original record. - -@example -@group -(setq x (record 'foo 1 2)) - @result{} #s(foo 1 2) -@end group -@group -(setq y (copy-record x)) - @result{} #s(foo 1 2) -@end group - -@group -(eq x y) - @result{} nil -@end group -@group -(equal x y) - @result{} t -@end group -@end example -@end defun - @node Backward Compatibility @section Backward Compatibility diff --git a/doc/lispref/sequences.texi b/doc/lispref/sequences.texi index 2c88ee38cb1..93e8fa8a5fa 100644 --- a/doc/lispref/sequences.texi +++ b/doc/lispref/sequences.texi @@ -151,20 +151,19 @@ This function generalizes @code{aref} (@pxref{Array Functions}) and @code{nth} (@pxref{Definition of nth}). @end defun -@defun copy-sequence sequence +@defun copy-sequence seqr @cindex copying sequences -This function returns a copy of @var{sequence}. The copy is the same -type of object as the original sequence, and it has the same elements -in the same order. +This function returns a copy of @var{seqr}, which should be either a +sequence or a record. The copy is the same type of object as the +original, and it has the same elements in the same order. Storing a new element into the copy does not affect the original -@var{sequence}, and vice versa. However, the elements of the new -sequence are not copies; they are identical (@code{eq}) to the elements +@var{seqr}, and vice versa. However, the elements of the copy +are not copies; they are identical (@code{eq}) to the elements of the original. Therefore, changes made within these elements, as -found via the copied sequence, are also visible in the original -sequence. +found via the copy, are also visible in the original. -If the sequence is a string with text properties, the property list in +If the argument is a string with text properties, the property list in the copy is itself a copy, not shared with the original's property list. However, the actual values of the properties are shared. @xref{Text Properties}. @@ -1148,10 +1147,10 @@ vector, a string, a bool-vector or a char-table). @end example @end defun -@defun aref array index +@defun aref arr index @cindex array elements -This function returns the @var{index}th element of @var{array}. The -first element is at index zero. +This function returns the @var{index}th element of the array or record +@var{arr}. The first element is at index zero. @example @group diff --git a/etc/NEWS b/etc/NEWS index aaca229d5cd..e351abc159f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -863,9 +863,9 @@ instead of its first. +++ ** Emacs now supports records for user-defined types, via the new -functions 'copy-record', 'make-record', 'record', and 'recordp'. -Records are now used internally to represent cl-defstruct and defclass -instances, for example. +functions 'make-record', 'record', and 'recordp'. Records are now +used internally to represent cl-defstruct and defclass instances, for +example. +++ ** 'save-some-buffers' now uses 'save-some-buffers-default-predicate' diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 25c9f999920..ecb89fd51d7 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2808,8 +2808,7 @@ non-nil value, that slot cannot be set via `setf'. (setq slots (nreverse slots) defaults (nreverse defaults)) (and copier - (push `(defalias ',copier - ,(if (null type) '#'copy-record '#'copy-sequence)) + (push `(defalias ',copier #'copy-sequence) forms)) (if constructor (push (list constructor diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 858b2fdaa04..e21d46e5289 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -699,8 +699,8 @@ SLOTS are the initialization slots used by `initialize-instance'. This static method is called when an object is constructed. It allocates the vector used to represent an EIEIO object, and then calls `initialize-instance' on that object." - (let* ((new-object (copy-record (eieio--class-default-object-cache - (eieio--class-object class))))) + (let* ((new-object (copy-sequence (eieio--class-default-object-cache + (eieio--class-object class))))) (if (and slots (let ((x (car slots))) (or (stringp x) (null x)))) @@ -804,7 +804,7 @@ first and modify the returned object.") (cl-defmethod clone ((obj eieio-default-superclass) &rest params) "Make a copy of OBJ, and then apply PARAMS." - (let ((nobj (copy-record obj))) + (let ((nobj (copy-sequence obj))) (if (stringp (car params)) (funcall (if eieio-backward-compatibility #'ignore #'message) "Obsolete name %S passed to clone" (pop params))) diff --git a/src/alloc.c b/src/alloc.c index fad84b8a0b3..88a1a1ed660 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3440,19 +3440,6 @@ usage: (record TYPE &rest SLOTS) */) } -DEFUN ("copy-record", Fcopy_record, Scopy_record, 1, 1, 0, - doc: /* Return a new record that is a shallow copy of the argument RECORD. */) - (Lisp_Object record) -{ - CHECK_RECORD (record); - ptrdiff_t size = ASIZE (record) & PSEUDOVECTOR_SIZE_MASK; - struct Lisp_Vector *new = allocate_record (size); - memcpy (new->contents, XVECTOR (record)->contents, - size * sizeof (Lisp_Object)); - return make_lisp_ptr (new, Lisp_Vectorlike); -} - - DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0, doc: /* Return a newly created vector of length LENGTH, with each element being INIT. See also the function `vector'. */) @@ -7523,7 +7510,6 @@ The time is in seconds as a floating point value. */); defsubr (&Slist); defsubr (&Svector); defsubr (&Srecord); - defsubr (&Scopy_record); defsubr (&Sbool_vector); defsubr (&Smake_byte_code); defsubr (&Smake_list); diff --git a/src/data.c b/src/data.c index 3ffca54658d..903e809d235 100644 --- a/src/data.c +++ b/src/data.c @@ -2266,8 +2266,8 @@ function chain of symbols. */) /* Extract and set vector and string elements. */ DEFUN ("aref", Faref, Saref, 2, 2, 0, - doc: /* Return the element of ARRAY at index IDX. -ARRAY may be a vector, a string, a char-table, a bool-vector, + doc: /* Return the element of ARG at index IDX. +ARG may be a vector, a string, a char-table, a bool-vector, a record, or a byte-code object. IDX starts at 0. */) (register Lisp_Object array, Lisp_Object idx) { diff --git a/src/fns.c b/src/fns.c index 47da5f8b4bc..2f07c2ccfb7 100644 --- a/src/fns.c +++ b/src/fns.c @@ -475,13 +475,19 @@ usage: (vconcat &rest SEQUENCES) */) DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0, - doc: /* Return a copy of a list, vector, string or char-table. -The elements of a list or vector are not copied; they are shared -with the original. */) + doc: /* Return a copy of a list, vector, string, char-table or record. +The elements of a list, vector or record are not copied; they are +shared with the original. */) (Lisp_Object arg) { if (NILP (arg)) return arg; + if (RECORDP (arg)) + { + ptrdiff_t size = ASIZE (arg) & PSEUDOVECTOR_SIZE_MASK; + return Frecord (size, XVECTOR (arg)->contents); + } + if (CHAR_TABLE_P (arg)) { return copy_char_table (arg); diff --git a/test/src/alloc-tests.el b/test/src/alloc-tests.el index 8b4ef8ce7d2..1cf1fc3be5c 100644 --- a/test/src/alloc-tests.el +++ b/test/src/alloc-tests.el @@ -47,7 +47,7 @@ (ert-deftest record-3 () (let* ((x (record 'foo 1 2 3)) - (y (copy-record x))) + (y (copy-sequence x))) (should-not (eq x y)) (dotimes (i 4) (should (eql (aref x i) (aref y i)))))) -- cgit v1.2.3 From 89898e43c7ceef28bb3c2116b4d8a3ec96d9c8da Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 21 Apr 2017 12:12:42 -0400 Subject: * lisp/emacs-lisp/cl-macs.el: Fix symbol-macrolet Revert 0d112c00ba0ec14bd3014efcd3430b9ddcfe1fc1 (to fix bug#26325) and use a different fix for bug#26068. (cl--symbol-macro-key): New function. (cl--sm-macroexpand, cl-symbol-macrolet): Use it instead of `symbol-name`. * test/lisp/emacs-lisp/cl-lib-tests.el (cl-lib-symbol-macrolet): Failure is not expected any more. --- lisp/emacs-lisp/cl-macs.el | 17 +++++++++++++---- test/lisp/emacs-lisp/cl-lib-tests.el | 1 - 2 files changed, 13 insertions(+), 5 deletions(-) (limited to 'lisp/emacs-lisp/cl-macs.el') diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index ecb89fd51d7..db1518ce611 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2047,6 +2047,12 @@ This is like `cl-flet', but for macros instead of functions. cl--old-macroexpand (symbol-function 'macroexpand))) +(defun cl--symbol-macro-key (sym) + "Return the key used in `macroexpand-all-environment' for symbol macro SYM." + ;; In the past we've used `symbol-name' instead, but that doesn't + ;; preserve the `eq'uality between different symbols of the same name. + `(:cl-symbol-macro . ,sym)) + (defun cl--sm-macroexpand (exp &optional env) "Special macro expander used inside `cl-symbol-macrolet'. This function replaces `macroexpand' during macro expansion @@ -2059,8 +2065,10 @@ except that it additionally expands symbol macros." (pcase exp ((pred symbolp) ;; Perform symbol-macro expansion. - (when (cdr (assq exp env)) - (setq exp (cadr (assq exp env))))) + ;; FIXME: Calling `cl--symbol-macro-key' for every var reference + ;; is a bit more costly than I'd like. + (when (cdr (assoc (cl--symbol-macro-key exp) env)) + (setq exp (cadr (assoc (cl--symbol-macro-key exp) env))))) (`(setq . ,_) ;; Convert setq to setf if required by symbol-macro expansion. (let* ((args (mapcar (lambda (f) (cl--sm-macroexpand f env)) @@ -2078,7 +2086,7 @@ except that it additionally expands symbol macros." (let ((letf nil) (found nil) (nbs ())) (dolist (binding bindings) (let* ((var (if (symbolp binding) binding (car binding))) - (sm (assq var env))) + (sm (assoc (cl--symbol-macro-key var) env))) (push (if (not (cdr sm)) binding (let ((nexp (cadr sm))) @@ -2149,7 +2157,8 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). (let ((expansion ;; FIXME: For N bindings, this will traverse `body' N times! (macroexpand-all (macroexp-progn body) - (cons (list (caar bindings) + (cons (list (cl--symbol-macro-key + (caar bindings)) (cl-cadar bindings)) macroexpand-all-environment)))) (if (or (null (cdar bindings)) (cl-cddar bindings)) diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index 564ddab67db..65bd97f3b2d 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -495,7 +495,6 @@ (ert-deftest cl-lib-symbol-macrolet () ;; bug#26325 - :expected-result :failed (should (equal (cl-flet ((f (x) (+ x 5))) (let ((x 5)) (f (+ x 6)))) -- cgit v1.2.3 From 0648edf3e05e224ee8410ab244df7364f919dc58 Mon Sep 17 00:00:00 2001 From: Noam Postavsky Date: Fri, 21 Apr 2017 23:37:05 -0400 Subject: Split variable macro env from function env * lisp/emacs-lisp/cl-macs.el (cl--sm-macroexpand): Remove. (cl-symbol-macrolet): Instead of adding each binding directly into the main environment with a special key format, put all symbol macro bindings into a single entry in the main environment under `:cl-symbol-macros'. (cl--sm-macroexpand): Look up symbol bindings in the `:cl-symbol-macros' entry of the environment. --- lisp/emacs-lisp/cl-macs.el | 64 ++++++++++++++++++++-------------------------- 1 file changed, 28 insertions(+), 36 deletions(-) (limited to 'lisp/emacs-lisp/cl-macs.el') diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index db1518ce611..b1ada00f4a4 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2047,28 +2047,22 @@ This is like `cl-flet', but for macros instead of functions. cl--old-macroexpand (symbol-function 'macroexpand))) -(defun cl--symbol-macro-key (sym) - "Return the key used in `macroexpand-all-environment' for symbol macro SYM." - ;; In the past we've used `symbol-name' instead, but that doesn't - ;; preserve the `eq'uality between different symbols of the same name. - `(:cl-symbol-macro . ,sym)) - (defun cl--sm-macroexpand (exp &optional env) "Special macro expander used inside `cl-symbol-macrolet'. This function replaces `macroexpand' during macro expansion of `cl-symbol-macrolet', and does the same thing as `macroexpand' except that it additionally expands symbol macros." - (let ((macroexpand-all-environment env)) + (let ((macroexpand-all-environment env) + (venv (alist-get :cl-symbol-macros env))) (while (progn (setq exp (funcall cl--old-macroexpand exp env)) (pcase exp ((pred symbolp) ;; Perform symbol-macro expansion. - ;; FIXME: Calling `cl--symbol-macro-key' for every var reference - ;; is a bit more costly than I'd like. - (when (cdr (assoc (cl--symbol-macro-key exp) env)) - (setq exp (cadr (assoc (cl--symbol-macro-key exp) env))))) + (let ((symval (assq exp venv))) + (when symval + (setq exp (cadr symval))))) (`(setq . ,_) ;; Convert setq to setf if required by symbol-macro expansion. (let* ((args (mapcar (lambda (f) (cl--sm-macroexpand f env)) @@ -2086,7 +2080,7 @@ except that it additionally expands symbol macros." (let ((letf nil) (found nil) (nbs ())) (dolist (binding bindings) (let* ((var (if (symbolp binding) binding (car binding))) - (sm (assoc (cl--symbol-macro-key var) env))) + (sm (assq var venv))) (push (if (not (cdr sm)) binding (let ((nexp (cadr sm))) @@ -2144,30 +2138,28 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). \(fn ((NAME EXPANSION) ...) FORM...)" (declare (indent 1) (debug ((&rest (symbolp sexp)) cl-declarations body))) - (cond - ((cdr bindings) - `(cl-symbol-macrolet (,(car bindings)) - (cl-symbol-macrolet ,(cdr bindings) ,@body))) - ((null bindings) (macroexp-progn body)) - (t - (let ((previous-macroexpand (symbol-function 'macroexpand))) - (unwind-protect - (progn - (fset 'macroexpand #'cl--sm-macroexpand) - (let ((expansion - ;; FIXME: For N bindings, this will traverse `body' N times! - (macroexpand-all (macroexp-progn body) - (cons (list (cl--symbol-macro-key - (caar bindings)) - (cl-cadar bindings)) - macroexpand-all-environment)))) - (if (or (null (cdar bindings)) (cl-cddar bindings)) - (macroexp--warn-and-return - (format-message "Malformed `cl-symbol-macrolet' binding: %S" - (car bindings)) - expansion) - expansion))) - (fset 'macroexpand previous-macroexpand)))))) + (let ((previous-macroexpand (symbol-function 'macroexpand)) + (malformed-bindings nil)) + (dolist (binding bindings) + (unless (and (consp binding) (symbolp (car binding)) + (consp (cdr binding)) (null (cddr binding))) + (push binding malformed-bindings))) + (unwind-protect + (progn + (fset 'macroexpand #'cl--sm-macroexpand) + (let* ((venv (cdr (assq :cl-symbol-macros macroexpand-all-environment))) + (expansion + (macroexpand-all (macroexp-progn body) + (cons (cons :cl-symbol-macros + (append bindings venv)) + macroexpand-all-environment)))) + (if malformed-bindings + (macroexp--warn-and-return + (format-message "Malformed `cl-symbol-macrolet' binding(s): %S" + (nreverse malformed-bindings)) + expansion) + expansion))) + (fset 'macroexpand previous-macroexpand)))) ;;; Multiple values. -- cgit v1.2.3