commit 2c68192c6b029bb839193c81cf2a16dad26305c6 (HEAD, refs/remotes/origin/master) Author: Stefan Monnier Date: Fri Mar 24 09:21:52 2017 -0400 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'. diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index 0f7efb6f18..3a348aae98 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 822fd2bf36..9a5d900cfc 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 8c4455a3da..1f8615fad3 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 c282938a9b..25c9f99992 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 7432dd4978..ab6354de7c 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 6b930a8d17..564ddab67d 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 commit b6738682ae16c71132c95cd87d48daf598fe89a9 Author: Lars Brinkhoff Date: Tue Mar 21 20:48:52 2017 +0100 Make the URL library use records. * lisp/url/url.el, lisp/url/url-cache.el, lisp/url/url-dav.el, lisp/url/url-expand.el, lisp/url/url-file.el, lisp/url/url-imap.el, lisp/url/url-ldap.el: Use `url-p' instead of `vectorp'. * lisp/url/url-http.el (url-http): Check for type `url' instead of `vector'. diff --git a/lisp/url/url-cache.el b/lisp/url/url-cache.el index 192bbb2481..a7247dfe10 100644 --- a/lisp/url/url-cache.el +++ b/lisp/url/url-cache.el @@ -184,7 +184,7 @@ Very fast if you have an `md5' primitive function, suitably fast otherwise." ;; if it has been specified: e.g. http://www.example.com:80 will ;; be transcoded as http://www.example.com (url-recreate-url - (if (vectorp url) url + (if (url-p url) url (url-generic-parse-url url))))) ;;;###autoload diff --git a/lisp/url/url-dav.el b/lisp/url/url-dav.el index f47bc5da3e..59b836ca6d 100644 --- a/lisp/url/url-dav.el +++ b/lisp/url/url-dav.el @@ -518,7 +518,7 @@ FAILURE-RESULTS is a list of (URL STATUS)." depth '(("Timeout" . "Infinite")))) ;; Get the parent URL ready for expand-file-name - (if (not (vectorp url)) + (if (not (url-p url)) (setq url (url-generic-parse-url url))) ;; Walk thru the response list, fully expand the URL, and grab the @@ -540,7 +540,7 @@ FAILURE-RESULTS is a list of (URL STATUS)." (child-url nil) (child-results nil) (results nil)) - (if (not (vectorp url)) + (if (not (url-p url)) (setq url (url-generic-parse-url url))) (while response diff --git a/lisp/url/url-expand.el b/lisp/url/url-expand.el index cc9341bdf5..9ceaa025fb 100644 --- a/lisp/url/url-expand.el +++ b/lisp/url/url-expand.el @@ -73,7 +73,7 @@ path components followed by `..' are removed, along with the `..' itself." ;; Need to figure out how/where to expand the fragment relative to (setq default (cond - ((vectorp default) + ((url-p default) ;; Default URL has already been parsed default) (default diff --git a/lisp/url/url-file.el b/lisp/url/url-file.el index 8e63a9073e..1dda1d3325 100644 --- a/lisp/url/url-file.el +++ b/lisp/url/url-file.el @@ -89,7 +89,7 @@ to them." keep-date &optional msg cont nowait)) (defun url-file-build-filename (url) - (if (not (vectorp url)) + (if (not (url-p url)) (setq url (url-generic-parse-url url))) (let* ((user (url-user url)) (pass (url-password url)) diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index 90f2e59cc5..06d32861b2 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@ -1243,7 +1243,7 @@ Optional arg GATEWAY-METHOD specifies the gateway to be used, overriding the value of `url-gateway-method'. The return value of this function is the retrieval buffer." - (cl-check-type url vector "Need a pre-parsed URL.") + (cl-check-type url url "Need a pre-parsed URL.") (let* (;; (host (url-host (or url-using-proxy url))) ;; (port (url-port (or url-using-proxy url))) (nsm-noninteractive (or url-request-noninteractive diff --git a/lisp/url/url-imap.el b/lisp/url/url-imap.el index 1195a344c9..b8fe4ed5ff 100644 --- a/lisp/url/url-imap.el +++ b/lisp/url/url-imap.el @@ -50,7 +50,7 @@ (nnimap-authenticator ,authenticator))))) (defun url-imap (url) - (unless (vectorp url) + (unless (url-p url) (signal 'wrong-type-error (list "Need a pre-parsed URL." url))) (with-current-buffer (generate-new-buffer " *url-imap*") (mm-disable-multibyte) diff --git a/lisp/url/url-ldap.el b/lisp/url/url-ldap.el index 8f5f6f55d0..d9a18e554f 100644 --- a/lisp/url/url-ldap.el +++ b/lisp/url/url-ldap.el @@ -115,11 +115,11 @@ (defun url-ldap (url) "Perform an LDAP search specified by URL. The return value is a buffer displaying the search results in HTML. -URL can be a URL string, or a URL vector of the type returned by +URL can be a URL string, or a URL record of the type returned by `url-generic-parse-url'." (if (stringp url) (setq url (url-generic-parse-url (url-unhex-string url))) - (if (not (vectorp url)) + (if (not (url-p url)) (error "Argument is not a valid URL"))) (with-current-buffer (generate-new-buffer " *url-ldap*") (setq url-current-object url) diff --git a/lisp/url/url.el b/lisp/url/url.el index 2eec1c44de..75cf77deaa 100644 --- a/lisp/url/url.el +++ b/lisp/url/url.el @@ -186,7 +186,7 @@ URL-encoded before it's used." (when (stringp url) (set-text-properties 0 (length url) nil url) (setq url (url-encode-url url))) - (if (not (vectorp url)) + (if (not (url-p url)) (setq url (url-generic-parse-url url))) (if (not (functionp callback)) (error "Must provide a callback function to url-retrieve")) commit 8e6f204f44b6183ba73c7d1bec5841f2b7b8bdd0 Author: Stefan Monnier Date: Wed Mar 15 22:48:28 2017 -0400 Make EIEIO use records. * lisp/emacs-lisp/eieio-compat.el (eieio--generic-static-object-generalizer): Adjust to new tags. * lisp/emacs-lisp/eieio-core.el: Use records, and place the class object directly as tag. (eieio--object-class): Adjust to new tag representation. (eieio-object-p): Rewrite, and adapt to new `type-of' behavior. (eieio-defclass-internal): Use `make-record'. (eieio--generic-generalizer): Adjust generalizer code accordingly. * lisp/emacs-lisp/eieio.el (make-instance, clone): Use copy-record. * lisp/emacs-lisp/pcase.el (pcase-mutually-exclusive-predicates): Add `recordp'. * doc/lispref/records.texi, doc/misc/eieio.texi: Update for records. diff --git a/doc/lispref/records.texi b/doc/lispref/records.texi index 618f30a72c..822fd2bf36 100644 --- a/doc/lispref/records.texi +++ b/doc/lispref/records.texi @@ -9,7 +9,8 @@ The purpose of records is to allow programmers to create objects with new types that are not built into Emacs. They are used as the -underlying representation of @code{cl-defstruct} instances. +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 diff --git a/doc/misc/eieio.texi b/doc/misc/eieio.texi index dfae565dee..7076c24422 100644 --- a/doc/misc/eieio.texi +++ b/doc/misc/eieio.texi @@ -1017,7 +1017,7 @@ If @var{errorp} is non-@code{nil}, @code{wrong-argument-type} is signaled. @defun class-p class @anchor{class-p} -Return @code{t} if @var{class} is a valid class vector. +Return @code{t} if @var{class} is a valid class object. @var{class} is a symbol. @end defun @@ -1055,7 +1055,7 @@ Will fetch the documentation string for @code{eieio-default-superclass}. Return a string of the form @samp{#} for @var{obj}. This should look like Lisp symbols from other parts of Emacs such as buffers and processes, and is shorter and cleaner than printing the -object's vector. It is more useful to use @code{object-print} to get +object's record. It is more useful to use @code{object-print} to get and object's print form, as this allows the object to add extra display information into the symbol. @end defun @@ -1212,7 +1212,7 @@ items defined in this second slot. Introspection permits a programmer to peek at the contents of a class without any previous knowledge of that class. While @eieio{} implements -objects on top of vectors, and thus everything is technically visible, +objects on top of records, and thus everything is technically visible, some functions have been provided. None of these functions are a part of CLOS. @@ -1525,7 +1525,7 @@ Currently, the default superclass is defined as follows: nil "Default parent class for classes with no specified parent class. Its slots are automatically adopted by classes with no specified -parents. This class is not stored in the `parent' slot of a class vector." +parents. This class is not stored in the `parent' slot of a class object." :abstract t) @end example diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index 986d028517..33c71ec580 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -294,8 +294,7 @@ Second, any text properties will be stripped from strings." (cond ((consp proposed-value) ;; Lists with something in them need special treatment. (let* ((slot-idx (- (eieio--slot-name-index class slot) - (eval-when-compile - (length (cl-struct-slot-info 'eieio--object))))) + (eval-when-compile eieio--object-num-slots))) (type (cl--slot-descriptor-type (aref (eieio--class-slots class) slot-idx))) (classtype (eieio-persistent-slot-type-is-class-p type))) diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el index 888d85f603..d6eb0b416f 100644 --- a/lisp/emacs-lisp/eieio-compat.el +++ b/lisp/emacs-lisp/eieio-compat.el @@ -145,7 +145,7 @@ Summary: ;; interleaved list comes before the class's non-interleaved list. 51 #'cl--generic-struct-tag (lambda (tag &rest _) - (and (symbolp tag) (boundp tag) (setq tag (symbol-value tag)) + (and (symbolp tag) (setq tag (cl--find-class tag)) (eieio--class-p tag) (let ((superclasses (eieio--class-precedence-list tag)) (specializers ())) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 5cc6d020ea..c59f85d6fb 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -108,21 +108,14 @@ Currently under control of this var: (cl-declaim (optimize (safety 1)))) -(cl-defstruct (eieio--object - (:type vector) ;We manage our own tagging system. - (:constructor nil) - (:copier nil)) - ;; `class-tag' holds a symbol, which is not the class name, but is instead - ;; properly prefixed as an internal EIEIO thingy and which holds the class - ;; object/struct in its `symbol-value' slot. - class-tag) +(eval-and-compile + (defconst eieio--object-num-slots 1)) -(eval-when-compile - (defconst eieio--object-num-slots - (length (cl-struct-slot-info 'eieio--object)))) +(defsubst eieio--object-class-tag (obj) + (aref obj 0)) (defsubst eieio--object-class (obj) - (symbol-value (eieio--object-class-tag obj))) + (eieio--object-class-tag obj)) ;;; Important macros used internally in eieio. @@ -166,13 +159,8 @@ Return nil if that option doesn't exist." (defun eieio-object-p (obj) "Return non-nil if OBJ is an EIEIO object." - (and (vectorp obj) - (> (length obj) 0) - (let ((tag (eieio--object-class-tag obj))) - (and (symbolp tag) - ;; (eq (symbol-function tag) :quick-object-witness-check) - (boundp tag) - (eieio--class-p (symbol-value tag)))))) + (and (recordp obj) + (eieio--class-p (eieio--object-class-tag obj)))) (define-obsolete-function-alias 'object-p 'eieio-object-p "25.1") @@ -496,18 +484,11 @@ See `defclass' for more information." (if clearparent (setf (eieio--class-parents newc) nil)) ;; Create the cached default object. - (let ((cache (make-vector (+ (length (eieio--class-slots newc)) - (eval-when-compile eieio--object-num-slots)) - nil)) - ;; We don't strictly speaking need to use a symbol, but the old - ;; code used the class's name rather than the class's object, so - ;; we follow this preference for using a symbol, which is probably - ;; convenient to keep the printed representation of such Elisp - ;; objects readable. - (tag (intern (format "eieio-class-tag--%s" cname)))) - (set tag newc) - (fset tag :quick-object-witness-check) - (setf (eieio--object-class-tag cache) tag) + (let ((cache (make-record newc + (+ (length (eieio--class-slots newc)) + (eval-when-compile eieio--object-num-slots) + -1) + nil))) (let ((eieio-skip-typecheck t)) ;; All type-checking has been done to our satisfaction ;; before this call. Don't waste our time in this call.. @@ -1060,9 +1041,10 @@ method invocation orders of the involved classes." ;; part of the dispatch code. 50 #'cl--generic-struct-tag (lambda (tag &rest _) - (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag)) - (mapcar #'eieio--class-name - (eieio--class-precedence-list (symbol-value tag)))))) + (let ((class (cl--find-class tag))) + (and (eieio--class-p class) + (mapcar #'eieio--class-name + (eieio--class-precedence-list class)))))) (cl-defmethod cl-generic-generalizers :extra "class" (specializer) "Support for dispatch on types defined by EIEIO's `defclass'." diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 1a6d5e9d7c..858b2fdaa0 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -337,14 +337,12 @@ variable name of the same name as the slot." ;; hard-coded in random .elc files. (defun eieio-pcase-slot-index-table (obj) "Return some data structure from which can be extracted the slot offset." - (eieio--class-index-table - (symbol-value (eieio--object-class-tag obj)))) + (eieio--class-index-table (eieio--object-class obj))) (defun eieio-pcase-slot-index-from-index-table (index-table slot) "Find the index to pass to `aref' to access SLOT." (let ((index (gethash slot index-table))) - (if index (+ (eval-when-compile - (length (cl-struct-slot-info 'eieio--object))) + (if index (+ (eval-when-compile eieio--object-num-slots) index)))) (pcase-defmacro eieio (&rest fields) @@ -701,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-sequence (eieio--class-default-object-cache - (eieio--class-object class))))) + (let* ((new-object (copy-record (eieio--class-default-object-cache + (eieio--class-object class))))) (if (and slots (let ((x (car slots))) (or (stringp x) (null x)))) @@ -806,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-sequence obj))) + (let ((nobj (copy-record obj))) (if (stringp (car params)) (funcall (if eieio-backward-compatibility #'ignore #'message) "Obsolete name %S passed to clone" (pop params))) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index fc5474ecc4..4a06ab25d3 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -503,24 +503,30 @@ MATCH is the pattern that needs to be matched, of the form: (symbolp . vectorp) (symbolp . stringp) (symbolp . byte-code-function-p) + (symbolp . recordp) (integerp . consp) (integerp . arrayp) (integerp . vectorp) (integerp . stringp) (integerp . byte-code-function-p) + (integerp . recordp) (numberp . consp) (numberp . arrayp) (numberp . vectorp) (numberp . stringp) (numberp . byte-code-function-p) + (numberp . recordp) (consp . arrayp) (consp . atom) (consp . vectorp) (consp . stringp) (consp . byte-code-function-p) + (consp . recordp) (arrayp . byte-code-function-p) (vectorp . byte-code-function-p) + (vectorp . recordp) (stringp . vectorp) + (stringp . recordp) (stringp . byte-code-function-p))) (defun pcase--mutually-exclusive-p (pred1 pred2) commit 056548283884d61b1b9637c3e56855ce3a17274d Author: Lars Brinkhoff Date: Tue Mar 14 13:52:40 2017 +0100 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. diff --git a/doc/lispref/records.texi b/doc/lispref/records.texi index aeba77a70e..618f30a72c 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 079f534168..2339d57631 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 021ef23274..3852ceb6c3 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 8c6d3d5d51..e15c94242f 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 58bcdd52ac..c282938a9b 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 482b579f11..7432dd4978 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 8a8d4a4c1a..65c86d2b65 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 093cb3476c..6b930a8d17 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 commit a2c33430292c79ac520100b1d0e8e7c04dfe426a Author: Lars Brinkhoff Date: Sun Jan 6 14:27:44 2013 +0100 Add record objects with user-defined types. * src/alloc.c (allocate_record): New function. (Fmake_record, Frecord, Fcopy_record): New functions. (syms_of_alloc): defsubr them. (purecopy): Work with records. * src/data.c (Ftype_of): Return slot 0 for record objects, or type name if record's type holds class. (Frecordp): New function. (syms_of_data): defsubr it. Define `Qrecordp'. (Faref, Faset): Work with records. * src/fns.c (Flength): Work with records. * src/lisp.h (prec_type): Add PVEC_RECORD. (RECORDP, CHECK_RECORD, CHECK_RECORD_TYPE): New functions. * src/lread.c (read1): Add syntax for records. * src/print.c (PRINT_CIRCLE_CANDIDATE_P): Add RECORDP. (print_object): Add syntax for records. * test/lisp/emacs-lisp/cl-print-tests.el (cl-print-tests-2): New test. * test/src/alloc-tests.el (record-1, record-2, record-3): New tests. * doc/lispref/elisp.texi, doc/lispref/objects.texi, doc/lispref/records.texi: Add documentation for records. diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index e0bd337e53..0f7efb6f18 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -180,6 +180,7 @@ To view this manual in other formats, click * Sequences Arrays Vectors:: Lists, strings and vectors are called sequences. Certain functions act on any kind of sequence. The description of vectors is here as well. +* Records:: Compound objects with programmer-defined types. * Hash Tables:: Very fast lookup-tables. * Symbols:: Symbols represent names, uniquely. @@ -314,6 +315,7 @@ Programming Types expression, more fundamental but less pretty. * Primitive Function Type:: A function written in C, callable from Lisp. * Byte-Code Type:: A function written in Lisp, then compiled. +* Record Type:: Compound objects with programmer-defined types. * Autoload Type:: A type used for automatically loading seldom-used functions. * Finalizer Type:: Runs code when no longer reachable. @@ -418,6 +420,10 @@ Sequences, Arrays, and Vectors * Bool-Vectors:: How to work with bool-vectors. * Rings:: Managing a fixed-size ring of objects. +Records + +* Record Functions:: Functions for records. + Hash Tables * Creating Hash:: Functions to create hash tables. @@ -1594,6 +1600,7 @@ Object Internals @include lists.texi @include sequences.texi +@include records.texi @include hash.texi @include symbols.texi @include eval.texi diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi index 56049af60a..90cafbef64 100644 --- a/doc/lispref/objects.texi +++ b/doc/lispref/objects.texi @@ -25,9 +25,10 @@ but not for @emph{the} type of an object. which all other types are constructed, are called @dfn{primitive types}. Each object belongs to one and only one primitive type. These types include @dfn{integer}, @dfn{float}, @dfn{cons}, @dfn{symbol}, -@dfn{string}, @dfn{vector}, @dfn{hash-table}, @dfn{subr}, and -@dfn{byte-code function}, plus several special types, such as -@dfn{buffer}, that are related to editing. (@xref{Editing Types}.) +@dfn{string}, @dfn{vector}, @dfn{hash-table}, @dfn{subr}, +@dfn{byte-code function}, and @dfn{record}, plus several special +types, such as @dfn{buffer}, that are related to editing. +(@xref{Editing Types}.) Each primitive type has a corresponding Lisp function that checks whether an object is a member of that type. @@ -154,6 +155,7 @@ latter are unique to Emacs Lisp. expression, more fundamental but less pretty. * Primitive Function Type:: A function written in C, callable from Lisp. * Byte-Code Type:: A function written in Lisp, then compiled. +* Record Type:: Compound objects with programmer-defined types. * Autoload Type:: A type used for automatically loading seldom-used functions. * Finalizer Type:: Runs code when no longer reachable. @@ -1347,6 +1349,16 @@ The printed representation and read syntax for a byte-code function object is like that for a vector, with an additional @samp{#} before the opening @samp{[}. +@node Record Type +@subsection Record Type + + A @dfn{record} is much like a @code{vector}. However, the first +element is used to hold its type as returned by @code{type-of}. The +purpose of records is to allow programmers to create objects with new +types that are not built into Emacs. + + @xref{Records}, for functions that work with records. + @node Autoload Type @subsection Autoload Type @@ -1959,6 +1971,9 @@ with references to further information. @item processp @xref{Processes, processp}. +@item recordp +@xref{Record Type, recordp}. + @item sequencep @xref{Sequence Functions, sequencep}. @@ -2022,6 +2037,7 @@ This function returns a symbol naming the primitive type of @code{marker}, @code{mutex}, @code{overlay}, @code{process}, @code{string}, @code{subr}, @code{symbol}, @code{thread}, @code{vector}, @code{window}, or @code{window-configuration}. +However, if @var{object} is a record, its first slot is returned. @example (type-of 1) @@ -2033,6 +2049,8 @@ This function returns a symbol naming the primitive type of @result{} symbol (type-of '(x)) @result{} cons +(type-of (record 'foo)) + @result{} foo @end group @end example @end defun diff --git a/doc/lispref/records.texi b/doc/lispref/records.texi new file mode 100644 index 0000000000..aeba77a70e --- /dev/null +++ b/doc/lispref/records.texi @@ -0,0 +1,98 @@ +@c -*-texinfo-*- +@c This is part of the GNU Emacs Lisp Reference Manual. +@c Copyright (C) 2017 Free Software +@c Foundation, Inc. +@c See the file elisp.texi for copying conditions. +@node Records +@chapter Records +@cindex record + + The purpose of records is to allow programmers to create objects +with new types that are not built into Emacs. + + 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}. Like arrays, records use +zero-origin indexing: the first slot has index 0. + + The printed representation of records is @samp{#s} followed by a +list specifying the contents. The first list element must be the +record type. The following elements are the record slots. + + A record is considered a constant for evaluation: the result of +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. +@end menu + +@node Record Functions +@section Record Functions + +@defun recordp object +This function returns @code{t} if @var{object} is a record. + +@example +@group +(recordp #s(a)) + @result{} t +@end group +@end example +@end defun + +@defun record type &rest objects +This function creates and returns a record whose type is @var{type} +and remaining slots are the rest of the arguments, @var{objects}. + +@example +@group +(vector 'foo 23 [bar baz] "rats") + @result{} #s(foo 23 [bar baz] "rats") +@end group +@end example +@end defun + +@defun make-record type length object +This function returns a new record with type @var{type} and +@var{length} more slots, each initialized to @var{object}. + +@example +@group +(setq sleepy (make-record 'foo 9 'Z)) + @result{} #s(foo Z Z Z Z Z Z Z Z Z) +@end group +@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 diff --git a/src/alloc.c b/src/alloc.c index ae3e1519c0..fe631f2e4d 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3392,6 +3392,94 @@ allocate_buffer (void) return b; } + +/* Allocate a new record with COUNT slots. Return NULL if COUNT is + too large. */ + +static struct Lisp_Vector * +allocate_record (int count) +{ + if (count >= (1 << PSEUDOVECTOR_SIZE_BITS)) + return NULL; + + struct Lisp_Vector *p = allocate_vector (count); + XSETPVECTYPE (p, PVEC_RECORD); + return p; +} + + +DEFUN ("make-record", Fmake_record, Smake_record, 3, 3, 0, + doc: /* Create a new record. +TYPE is its type as returned by `type-of'. SLOTS is the number of +slots, each initialized to INIT. The number of slots, including the +type slot, must fit in PSEUDOVECTOR_SIZE_BITS. */) + (Lisp_Object type, Lisp_Object slots, Lisp_Object init) +{ + Lisp_Object record; + ptrdiff_t size, i; + struct Lisp_Vector *p; + + CHECK_NATNUM (slots); + + size = XFASTINT (slots) + 1; + p = allocate_record (size); + if (p == NULL) + error ("Attempt to allocate a record of %ld slots; max is %d", + size, (1 << PSEUDOVECTOR_SIZE_BITS) - 1); + + p->contents[0] = type; + for (i = 1; i < size; i++) + p->contents[i] = init; + + XSETVECTOR (record, p); + return record; +} + + +DEFUN ("record", Frecord, Srecord, 1, MANY, 0, + doc: /* Create a new record. +TYPE is its type as returned by `type-of'. SLOTS is used to +initialize the record slots with shallow copies of the arguments. The +number of slots, including the type slot, must fit in +PSEUDOVECTOR_SIZE_BITS. +usage: (record TYPE &rest SLOTS) */) + (ptrdiff_t nargs, Lisp_Object *args) +{ + struct Lisp_Vector *p = allocate_record (nargs); + if (p == NULL) + error ("Attempt to allocate a record of %ld slots; max is %d", + nargs, (1 << PSEUDOVECTOR_SIZE_BITS) - 1); + + Lisp_Object type = args[0]; + Lisp_Object record; + + p->contents[0] = type; + memcpy (p->contents + 1, args + 1, (nargs - 1) * sizeof *args); + + XSETVECTOR (record, p); + return record; +} + + +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); + struct Lisp_Vector *src = XVECTOR (record); + ptrdiff_t size = ASIZE (record) & PSEUDOVECTOR_SIZE_MASK; + struct Lisp_Vector *new = allocate_record (size); + if (new == NULL) + error ("Attempt to allocate a record of %ld slots; max is %d", + size, (1 << PSEUDOVECTOR_SIZE_BITS) - 1); + + memcpy (&(new->contents[0]), &(src->contents[0]), + size * sizeof (Lisp_Object)); + XSETVECTOR (record, new); + return record; +} + + 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'. */) @@ -5532,7 +5620,7 @@ purecopy (Lisp_Object obj) struct Lisp_Hash_Table *h = purecopy_hash_table (table); XSET_HASH_TABLE (obj, h); } - else if (COMPILEDP (obj) || VECTORP (obj)) + else if (COMPILEDP (obj) || VECTORP (obj) || RECORDP (obj)) { struct Lisp_Vector *objp = XVECTOR (obj); ptrdiff_t nbytes = vector_nbytes (objp); @@ -7461,10 +7549,13 @@ The time is in seconds as a floating point value. */); defsubr (&Scons); defsubr (&Slist); defsubr (&Svector); + defsubr (&Srecord); + defsubr (&Scopy_record); defsubr (&Sbool_vector); defsubr (&Smake_byte_code); defsubr (&Smake_list); defsubr (&Smake_vector); + defsubr (&Smake_record); defsubr (&Smake_string); defsubr (&Smake_bool_vector); defsubr (&Smake_symbol); diff --git a/src/data.c b/src/data.c index ae8dd9721c..5fdbec2000 100644 --- a/src/data.c +++ b/src/data.c @@ -267,6 +267,15 @@ for example, (type-of 1) returns `integer'. */) case PVEC_MUTEX: return Qmutex; case PVEC_CONDVAR: return Qcondition_variable; case PVEC_TERMINAL: return Qterminal; + case PVEC_RECORD: + { + Lisp_Object t = AREF (object, 0); + if (RECORDP (t) && 1 < (ASIZE (t) & PSEUDOVECTOR_SIZE_MASK)) + /* Return the type name field of the class! */ + return AREF (t, 1); + else + return t; + } /* "Impossible" cases. */ case PVEC_XWIDGET: case PVEC_OTHER: @@ -359,6 +368,15 @@ DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0, return Qnil; } +DEFUN ("recordp", Frecordp_p, Srecordp, 1, 1, 0, + doc: /* Return t if OBJECT is a record. */) + (Lisp_Object object) +{ + if (RECORDP (object)) + return Qt; + return Qnil; +} + DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0, doc: /* Return t if OBJECT is a string. */ attributes: const) @@ -2287,7 +2305,7 @@ or a byte-code object. IDX starts at 0. */) ptrdiff_t size = 0; if (VECTORP (array)) size = ASIZE (array); - else if (COMPILEDP (array)) + else if (COMPILEDP (array) || RECORDP (array)) size = ASIZE (array) & PSEUDOVECTOR_SIZE_MASK; else wrong_type_argument (Qarrayp, array); @@ -2308,7 +2326,8 @@ bool-vector. IDX starts at 0. */) CHECK_NUMBER (idx); idxval = XINT (idx); - CHECK_ARRAY (array, Qarrayp); + if (! RECORDP (array)) + CHECK_ARRAY (array, Qarrayp); if (VECTORP (array)) { @@ -2328,7 +2347,14 @@ bool-vector. IDX starts at 0. */) CHECK_CHARACTER (idx); CHAR_TABLE_SET (array, idxval, newelt); } - else + else if (RECORDP (array)) + { + ptrdiff_t size = ASIZE (array) & PSEUDOVECTOR_SIZE_MASK; + if (idxval < 0 || idxval >= size) + args_out_of_range (array, idx); + ASET (array, idxval, newelt); + } + else /* STRINGP */ { int c; @@ -3604,6 +3630,7 @@ syms_of_data (void) DEFSYM (Qsequencep, "sequencep"); DEFSYM (Qbufferp, "bufferp"); DEFSYM (Qvectorp, "vectorp"); + DEFSYM (Qrecordp, "recordp"); DEFSYM (Qbool_vector_p, "bool-vector-p"); DEFSYM (Qchar_or_string_p, "char-or-string-p"); DEFSYM (Qmarkerp, "markerp"); @@ -3714,6 +3741,7 @@ syms_of_data (void) DEFSYM (Qbuffer, "buffer"); DEFSYM (Qframe, "frame"); DEFSYM (Qvector, "vector"); + DEFSYM (Qrecord, "record"); DEFSYM (Qchar_table, "char-table"); DEFSYM (Qbool_vector, "bool-vector"); DEFSYM (Qhash_table, "hash-table"); @@ -3750,6 +3778,7 @@ syms_of_data (void) defsubr (&Sstringp); defsubr (&Smultibyte_string_p); defsubr (&Svectorp); + defsubr (&Srecordp); defsubr (&Schar_table_p); defsubr (&Svector_or_char_table_p); defsubr (&Sbool_vector_p); diff --git a/src/fns.c b/src/fns.c index de7fc1b47f..47da5f8b4b 100644 --- a/src/fns.c +++ b/src/fns.c @@ -106,7 +106,7 @@ To get the number of bytes, use `string-bytes'. */) XSETFASTINT (val, MAX_CHAR); else if (BOOL_VECTOR_P (sequence)) XSETFASTINT (val, bool_vector_size (sequence)); - else if (COMPILEDP (sequence)) + else if (COMPILEDP (sequence) || RECORDP (sequence)) XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK); else if (CONSP (sequence)) { diff --git a/src/lisp.h b/src/lisp.h index 3125bd2a5d..5e7d41bc5d 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -889,6 +889,7 @@ enum pvec_type PVEC_COMPILED, PVEC_CHAR_TABLE, PVEC_SUB_CHAR_TABLE, + PVEC_RECORD, PVEC_FONT /* Should be last because it's used for range checking. */ }; @@ -1412,6 +1413,7 @@ CHECK_VECTOR (Lisp_Object x) CHECK_TYPE (VECTORP (x), Qvectorp, x); } + /* A pseudovector is like a vector, but has other non-Lisp components. */ INLINE enum pvec_type @@ -2732,6 +2734,18 @@ FRAMEP (Lisp_Object a) return PSEUDOVECTORP (a, PVEC_FRAME); } +INLINE bool +RECORDP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_RECORD); +} + +INLINE void +CHECK_RECORD (Lisp_Object x) +{ + CHECK_TYPE (RECORDP (x), Qrecordp, x); +} + /* Test for image (image . spec) */ INLINE bool IMAGEP (Lisp_Object x) diff --git a/src/lread.c b/src/lread.c index 5c6a7f97f5..6de9fe6e08 100644 --- a/src/lread.c +++ b/src/lread.c @@ -2603,8 +2603,18 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) int param_count = 0; if (!EQ (head, Qhash_table)) - error ("Invalid extended read marker at head of #s list " - "(only hash-table allowed)"); + { + ptrdiff_t size = XINT (Flength (tmp)); + Lisp_Object record = Fmake_record (CAR_SAFE (tmp), + make_number (size - 1), + Qnil); + for (int i = 1; i < size; i++) + { + tmp = Fcdr (tmp); + ASET (record, i, Fcar (tmp)); + } + return record; + } tmp = CDR_SAFE (tmp); diff --git a/src/print.c b/src/print.c index e857761bd4..76f263994e 100644 --- a/src/print.c +++ b/src/print.c @@ -1135,7 +1135,8 @@ print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) || (VECTORLIKEP (obj) \ && (VECTORP (obj) || COMPILEDP (obj) \ || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \ - || HASH_TABLE_P (obj) || FONTP (obj))) \ + || HASH_TABLE_P (obj) || FONTP (obj) \ + || RECORDP (obj))) \ || (! NILP (Vprint_gensym) \ && SYMBOLP (obj) \ && !SYMBOL_INTERNED_P (obj))) @@ -1963,6 +1964,30 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) } break; + case PVEC_RECORD: + { + ptrdiff_t n, size = ASIZE (obj) & PSEUDOVECTOR_SIZE_MASK; + int i; + + /* Don't print more elements than the specified maximum. */ + if (NATNUMP (Vprint_length) + && XFASTINT (Vprint_length) < size) + n = XFASTINT (Vprint_length); + else + n = size; + + print_c_string ("#s(", printcharfun); + for (i = 0; i < n; i ++) + { + if (i) printchar (' ', printcharfun); + print_object (AREF (obj, i), printcharfun, escapeflag); + } + if (n < size) + print_c_string (" ...", printcharfun); + printchar (')', printcharfun); + } + break; + case PVEC_SUB_CHAR_TABLE: case PVEC_COMPILED: case PVEC_CHAR_TABLE: diff --git a/test/lisp/emacs-lisp/cl-print-tests.el b/test/lisp/emacs-lisp/cl-print-tests.el index 04ddfeeca8..772601fe87 100644 --- a/test/lisp/emacs-lisp/cl-print-tests.el +++ b/test/lisp/emacs-lisp/cl-print-tests.el @@ -37,4 +37,14 @@ (should (string-match "\\`#f(compiled-function (x) .*\n\n.*)\\'" (cl-prin1-to-string (symbol-function #'caar)))))) +(ert-deftest cl-print-tests-2 () + (let ((x (record 'foo 1 2 3))) + (should (equal + x + (car (read-from-string (with-output-to-string (prin1 x)))))) + (let ((print-circle t)) + (should (string-match + "\\`(#1=#s(foo 1 2 3) #1#)\\'" + (cl-prin1-to-string (list x x))))))) + ;;; cl-print-tests.el ends here. diff --git a/test/src/alloc-tests.el b/test/src/alloc-tests.el index af4ad6c635..8b4ef8ce7d 100644 --- a/test/src/alloc-tests.el +++ b/test/src/alloc-tests.el @@ -31,3 +31,23 @@ (ert-deftest finalizer-object-type () (should (equal (type-of (make-finalizer nil)) 'finalizer))) + +(ert-deftest record-1 () + (let ((x (record 'foo 1 2 3))) + (should (recordp x)) + (should (eq (type-of x) 'foo)) + (should (eq (aref x 0) 'foo)) + (should (eql (aref x 3) 3)) + (should (eql (length x) 4)))) + +(ert-deftest record-2 () + (let ((x (make-record 'bar 1 0))) + (should (eql (length x) 2)) + (should (eql (aref x 1) 0)))) + +(ert-deftest record-3 () + (let* ((x (record 'foo 1 2 3)) + (y (copy-record x))) + (should-not (eq x y)) + (dotimes (i 4) + (should (eql (aref x i) (aref y i)))))) commit 19b92cdfb04a025037d7388954b64468d6f54462 Author: Tino Calancha Date: Tue Apr 4 15:16:15 2017 +0900 Fix a test in python-test.el Fix a test that breaks the test suite when it is run within a virtual environment. See following link for details: https://lists.gnu.org/archive/html/emacs-devel/2017-03/msg00857.html * test/lisp/progmodes/python-tests.el (python-shell-calculate-process-environment-7): Bind python-shell-virtualenv-root to VIRTUAL_ENV when this var is set; otherwise bind it to '/env'. diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el index 2f4c2fb849..3b75e81afe 100644 --- a/test/lisp/progmodes/python-tests.el +++ b/test/lisp/progmodes/python-tests.el @@ -2612,7 +2612,7 @@ Using `python-shell-interpreter' and "Test no side-effects on `process-environment'." (let* ((python-shell-process-environment '("TESTVAR1=value1" "TESTVAR2=value2")) - (python-shell-virtualenv-root "/env") + (python-shell-virtualenv-root (or (getenv "VIRTUAL_ENV") "/env")) (python-shell-unbuffered t) (python-shell-extra-pythonpaths'("/path1" "/path2")) (original-process-environment (copy-sequence process-environment))) commit 3887c54544bc2e5f8c2e7c12973887f9b2b88c40 Author: Noam Postavsky Date: Sat Apr 1 09:34:04 2017 -0400 Throw a `search-failed' derived error in Info search The original fix for Bug#6106 switched from signalling `search-failed' to `user-error'. However, this breaks incremental searching over multiple nodes because the isearch code doesn't expect a `user-error'. * src/search.c (syms_of_search): New error, `user-search-failed', with `user-error' and `search-failed' as parents. * doc/lispref/errors.texi (Standard Errors): Document it. * etc/NEWS: Announce it. * lisp/info.el (Info-search): Use it instead of `user-error' so that isearch will handle failed searches correctly. diff --git a/doc/lispref/errors.texi b/doc/lispref/errors.texi index 2ec1a108ea..1f67819c34 100644 --- a/doc/lispref/errors.texi +++ b/doc/lispref/errors.texi @@ -186,6 +186,12 @@ The message is @samp{Undefined color}. @xref{Color Names}. @item user-error The message is the empty string. @xref{Signaling Errors}. +@item user-search-failed +This is like @samp{search-failed}, but doesn't trigger the debugger, +like @samp{user-error}. @xref{Signaling Errors}, and @xref{Searching +and Matching}. This is used for searching in Info files, @xref{Search +Text,,,info,Info}. + @item void-function The message is @samp{Symbol's function definition is void}. @xref{Function Cells}. diff --git a/etc/NEWS b/etc/NEWS index bfd7d2bd32..fc07656986 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1058,6 +1058,10 @@ its window gets deleted by 'delete-other-windows'. *** New command 'window-swap-states' swaps the states of two live windows. ++++ +*** New error type 'user-search-failed' like 'search-failed' but +avoids debugger like 'user-error'. + * Changes in Emacs 26.1 on Non-Free Operating Systems diff --git a/lisp/info.el b/lisp/info.el index a6bab290a7..81e5d29f82 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -1998,20 +1998,20 @@ If DIRECTION is `backward', search in the reverse direction." Info-isearch-initial-node bound (and found (> found opoint-min) (< found opoint-max))) - (user-error "Search failed: `%s' (end of node)" regexp)) + (signal 'user-search-failed (list regexp "(end of node)"))) ;; If no subfiles, give error now. (unless (or found Info-current-subfile) (if isearch-mode - (user-error "Search failed: `%s' (end of manual)" regexp) + (signal 'user-search-failed (list regexp "end of manual")) (let ((search-spaces-regexp Info-search-whitespace-regexp)) (unless (if backward (re-search-backward regexp nil t) (re-search-forward regexp nil t)) - (user-error "Search failed: `%s'" regexp))))) + (signal 'user-seach-failed (list regexp)))))) (if (and bound (not found)) - (user-error "Search failed: `%s'" regexp)) + (signal 'user-search-failed (list regexp))) (unless (or found bound) (unwind-protect @@ -2055,8 +2055,8 @@ If DIRECTION is `backward', search in the reverse direction." (setq list nil))) (if found (message "") - (user-error "Search failed: `%s'%s" - regexp (if isearch-mode " (end of manual)" "")))) + (signal 'user-search-failed + `(,regexp ,@(if isearch-mode '("end of manual")))))) (if (not found) (progn (Info-read-subfile osubfile) (goto-char opoint) diff --git a/src/search.c b/src/search.c index 33cb02aa7a..c0deb57213 100644 --- a/src/search.c +++ b/src/search.c @@ -3389,6 +3389,10 @@ syms_of_search (void) /* Error condition used for failing searches. */ DEFSYM (Qsearch_failed, "search-failed"); + /* Error condition used for failing searches started by user, i.e., + where failure should not invoke the debugger. */ + DEFSYM (Quser_search_failed, "user-search-failed"); + /* Error condition signaled when regexp compile_pattern fails. */ DEFSYM (Qinvalid_regexp, "invalid-regexp"); @@ -3397,6 +3401,12 @@ syms_of_search (void) Fput (Qsearch_failed, Qerror_message, build_pure_c_string ("Search failed")); + Fput (Quser_search_failed, Qerror_conditions, + listn (CONSTYPE_PURE, 4, + Quser_search_failed, Quser_error, Qsearch_failed, Qerror)); + Fput (Quser_search_failed, Qerror_message, + build_pure_c_string ("Search failed")); + Fput (Qinvalid_regexp, Qerror_conditions, listn (CONSTYPE_PURE, 2, Qinvalid_regexp, Qerror)); Fput (Qinvalid_regexp, Qerror_message, commit 49197e6e3d30a4da91d5f18041dd125ac327592a Author: Michael Albinus Date: Mon Apr 3 14:04:06 2017 +0200 Add Tramp test * doc/misc/tramp.texi (Remote processes): Fix typo. * lisp/shell.el (shell): Fix typo. * lisp/net/tramp.el (tramp-set-connection-local-variables): Simplify. * test/lisp/net/tramp-tests.el (tramp-test30-explicit-shell-file-name): New test. (tramp--test-special-characters, tramp--test-utf8): Adapt docstring. (tramp-test31-vc-registered) (tramp-test32-make-auto-save-file-name) (tramp-test33-make-nearby-temp-file) (tramp-test34-special-characters) (tramp-test34-special-characters-with-stat) (tramp-test34-special-characters-with-perl) (tramp-test34-special-characters-with-ls, tramp-test35-utf8) (tramp-test35-utf8-with-stat, tramp-test35-utf8-with-perl) (tramp-test35-utf8-with-ls) (tramp-test36-asynchronous-requests) (tramp-test37-recursive-load, tramp-test38-unload): Rename. diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 8e04d69c19..b19836d0b9 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -2523,13 +2523,13 @@ different remote hosts. @group (connection-local-set-profiles - '(:application 'tramp :protocol "ssh" :machine "localhost") + '(:application tramp :protocol "ssh" :machine "localhost") 'remote-bash) @end group @group (connection-local-set-profiles - `(:application 'tramp :protocol "sudo" + `(:application tramp :protocol "sudo" :user "root" :machine ,(system-name)) 'remote-ksh) @end group diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 0ca5a6d3ac..1786355116 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1347,14 +1347,10 @@ version, the function does nothing." ;; `hack-connection-local-variables-apply' exists since Emacs 26.1. (tramp-compat-funcall 'hack-connection-local-variables-apply - (append - '(tramp) - (when (tramp-file-name-method vec) - `(:protocol ,(tramp-file-name-method vec))) - (when (tramp-file-name-user vec) - `(:user ,(tramp-file-name-user vec))) - (when (tramp-file-name-host vec) - `(:machine ,(tramp-file-name-host vec))))))) + `(:application tramp + :protocol ,(tramp-file-name-method vec) + :user ,(tramp-file-name-user vec) + :machine ,(tramp-file-name-host vec))))) (defun tramp-debug-buffer-name (vec) "A name for the debug buffer for VEC." diff --git a/lisp/shell.el b/lisp/shell.el index 55a053295f..e03ccbb4f9 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -715,7 +715,7 @@ Otherwise, one argument `-i' is passed to the shell. (when (file-remote-p default-directory) ;; Apply connection-local variables. (hack-connection-local-variables-apply - `(:application 'tramp + `(:application tramp :protocol ,(file-remote-p default-directory 'method) :user ,(file-remote-p default-directory 'user) :machine ,(file-remote-p default-directory 'host))) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 2a4ef740a0..ba00a96cfd 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -1912,7 +1912,51 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (regexp-quote envvar) (funcall this-shell-command-to-string "set"))))))))) -(ert-deftest tramp-test30-vc-registered () +;; The functions were introduced in Emacs 26.1. +(ert-deftest tramp-test30-explicit-shell-file-name () + "Check that connection-local `explicit-shell-file-name' is set." + :tags '(:expensive-test) + (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-sh-p)) + (skip-unless (and (fboundp 'connection-local-set-profile-variables) + (fboundp 'connection-local-set-profiles))) + + ;; `connection-local-set-profile-variables' and + ;; `connection-local-set-profiles' exists since Emacs 26. We don't + ;; want to see compiler warnings for older Emacsen. + (let ((default-directory tramp-test-temporary-file-directory) + explicit-shell-file-name kill-buffer-query-functions) + (unwind-protect + (progn + ;; `shell-mode' would ruin our test, because it deletes all + ;; buffer local variables. + (put 'explicit-shell-file-name 'permanent-local t) + ;; Declare connection-local variable `explicit-shell-file-name'. + (with-no-warnings + (connection-local-set-profile-variables + 'remote-sh + '((explicit-shell-file-name . "/bin/sh") + (explicit-sh-args . ("-i")))) + (connection-local-set-profiles + `(:application tramp + :protocol ,(file-remote-p default-directory 'method) + :user ,(file-remote-p default-directory 'user) + :machine ,(file-remote-p default-directory 'host)) + 'remote-sh)) + + ;; Run interactive shell. Since the default directory is + ;; remote, `explicit-shell-file-name' shall be set in order + ;; to avoid a question. + (with-current-buffer (get-buffer-create "*shell*") + (ignore-errors (kill-process (current-buffer))) + (should-not explicit-shell-file-name) + (call-interactively 'shell) + (should explicit-shell-file-name))) + + (put 'explicit-shell-file-name 'permanent-local nil) + (kill-buffer "*shell*")))) + +(ert-deftest tramp-test31-vc-registered () "Check `vc-registered'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) @@ -1983,7 +2027,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Cleanup. (ignore-errors (delete-directory tmp-name1 'recursive)))))) -(ert-deftest tramp-test31-make-auto-save-file-name () +(ert-deftest tramp-test32-make-auto-save-file-name () "Check `make-auto-save-file-name'." (skip-unless (tramp--test-enabled)) @@ -2078,7 +2122,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (ignore-errors (delete-directory tmp-name2 'recursive)))))) ;; The functions were introduced in Emacs 26.1. -(ert-deftest tramp-test32-make-nearby-temp-file () +(ert-deftest tramp-test33-make-nearby-temp-file () "Check `make-nearby-temp-file' and `temporary-file-directory'." (skip-unless (tramp--test-enabled)) (skip-unless @@ -2086,7 +2130,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; `make-nearby-temp-file' and `temporary-file-directory' exists ;; since Emacs 26. We don't want to see compiler warnings for older - ;; Emacsen." + ;; Emacsen. (let ((default-directory tramp-test-temporary-file-directory) tmp-file) ;; The remote host shall know a temporary file directory. @@ -2343,7 +2387,7 @@ This requires restrictions of file name syntax." (ignore-errors (delete-directory tmp-name2 'recursive)))))) (defun tramp--test-special-characters () - "Perform the test in `tramp-test33-special-characters*'." + "Perform the test in `tramp-test34-special-characters*'." ;; Newlines, slashes and backslashes in file names are not ;; supported. So we don't test. And we don't test the tab ;; character on Windows or Cygwin, because the backslash is @@ -2386,7 +2430,7 @@ This requires restrictions of file name syntax." "{foo}bar{baz}")) ;; These tests are inspired by Bug#17238. -(ert-deftest tramp-test33-special-characters () +(ert-deftest tramp-test34-special-characters () "Check special characters in file names." (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-rsync-p))) @@ -2394,7 +2438,7 @@ This requires restrictions of file name syntax." (tramp--test-special-characters)) -(ert-deftest tramp-test33-special-characters-with-stat () +(ert-deftest tramp-test34-special-characters-with-stat () "Check special characters in file names. Use the `stat' command." :tags '(:expensive-test) @@ -2412,7 +2456,7 @@ Use the `stat' command." tramp-connection-properties))) (tramp--test-special-characters))) -(ert-deftest tramp-test33-special-characters-with-perl () +(ert-deftest tramp-test34-special-characters-with-perl () "Check special characters in file names. Use the `perl' command." :tags '(:expensive-test) @@ -2433,7 +2477,7 @@ Use the `perl' command." tramp-connection-properties))) (tramp--test-special-characters))) -(ert-deftest tramp-test33-special-characters-with-ls () +(ert-deftest tramp-test34-special-characters-with-ls () "Check special characters in file names. Use the `ls' command." :tags '(:expensive-test) @@ -2456,7 +2500,7 @@ Use the `ls' command." (tramp--test-special-characters))) (defun tramp--test-utf8 () - "Perform the test in `tramp-test34-utf8*'." + "Perform the test in `tramp-test35-utf8*'." (let* ((utf8 (if (and (eq system-type 'darwin) (memq 'utf-8-hfs (coding-system-list))) 'utf-8-hfs 'utf-8)) @@ -2470,7 +2514,7 @@ Use the `ls' command." "银河系漫游指南系列" "Автостопом по гала́ктике"))) -(ert-deftest tramp-test34-utf8 () +(ert-deftest tramp-test35-utf8 () "Check UTF8 encoding in file names and file contents." (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-docker-p))) @@ -2480,7 +2524,7 @@ Use the `ls' command." (tramp--test-utf8)) -(ert-deftest tramp-test34-utf8-with-stat () +(ert-deftest tramp-test35-utf8-with-stat () "Check UTF8 encoding in file names and file contents. Use the `stat' command." :tags '(:expensive-test) @@ -2500,7 +2544,7 @@ Use the `stat' command." tramp-connection-properties))) (tramp--test-utf8))) -(ert-deftest tramp-test34-utf8-with-perl () +(ert-deftest tramp-test35-utf8-with-perl () "Check UTF8 encoding in file names and file contents. Use the `perl' command." :tags '(:expensive-test) @@ -2523,7 +2567,7 @@ Use the `perl' command." tramp-connection-properties))) (tramp--test-utf8))) -(ert-deftest tramp-test34-utf8-with-ls () +(ert-deftest tramp-test35-utf8-with-ls () "Check UTF8 encoding in file names and file contents. Use the `ls' command." :tags '(:expensive-test) @@ -2547,7 +2591,7 @@ Use the `ls' command." (tramp--test-utf8))) ;; This test is inspired by Bug#16928. -(ert-deftest tramp-test35-asynchronous-requests () +(ert-deftest tramp-test36-asynchronous-requests () "Check parallel asynchronous requests. Such requests could arrive from timers, process filters and process sentinels. They shall not disturb each other." @@ -2636,7 +2680,7 @@ process sentinels. They shall not disturb each other." (dolist (buf buffers) (ignore-errors (kill-buffer buf)))))))) -(ert-deftest tramp-test36-recursive-load () +(ert-deftest tramp-test37-recursive-load () "Check that Tramp does not fail due to recursive load." (skip-unless (tramp--test-enabled)) @@ -2657,7 +2701,7 @@ process sentinels. They shall not disturb each other." (mapconcat 'shell-quote-argument load-path " -L ") (shell-quote-argument code))))))) -(ert-deftest tramp-test37-unload () +(ert-deftest tramp-test38-unload () "Check that Tramp and its subpackages unload completely. Since it unloads Tramp, it shall be the last test to run." ;; Mark as failed until all symbols are unbound. @@ -2704,8 +2748,8 @@ Since it unloads Tramp, it shall be the last test to run." ;; * Work on skipped tests. Make a comment, when it is impossible. ;; * Fix `tramp-test06-directory-file-name' for `ftp'. ;; * Fix `tramp-test27-start-file-process' on MS Windows (`process-send-eof'?). -;; * Fix Bug#16928. Set expected error of `tramp-test35-asynchronous-requests'. -;; * Fix `tramp-test37-unload' (Not all symbols are unbound). Set +;; * Fix Bug#16928. Set expected error of `tramp-test36-asynchronous-requests'. +;; * Fix `tramp-test38-unload' (Not all symbols are unbound). Set ;; expected error. (defun tramp-test-all (&optional interactive)