commit 1319d108dae70a8349110acd0f88d22436a9a70c (HEAD, refs/remotes/origin/master) Merge: 5d257a99b7 6d3608be88 Author: Stefan Kangas Date: Sun Jan 23 06:30:31 2022 +0100 Merge from origin/emacs-28 6d3608be88 Seccomp: improve support for newer versions of glibc (Bug#... e58ecd01d5 EUDC: Fix a quoting bug in the BBDB backend commit 5d257a99b7a67ffb61b315480182593f48ceee5f Author: Po Lu Date: Sun Jan 23 01:25:55 2022 +0000 Fix documentation formatting error * doc/lispref/streams.texi (Input Functions): Remove extraneous @end defun. diff --git a/doc/lispref/streams.texi b/doc/lispref/streams.texi index 70652a2c2b..8f8562cadc 100644 --- a/doc/lispref/streams.texi +++ b/doc/lispref/streams.texi @@ -326,7 +326,6 @@ For example: @end group @end example @end defun -@end defun @defun read-positioning-symbols &optional stream This function reads one textual expression from @var{stream}, like commit bdcbe897d19bd5fbf1ecf89c5ecf1e0c56b270ac Author: Po Lu Date: Sun Jan 23 01:19:22 2022 +0000 * src/haikumenu.c (run_menu_bar_help_event): Fix bounds sanity check. diff --git a/src/haikumenu.c b/src/haikumenu.c index 2922981cb3..1c75e0f9a4 100644 --- a/src/haikumenu.c +++ b/src/haikumenu.c @@ -616,7 +616,7 @@ run_menu_bar_help_event (struct frame *f, int mb_idx) } vec = f->menu_bar_vector; - if (mb_idx >= ASIZE (vec)) + if ((mb_idx + MENU_ITEMS_ITEM_HELP) >= ASIZE (vec)) emacs_abort (); help = AREF (vec, mb_idx + MENU_ITEMS_ITEM_HELP); commit 7c16f691011deb0843ea8d7c8324aca034cbd56c Author: Po Lu Date: Sun Jan 23 09:14:16 2022 +0800 Clean up some of the X extension related code * src/image.c (Fimage_transforms_p): Remove unused variables. * src/xterm.c (x_probe_xfixes_extension): (x_term_init): Probe for xfixes during terminal initialization instead. * src/xterm.h (struct x_display_info): New fields for xfixes support. diff --git a/src/image.c b/src/image.c index ce9af2dd67..7ee595297f 100644 --- a/src/image.c +++ b/src/image.c @@ -11195,8 +11195,6 @@ The list of capabilities can include one or more of the following: || defined (HAVE_HAIKU) return list2 (Qscale, Qrotate90); # elif defined (HAVE_X_WINDOWS) && defined (HAVE_XRENDER) - int event_basep, error_basep; - if (FRAME_DISPLAY_INFO (f)->xrender_supported_p) return list2 (Qscale, Qrotate90); # elif defined (HAVE_NTGUI) diff --git a/src/xterm.c b/src/xterm.c index 36e0045d2e..2a4ea883bc 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -14920,8 +14920,12 @@ static bool x_probe_xfixes_extension (Display *dpy) { #ifdef HAVE_XFIXES - int major, minor; - return XFixesQueryVersion (dpy, &major, &minor) && major >= 4; + struct x_display_info *info + = x_display_info_for_display (dpy); + + return (info + && info->xfixes_supported_p + && info->xfixes_major >= 4); #else return false; #endif /* HAVE_XFIXES */ @@ -15431,6 +15435,20 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) } #endif +#ifdef HAVE_XFIXES + int xfixes_event_base, xfixes_error_base; + dpyinfo->xfixes_supported_p + = XFixesQueryExtension (dpyinfo->display, &xfixes_event_base, + &xfixes_error_base); + + if (dpyinfo->xfixes_supported_p) + { + if (!XFixesQueryVersion (dpyinfo->display, &dpyinfo->xfixes_major, + &dpyinfo->xfixes_minor)) + dpyinfo->xfixes_supported_p = false; + } +#endif + #if defined USE_CAIRO || defined HAVE_XFT { /* If we are using Xft, the following precautions should be made: diff --git a/src/xterm.h b/src/xterm.h index 26b2851590..a4ad57edda 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -546,6 +546,12 @@ struct x_display_info int xrender_major; int xrender_minor; #endif + +#ifdef HAVE_XFIXES + bool xfixes_supported_p; + int xfixes_major; + int xfixes_minor; +#endif }; #ifdef HAVE_X_I18N commit 27e080d009076c4c7482201987af36d423a75b61 Author: Po Lu Date: Sun Jan 23 08:45:21 2022 +0800 * src/pgtkterm.c (pgtk_flash): Fix input blocking. diff --git a/src/pgtkterm.c b/src/pgtkterm.c index 8073f51c61..efbeaafaf1 100644 --- a/src/pgtkterm.c +++ b/src/pgtkterm.c @@ -3731,12 +3731,12 @@ recover_from_visible_bell (struct atimer *timer) static void pgtk_flash (struct frame *f) { - block_input (); - { if (!FRAME_CR_CONTEXT (f)) return; + block_input (); + cairo_surface_t *surface_orig = FRAME_CR_SURFACE (f); int width = FRAME_CR_SURFACE_DESIRED_WIDTH (f); @@ -3806,9 +3806,8 @@ pgtk_flash (struct frame *f) } cairo_destroy (cr); + unblock_input (); } - - unblock_input (); } /* Make audible bell. */ commit 7922131bb20ebf5570cf9a7fd96c957677e2a6c2 Author: Eli Zaretskii Date: Sat Jan 22 20:47:10 2022 +0200 Minor copyedits in "Symbols with Position" * doc/lispref/symbols.texi (Symbols with Position): Fix wording and improve indexing. diff --git a/doc/lispref/symbols.texi b/doc/lispref/symbols.texi index f3a9e586e3..9e44348b67 100644 --- a/doc/lispref/symbols.texi +++ b/doc/lispref/symbols.texi @@ -754,8 +754,9 @@ Symbol forms whose names start with @samp{#_} are not transformed. @node Symbols with Position @section Symbols with Position -@cindex symbols with position +@cindex symbol with position +@cindex bare symbol A @dfn{symbol with position} is a symbol, the @dfn{bare symbol}, together with an unsigned integer called the @dfn{position}. These objects are intended for use by the byte compiler, which records in @@ -802,12 +803,12 @@ position, @code{nil} otherwise. @defun bare-symbol symbol This function returns the bare symbol contained in @var{symbol}, or @var{symbol} itself if it is already a bare symbol. For any other -type of object, it throws an error. +type of object, it signals an error. @end defun @defun symbol-with-pos-pos symbol This function returns the position, a number, from a symbol with -position. For any other type of object, it throws an error. +position. For any other type of object, it signals an error. @end defun @defun position-symbol sym pos @@ -815,5 +816,5 @@ Make a new symbol with position. @var{sym} is either a bare symbol or a symbol with position, and supplies the symbol part of the new object. @var{pos} is either an integer which becomes the number part of the new object, or a symbol with position whose position is used. -Emacs throws an error if either argument is invalid. +Emacs signals an error if either argument is invalid. @end defun commit df49e3a3ab4cddf1e3c0f5482c7fdd809d8a8884 Merge: fd31ef21c5 f57f28935a Author: Alan Mackenzie Date: Sat Jan 22 18:02:01 2022 +0000 Merge branch 'master' of /home/acm/emacs/emacs.git/master commit fd31ef21c5b4679da9c2e26f5aeade8d667d9089 Author: Alan Mackenzie Date: Sat Jan 22 17:48:46 2022 +0000 Don't use 'load-read-function' in byte-compile-from-buffer * lisp/emacs-lisp/bytecomp.el (byte-compile-from-buffer): Call read-positioning-symbols directly, rather than binding load-read-function to it. This is so that a lower level use of load-read-function will not return a form containing symbols with position. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 903dd50e34..794dc531ea 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2303,8 +2303,11 @@ With argument ARG, insert value in current buffer after the form." (forward-line 1)) (not (eobp))) (let* ((lread--unescaped-character-literals nil) - (load-read-function #'read-positioning-symbols) - (form (funcall load-read-function inbuffer)) + ;; Don't bind `load-read-function' to + ;; `read-positioning-symbols' here. Calls to `read' + ;; at a lower level must not get symbols with + ;; position. + (form (read-positioning-symbols inbuffer)) (warning (byte-run--unescaped-character-literals-warning))) (when warning (byte-compile-warn-x form "%s" warning)) (byte-compile-toplevel-file-form form))) commit 88e1f8b02086aaf652e3058b36b7612c073c04b3 Merge: 1edde2fc7a 14d64a8adc Author: Alan Mackenzie Date: Sat Jan 22 17:41:03 2022 +0000 Merge branch 'scratch/correct-warning-pos' commit f57f28935a1f0c46776976dd497322a07d248f5f Author: Lars Ingebrigtsen Date: Sat Jan 22 16:46:46 2022 +0100 Fix print-unreadable-function documentation * doc/lispref/streams.texi (Output Variables): Fix description of non-string values. diff --git a/doc/lispref/streams.texi b/doc/lispref/streams.texi index 784adb9bd5..bf728ea3e9 100644 --- a/doc/lispref/streams.texi +++ b/doc/lispref/streams.texi @@ -895,9 +895,9 @@ be called to handle printing of these objects. The function will be called with two arguments: the object and the @var{noescape} flag used by the printing functions (@pxref{Output Functions}). -The function should return either @code{nil} (print nothing), or a -string (which will be printed), or any other object (which means that -the object should be printed normally). For instance: +The function should return either @code{nil} (print the object as +usual), or a string (which will be printed), or any other object +(don't print the object). For instance: @example (let ((print-unreadable-function commit 6d3608be88e1b30d2d10ee81f14dd485275c20ff (refs/remotes/origin/emacs-28) Author: Philipp Stephani Date: Sat Jan 22 17:11:37 2022 +0100 Seccomp: improve support for newer versions of glibc (Bug#51073) * lib-src/seccomp-filter.c (main): Allow 'pread64' and 'faccessat2' system calls. Newer versions of glibc use these system call (starting with commits 95c1056962a3f2297c94ce47f0eaf0c5b6563231 and 3d3ab573a5f3071992cbc4f57d50d1d29d55bde2, respectively). diff --git a/lib-src/seccomp-filter.c b/lib-src/seccomp-filter.c index 552a986239..d368cbb46c 100644 --- a/lib-src/seccomp-filter.c +++ b/lib-src/seccomp-filter.c @@ -228,6 +228,7 @@ main (int argc, char **argv) capabilities, and operating on them shouldn't cause security issues. */ RULE (SCMP_ACT_ALLOW, SCMP_SYS (read)); + RULE (SCMP_ACT_ALLOW, SCMP_SYS (pread64)); RULE (SCMP_ACT_ALLOW, SCMP_SYS (write)); RULE (SCMP_ACT_ALLOW, SCMP_SYS (close)); RULE (SCMP_ACT_ALLOW, SCMP_SYS (lseek)); @@ -239,6 +240,7 @@ main (int argc, char **argv) should be further restricted using mount namespaces. */ RULE (SCMP_ACT_ALLOW, SCMP_SYS (access)); RULE (SCMP_ACT_ALLOW, SCMP_SYS (faccessat)); + RULE (SCMP_ACT_ALLOW, SCMP_SYS (faccessat2)); RULE (SCMP_ACT_ALLOW, SCMP_SYS (stat)); RULE (SCMP_ACT_ALLOW, SCMP_SYS (stat64)); RULE (SCMP_ACT_ALLOW, SCMP_SYS (lstat)); commit 6139a05241aa3f082b49cbfe90ce61ceb0189bf7 Author: Michael Albinus Date: Sat Jan 22 17:12:14 2022 +0100 Add direct remote copying in Tramp's scp support * doc/misc/tramp.texi: Use @trampfn{} function where possible. (Top, Configuration): Insert section 'Ssh setup' and remove section 'Windows setup hints' in menu. (Default Method): Mention tramp-use-scp-direct-remote-copying. (Ssh setup): New node. (Windows setup hints): Move it to that new node. (Frequently Asked Questions): Move items about ssh config to that node. * etc/NEWS: Add Tramp's direct remote copying feature. Fix typos. * lisp/net/tramp-sh.el (tramp-use-scp-direct-remote-copying): New defcustom. (tramp-methods) : Add "%y" marker. (tramp-scp-direct-remote-copying): New defun. (tramp-do-copy-or-rename-file-out-of-band): Extend for direct remote copying. * lisp/net/tramp.el (tramp-methods): Extend docstring. (tramp-password-prompt-not-unique): New defvar. (tramp-read-passwd): Adapt docstring. (tramp-read-passwd-without-cache): New defun. (tramp-action-password): Call it. diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 6a198e9bfb..ea544218ec 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -133,19 +133,21 @@ Configuring @value{tramp} for use * Multi-hops:: Connecting to a remote host using multiple hops. * Firewalls:: Passing firewalls. * Customizing Methods:: Using Non-Standard Methods. -* Customizing Completion:: Selecting config files for user/host name completion. +* Customizing Completion:: Selecting config files for user/host name @c +completion. * Password handling:: Reusing passwords for several connections. * Connection caching:: Reusing connection related information. * Predefined connection information:: Setting own connection related information. -* Remote programs:: How @value{tramp} finds and uses programs on the remote host. +* Remote programs:: How @value{tramp} finds and uses programs @c +on the remote host. * Remote shell setup:: Remote shell setup hints. +* Ssh setup:: Ssh setup hints. * FUSE setup:: @acronym{FUSE} setup hints. * Android shell setup:: Android shell setup hints. * Auto-save File Lock and Backup:: Auto-save, File Lock and Backup. * Keeping files encrypted:: Protect remote files by encryption. -* Windows setup hints:: Issues with Cygwin ssh. Using @value{tramp} @@ -523,7 +525,7 @@ performed on another host, it can be comnbined with a leading connects first to the other host with non-administrative credentials, and changes to administrative credentials on that host afterwards. In a simple case, the syntax looks like -@file{@value{prefix}ssh@value{postfixhop}user@@host|sudo@value{postfixhop}@value{postfix}/path/to/file}. +@file{@trampfn{ssh@value{postfixhop}user@@host|sudo,,/path/to/file}}. @xref{Ad-hoc multi-hops}. @@ -683,19 +685,21 @@ may be used in your init file: * Multi-hops:: Connecting to a remote host using multiple hops. * Firewalls:: Passing firewalls. * Customizing Methods:: Using Non-Standard Methods. -* Customizing Completion:: Selecting config files for user/host name completion. +* Customizing Completion:: Selecting config files for user/host name @c +completion. * Password handling:: Reusing passwords for several connections. * Connection caching:: Reusing connection related information. * Predefined connection information:: Setting own connection related information. -* Remote programs:: How @value{tramp} finds and uses programs on the remote host. +* Remote programs:: How @value{tramp} finds and uses programs @c +on the remote host. * Remote shell setup:: Remote shell setup hints. +* Ssh setup:: Ssh setup hints. * FUSE setup:: @acronym{FUSE} setup hints. * Android shell setup:: Android shell setup hints. * Auto-save File Lock and Backup:: Auto-save, File Lock and Backup. * Keeping files encrypted:: Protect remote files by encryption. -* Windows setup hints:: Issues with Cygwin ssh. @end menu @@ -1234,7 +1238,8 @@ be populated in your @command{Online Accounts} application outside Emacs. Since Google Drive uses cryptic blob file names internally, @value{tramp} works with the @code{display-name} of the files. This could produce unexpected behavior in case two files in the same -directory have the same @code{display-name}, such a situation must be avoided. +directory have the same @code{display-name}, such a situation must be +avoided. @item @option{mtp} @cindex method @option{mtp} @@ -1448,7 +1453,7 @@ External methods might be more efficient for large files, but most @value{tramp} users edit small files more often than large files. Enable compression, @code{tramp-inline-compress-start-size}, for a -performance boost for large files. +performance boost for large files with inline methods. Since @command{ssh} has become the most common method of remote host access and it has the most reasonable security protocols, use @@ -1474,6 +1479,10 @@ For editing large files, @option{scp} is faster than @option{ssh}. @option{pscp} is faster than @option{plink}. But this speed improvement is not always true. +When copying large files between two different remote hosts via +@option{scp}, set @code{tramp-use-scp-direct-remote-copying} to +non-@code{nil}. + @node Default User @section Selecting a default user @@ -1689,8 +1698,8 @@ Sometimes, it is not possible to reach a remote host directly. A firewall might be in the way, which could be passed via a proxy server. -Both ssh and PuTTY support such proxy settings, using an HTTP tunnel -via the @command{CONNECT} command (conforming to RFC 2616, 2817 +Both OpenSSH and PuTTY support such proxy settings, using an HTTP +tunnel via the @command{CONNECT} command (conforming to RFC 2616, 2817 specifications). Proxy servers using HTTP 1.1 or later protocol support this command. @@ -1804,7 +1813,7 @@ hadoop server. @cindex @option{vagrant} method Convenience method to access vagrant boxes. It is often used in multi-hop file names like -@file{@value{prefix}vagrant@value{postfixhop}box|sudo@value{postfixhop}box@value{postfix}/path/to/file}, +@file{@trampfn{vagrant@value{postfixhop}box|sudo,box,/path/to/file}}, where @samp{box} is the name of the vagrant box. @end table @@ -2606,6 +2615,211 @@ where @samp{192.168.0.1} is the remote host IP address @end table +@node Ssh setup +@section Ssh setup hints + +The most common @value{tramp} connection family is based on either +@command{ssh} or @command{scp} of OpenSSH, or @command{plink} or +@command{pscp} of PuTTY on MS Windows. In the following, some +configuration recommendations are given. + + +@subsection Detection of session hangouts + +@vindex ServerAliveInterval@r{, ssh option} +@vindex ServerAliveCountMax@r{, ssh option} +@command{ssh} sessions on the local host hang when the network is +down. @value{tramp} cannot safely detect such hangs. OpenSSH can be +configured to kill such hangs with the following settings in +@file{~/.ssh/config}: + +@example +@group +Host * + ServerAliveInterval 5 + ServerAliveCountMax 2 +@end group +@end example + +The corresponding PuTTY configuration is in the @option{Connection} +entry, @option{Seconds between keepalives} option. Set this to 5. +There is no counter which could be set. + + +@subsection Using ssh connection sharing + +@vindex ControlPath@r{, ssh option} +@vindex ControlPersist@r{, ssh option} +@value{tramp} uses the @option{ControlMaster=auto} OpenSSH option by +default, if possible. However, it overwrites @option{ControlPath} +settings when initiating @command{ssh} sessions. @value{tramp} does +this to fend off a stall if a master session opened outside the Emacs +session is no longer open. That is why @value{tramp} prompts for the +password again even if there is an @command{ssh} already open. + +@vindex tramp-ssh-controlmaster-options +Some OpenSSH versions support a @option{ControlPersist} option, which +allows you to set the @option{ControlPath} provided the variable +@code{tramp-ssh-controlmaster-options} is customized as follows: + +@lisp +@group +(customize-set-variable + 'tramp-ssh-controlmaster-options + (concat + "-o ControlPath=/tmp/ssh-ControlPath-%%r@@%%h:%%p " + "-o ControlMaster=auto -o ControlPersist=yes")) +@end group +@end lisp + +Note how @samp{%r}, @samp{%h} and @samp{%p} must be encoded as +@samp{%%r}, @samp{%%h} and @samp{%%p}. + +@vindex tramp-use-ssh-controlmaster-options +If the @file{~/.ssh/config} file is configured appropriately for the +above behavior, then any changes to @command{ssh} can be suppressed +with this @code{nil} setting: + +@lisp +(customize-set-variable 'tramp-use-ssh-controlmaster-options nil) +@end lisp + +@vindex ProxyCommand@r{, ssh option} +@vindex ProxyJump@r{, ssh option} +This should also be set to @code{nil} if you use the +@option{ProxyCommand} or @option{ProxyJump} options in your +@command{ssh} configuration. + +In order to use the @option{ControlMaster} option, @value{tramp} must +check whether the @command{ssh} client supports this option. This is +only possible on the local host, for the first hop. @value{tramp} +does not use this option on proxy hosts, therefore. + +If you want to use this option also for the other hops, you must +configure @file{~/.ssh/config} on the proxy host: + +@example +@group +Host * + ControlMaster auto + ControlPath tramp.%C + ControlPersist no +@end group +@end example + +Check the @samp{ssh_config(5)} man page whether these options are +supported on your proxy host. + +On MS Windows, @code{tramp-use-ssh-controlmaster-options} is set to +@code{nil} by default, because the MS Windows and MSYS2 +implementations of @command{OpenSSH} do not support this option properly. + +In PuTTY, you can achieve connection sharing in the @option{Connection/SSH} +entry, enabling the @option{Share SSH connections if possible} option. + + +@subsection Configure direct copying between two remote servers + +@vindex tramp-use-scp-direct-remote-copying +@value{tramp} uses a temporary local copy when copying two files +between different remote hosts via external methods. This behavior is +due to authentication problems @value{tramp} cannot handle +sufficiently. However, for @option{scp} connections this can be +changed. When a file shall be copied between two different remote +hosts @samp{source} and @samp{target}, and + +@itemize @minus +@item +Variable @code{tramp-use-scp-direct-remote-copying} is non-@code{nil}, + +@item +Remote host @samp{source} doesn't use the @option{RemoteCommand} +option in @file{~/.ssh/config}, + +@item +Remote host @samp{target} shows the same host key when seen from the +local host and from host @samp{source}, and + +@item +@command{scp} running on host @samp{source} can authenticate to host +@samp{target} without requiring a password, +@end itemize + +@noindent +@value{tramp} applies direct remote copying between hosts +@samp{source} and @samp{target} like + +@example +scp -p -T -R -q -r source:/path/to/file target:/path/to/another/file +@end example + +This protects also your local temporary directory from overrun when +copying large files. + +If these conditions do not apply, and +@code{tramp-use-scp-direct-remote-copying} is non-@code{nil}, the +option @samp{-3} is used instead of @samp{-R}. + +@c FIXME +When @value{tramp} uses direct remote copying, password caches are not +consulted. + + +@subsection Issues with Cygwin ssh +@cindex cygwin, issues + +This section is incomplete. Please share your solutions. + +@cindex method @option{sshx} with cygwin +@cindex @option{sshx} method with cygwin + +Cygwin's @command{ssh} works only with a Cygwin version of Emacs. To +check for compatibility: type @kbd{M-x eshell @key{RET}}, and start +@kbd{ssh test.host @key{RET}}. Incompatibilities trigger this +message: + +@example +Pseudo-terminal will not be allocated because stdin is not a terminal. +@end example + +Some older versions of Cygwin's @command{ssh} work with the +@option{sshx} access method. Consult Cygwin's FAQ at +@uref{https://cygwin.com/faq/} for details. + +@cindex cygwin and @command{fakecygpty} +@cindex @command{fakecygpty} and cygwin + +On @uref{https://www.emacswiki.org/emacs/SshWithNTEmacs, the Emacs +Wiki} it is explained how to use the helper program +@command{fakecygpty} to fix this problem. + +@cindex method @option{scpx} with cygwin +@cindex @option{scpx} method with cygwin + +When using the @option{scpx} access method, Emacs may call +@command{scp} with MS Windows file naming, such as @file{c:/foo}. But +the version of @command{scp} that is installed with Cygwin does not +know about MS Windows file naming, which causes it to incorrectly look +for a host named @samp{c}. + +A workaround: write a wrapper script for @option{scp} to convert +Windows file names to Cygwin file names. + +@cindex cygwin and @command{ssh-agent} +@cindex @env{SSH_AUTH_SOCK} and emacs on ms windows +@vindex SSH_AUTH_SOCK@r{, environment variable} + +When using the @command{ssh-agent} on MS Windows for password-less +interaction, @option{ssh} methods depend on the environment variable +@env{SSH_AUTH_SOCK}. But this variable is not set when Emacs is +started from a Desktop shortcut and authentication fails. + +One workaround is to use an MS Windows based SSH Agent, such as +@command{Pageant}. It is part of the PuTTY Suite of tools. + +The fallback is to start Emacs from a shell. + + @node FUSE setup @section @acronym{FUSE} setup hints @@ -2828,10 +3042,10 @@ Example: The backup file name of @file{@trampfn{su,root@@localhost,/etc/secretfile}} would be @ifset unified -@file{@trampfn{su,root@@localhost,~/.emacs.d/backups/!su:root@@localhost:!etc!secretfile~}} +@file{@trampfn{su,root@@localhost,~/.emacs.d/backups/!su:root@@localhost:!etc!secretfile~}}. @end ifset @ifset separate -@file{@trampfn{su,root@@localhost,~/.emacs.d/backups/![su!root@@localhost]!etc!secretfile~}} +@file{@trampfn{su,root@@localhost,~/.emacs.d/backups/![su!root@@localhost]!etc!secretfile~}}. @end ifset @vindex auto-save-file-name-transforms @@ -2985,62 +3199,6 @@ subdirectories will remain encrypted. @end deffn -@node Windows setup hints -@section Issues with Cygwin ssh -@cindex cygwin, issues - -This section is incomplete. Please share your solutions. - -@cindex method @option{sshx} with cygwin -@cindex @option{sshx} method with cygwin - -Cygwin's @command{ssh} works only with a Cygwin version of Emacs. To -check for compatibility: type @kbd{M-x eshell @key{RET}}, and start -@kbd{ssh test.host @key{RET}}. Incompatibilities trigger this -message: - -@example -Pseudo-terminal will not be allocated because stdin is not a terminal. -@end example - -Some older versions of Cygwin's @command{ssh} work with the -@option{sshx} access method. Consult Cygwin's FAQ at -@uref{https://cygwin.com/faq/} for details. - -@cindex cygwin and @command{fakecygpty} -@cindex @command{fakecygpty} and cygwin - -On @uref{https://www.emacswiki.org/emacs/SshWithNTEmacs, the Emacs -Wiki} it is explained how to use the helper program -@command{fakecygpty} to fix this problem. - -@cindex method @option{scpx} with cygwin -@cindex @option{scpx} method with cygwin - -When using the @option{scpx} access method, Emacs may call -@command{scp} with MS Windows file naming, such as @file{c:/foo}. But -the version of @command{scp} that is installed with Cygwin does not -know about MS Windows file naming, which causes it to incorrectly look -for a host named @samp{c}. - -A workaround: write a wrapper script for @option{scp} to convert -Windows file names to Cygwin file names. - -@cindex cygwin and @command{ssh-agent} -@cindex @env{SSH_AUTH_SOCK} and emacs on ms windows -@vindex SSH_AUTH_SOCK@r{, environment variable} - -When using the @command{ssh-agent} on MS Windows for password-less -interaction, @option{ssh} methods depend on the environment variable -@env{SSH_AUTH_SOCK}. But this variable is not set when Emacs is -started from a Desktop shortcut and authentication fails. - -One workaround is to use an MS Windows based SSH Agent, such as -Pageant. It is part of the Putty Suite of tools. - -The fallback is to start Emacs from a shell. - - @node Usage @chapter Using @value{tramp} @cindex using @value{tramp} @@ -3085,23 +3243,23 @@ is a feature of Emacs that may cause missed prompts when using on the remote host @var{host}, using the method @var{method}. @table @file -@item @value{prefix}ssh@value{postfixhop}melancholia@value{postfix}.emacs +@item @trampfn{ssh,melancholia,.emacs} For the file @file{.emacs} located in the home directory, on the host @code{melancholia}, using method @code{ssh}. -@item @value{prefix}ssh@value{postfixhop}melancholia.danann.net@value{postfix}.emacs +@item @trampfn{ssh,melancholia.danann.net,.emacs} For the file @file{.emacs} specified using the fully qualified domain name of the host. -@item @value{prefix}ssh@value{postfixhop}melancholia@value{postfix}~/.emacs +@item @trampfn{ssh,melancholia,~/.emacs} For the file @file{.emacs} specified using the @file{~}, which is expanded. -@item @value{prefix}ssh@value{postfixhop}melancholia@value{postfix}~daniel/.emacs +@item @trampfn{ssh,melancholia,~daniel/.emacs} For the file @file{.emacs} located in @code{daniel}'s home directory on the host, @code{melancholia}. The @file{~} construct is expanded to the home directory of that user on the remote host. -@item @value{prefix}ssh@value{postfixhop}melancholia@value{postfix}/etc/squid.conf +@item @trampfn{ssh,melancholia,/etc/squid.conf} For the file @file{/etc/squid.conf} on the host @code{melancholia}. @end table @@ -3115,12 +3273,9 @@ brackets @file{@value{ipv6prefix}} and @file{@value{ipv6postfix}}. @end ifset By default, @value{tramp} will use the current local user name as the -remote user name for log in to the remote host. Specifying a different -name using the proper syntax will override this default behavior: - -@example -@trampfn{method,user@@host,path/to/file} -@end example +remote user name for log in to the remote host. Specifying a +different name using the proper syntax will override this default +behavior: @file{@trampfn{method,user@@host,path/to/file}}. @file{@trampfn{ssh,daniel@@melancholia,.emacs}} is for file @file{.emacs} in @code{daniel}'s home directory on the host, @@ -3316,8 +3471,9 @@ remote host name and file name. For example, hopping over a single proxy @samp{bird@@bastion} to a remote file on @samp{you@@remotehost}: @example -@c @kbd{C-x C-f @trampfn{ssh@value{postfixhop}bird@@bastion|ssh,you,remotehost,/path} @key{RET}} -@kbd{C-x C-f @value{prefix}ssh@value{postfixhop}bird@@bastion|ssh@value{postfixhop}you@@remotehost@value{postfix}/path @key{RET}} +@c @kbd{C-x C-f @trampfn{ssh@value{postfixhop}bird@@bastion|ssh,you@@remotehost,/path} @key{RET}} +@kbd{C-x C-f @value{prefix}ssh@value{postfixhop}bird@@bastion|@c +ssh@value{postfixhop}you@@remotehost@value{postfix}/path @key{RET}} @end example Each involved method must be an inline method (@pxref{Inline methods}). @@ -3345,12 +3501,12 @@ Ad-hoc proxies can take patterns @code{%h} or @code{%u} like in @code{tramp-default-proxies-alist}. The following file name expands to user @samp{root} on host @samp{remotehost}, starting with an @option{ssh} session on host @samp{remotehost}: -@samp{@value{prefix}ssh@value{postfixhop}%h|su@value{postfixhop}remotehost@value{postfix}}. +@samp{@trampfn{ssh@value{postfixhop}%h|su,remotehost,}}. -On the other hand, if a trailing hop does not specify a host name, -the host name of the previous hop is reused. Therefore, the following +On the other hand, if a trailing hop does not specify a host name, the +host name of the previous hop is reused. Therefore, the following file name is equivalent to the previous example: -@samp{@value{prefix}ssh@value{postfixhop}remotehost|su@value{postfixhop}@value{postfix}}. +@samp{@trampfn{ssh@value{postfixhop}remotehost|su,,}}. @node Remote processes @@ -3971,7 +4127,9 @@ would trigger renaming of buffer file names on @samp{badhost} to @samp{goodhost}, including changing the directory name. @lisp -("@trampfn{ssh,.+\\\\.company\\\\.org,}" . "@value{prefix}ssh@value{postfixhop}multi.hop|ssh@value{postfixhop}%h@value{postfix}") +("@trampfn{ssh,.+\\\\.company\\\\.org,}" @c +. "@value{prefix}ssh@value{postfixhop}multi.hop|@c +ssh@value{postfixhop}%h@value{postfix}") @end lisp routes all connections to a host in @samp{company.org} via @@ -4231,7 +4389,8 @@ It is even possible to access file archives in file archives, as (progn (url-handler-mode 1) (find-file - "https://ftp.debian.org/debian/pool/main/c/coreutils/coreutils_8.28-1_amd64.deb/control.tar.gz/control")) + "https://ftp.debian.org/debian/pool/main/c/coreutils/\ +coreutils_8.28-1_amd64.deb/control.tar.gz/control")) @end group @end lisp @@ -4537,97 +4696,6 @@ In order to disable those optimizations, set user option @code{tramp-local-host-regexp} to @code{nil}. -@item -@value{tramp} does not recognize if a @command{ssh} session hangs - -@vindex ServerAliveInterval@r{, ssh option} -@command{ssh} sessions on the local host hang when the network is -down. @value{tramp} cannot safely detect such hangs. The network -configuration for @command{ssh} can be configured to kill such hangs -with the following command in the @file{~/.ssh/config}: - -@example -@group -Host * - ServerAliveInterval 5 -@end group -@end example - - -@item -@value{tramp} does not use default @command{ssh} @option{ControlPath} - -@vindex ControlPath@r{, ssh option} -@vindex ControlPersist@r{, ssh option} -@value{tramp} overwrites @option{ControlPath} settings when initiating -@command{ssh} sessions. @value{tramp} does this to fend off a stall -if a master session opened outside the Emacs session is no longer -open. That is why @value{tramp} prompts for the password again even -if there is an @command{ssh} already open. - -@vindex tramp-ssh-controlmaster-options -Some @command{ssh} versions support a @option{ControlPersist} option, -which allows you to set the @option{ControlPath} provided the variable -@code{tramp-ssh-controlmaster-options} is customized as follows: - -@lisp -@group -(customize-set-variable - 'tramp-ssh-controlmaster-options - (concat - "-o ControlPath=/tmp/ssh-ControlPath-%%r@@%%h:%%p " - "-o ControlMaster=auto -o ControlPersist=yes")) -@end group -@end lisp - -Note how @samp{%r}, @samp{%h} and @samp{%p} must be encoded as -@samp{%%r}, @samp{%%h} and @samp{%%p}. - -@vindex tramp-use-ssh-controlmaster-options -If the @file{~/.ssh/config} file is configured appropriately for the -above behavior, then any changes to @command{ssh} can be suppressed -with this @code{nil} setting: - -@lisp -(customize-set-variable 'tramp-use-ssh-controlmaster-options nil) -@end lisp - -@vindex ProxyCommand@r{, ssh option} -@vindex ProxyJump@r{, ssh option} -This should also be set to @code{nil} if you use the -@option{ProxyCommand} or @option{ProxyJump} options in your -@command{ssh} configuration. - -On MS Windows, @code{tramp-use-ssh-controlmaster-options} is set to -@code{nil} by default, because the MS Windows and MSYS2 -implementations of @command{OpenSSH} do not support this option properly. - - -@item -On multi-hop connections, @value{tramp} does not use @command{ssh} -@option{ControlMaster} - -In order to use the @option{ControlMaster} option, @value{tramp} must -check whether the @command{ssh} client supports this option. This is -only possible on the local host, for the first hop. @value{tramp} -does not use this option on proxy hosts. - -If you want to use this option also for the other hops, you must -configure @file{~/.ssh/config} on the proxy host: - -@example -@group -Host * - ControlMaster auto - ControlPath tramp.%C - ControlPersist no -@end group -@end example - -Check the @samp{ssh_config(5)} man page whether these options are -supported on your proxy host. - - @item Does @value{tramp} support @acronym{SSH} security keys? @@ -5075,7 +5143,8 @@ Why saved multi-hop file names do not work in a new Emacs session? When saving ad-hoc multi-hop @value{tramp} file names (@pxref{Ad-hoc multi-hops}) via bookmarks, recent files, filecache, bbdb, or another package, use the full ad-hoc file name including all hops, like -@file{@trampfn{ssh,bird@@bastion|ssh@value{postfixhop}news.my.domain,/opt/news/etc}}. +@file{@trampfn{ssh,bird@@bastion|ssh@value{postfixhop}@c +news.my.domain,/opt/news/etc}}. Alternatively, when saving abbreviated multi-hop file names @file{@trampfn{ssh,news@@news.my.domain,/opt/news/etc}}, the user @@ -5384,7 +5453,7 @@ bind it to non-@code{nil} value. Keeping a local cache of remote file attributes in sync with the remote host is a time-consuming operation. Flushing and re-querying these attributes can tax @value{tramp} to a grinding halt on busy -remote servers. +remote hosts. To get around these types of slow-downs in @value{tramp}'s responsiveness, set the @code{process-file-side-effects} to @code{nil} @@ -5539,6 +5608,8 @@ function call traces are written to the buffer @file{*trace-output*}. @c @c * Say something about the .login and .profile files of the remote @c shells. +@c @c * Explain how tramp.el works in principle: open a shell on a remote @c host and then send commands to it. +@c @c * Consistent small or capitalized words especially in menus. diff --git a/etc/NEWS b/etc/NEWS index 048f6d5598..5297db3e2d 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -72,8 +72,8 @@ work on any underlying window system supported by GDK, such as Wayland and Broadway. --- -** The docstrings of preloaded files are not in 'etc/DOC' any more. -Instead, they're fetched as needed from the corresponding '.elc' file, +** The docstrings of preloaded files are not in "etc/DOC" any more. +Instead, they're fetched as needed from the corresponding ".elc" file, as was already the case for all the non-preloaded files. @@ -94,10 +94,10 @@ time. --- ** Support for old EIEIO functions is not autoloaded any more. -You need an explicit (require 'eieio-compat) to use 'defmethod' -and 'defgeneric' (which have been made obsolete in Emacs-25 with +You need an explicit '(require 'eieio-compat)' to use 'defmethod' +and 'defgeneric' (which have been made obsolete in Emacs 25.1 with 'cl-defmethod' and 'cl-defgeneric'). -Similarly you might need to (require 'eieio-compat) before loading +Similarly you might need to '(require 'eieio-compat)' before loading files that were compiled with an old EIEIO (Emacs<25). --- @@ -260,13 +260,13 @@ These will take you (respectively) to the next and previous "page". ** Outline Mode *** Support for customizing the default visibility state of headings. -Customize the option 'outline-default-state' to define what headings -will be visible after Outline mode is turned on. When equal to a -number, the option 'outline-default-rules' determines the visibility -of the subtree starting at the corresponding level. Values are -provided to control showing a heading subtree depending on whether the -heading matches a regexp, or on whether its subtree has long lines or -is itself too long. +Customize the user option 'outline-default-state' to define what +headings will be visible after Outline mode is turned on. When equal +to a number, the user option 'outline-default-rules' determines the +visibility of the subtree starting at the corresponding level. Values +are provided to control showing a heading subtree depending on whether +the heading matches a regexp, or on whether its subtree has long lines +or is itself too long. ** Outline Minor Mode @@ -414,15 +414,15 @@ received. ** Minibuffer and Completions -*** The *Completions* buffer can now be automatically selected. -To enable this behavior, customize the option 'completion-auto-select' -to t. Then pressing TAB will switch to the *Completions* buffer when -it pops up that buffer. +*** The "*Completions*" buffer can now be automatically selected. +To enable this behavior, customize the user option +'completion-auto-select' to t. Then pressing 'TAB' will switch to the +"*Completions*" buffer when it pops up that buffer. *** New user option 'completion-wrap-movement'. When non-nil, the commands 'next-completion' and 'previous-completion' automatically wrap around on reaching the beginning or the end of -the *Completions* buffer. +the "*Completions*" buffer. ** Isearch and Replace @@ -484,7 +484,7 @@ If non-nil, 'C-c C-a' will put attached files at the end of the message. --- *** Message Mode now supports image yanking. ---- ++++ *** New user option 'message-server-alist'. This controls automatic insertion of the "X-Message-SMTP-Method" header before sending a message. @@ -836,6 +836,12 @@ When calling 'abbreviate-file-name' on a Tramp filename, the result will abbreviate the user's home directory, for example by abbreviating "/ssh:user@host:/home/user" to "/ssh:user@host:~". ++++ +*** New user option 'tramp-use-scp-direct-remote-copying'. +When set to non-nil, Tramp does not copy files between two remote +hosts via a local copy in its temporary directory, but let the 'scp' +command do this job. + ** Browse URL --- @@ -991,7 +997,7 @@ read back by the Emacs Lisp reader. This variable allows changing how Emacs prints unreadable objects. --- -** The variable 'polling-period' now accepts floating point values. +** The user option 'polling-period' now accepts floating point values. This means Emacs can now poll for input during Lisp execution more frequently than once in a second. @@ -1039,7 +1045,7 @@ wheel on some mice, or when the user's finger moves off the touchpad. +++ ** New event type 'pinch'. -This event is sent when a user peforms a pinch gesture on a touchpad, +This event is sent when a user performs a pinch gesture on a touchpad, which is comprised of placing two fingers on the touchpad and moving them towards or away from each other. @@ -1199,14 +1205,14 @@ This can be used to check whether a specific font has a glyph for a character. +++ -** 'window-text-pixel-size' now accepts a new argument 'ignore-line-at-end'. +** 'window-text-pixel-size' now accepts a new argument IGNORE-LINE-AT-END. This controls whether or not the last screen line of the text being measured will be counted for the purpose of calculating the text dimensions. +++ -** 'window-text-pixel-size' understands a new meaning of 'from'. -Specifying a cons as the from argument allows to start measuring text +** 'window-text-pixel-size' understands a new meaning of FROM. +Specifying a cons as the FROM argument allows to start measuring text from a specified amount of pixels above or below a position. --- @@ -1383,9 +1389,9 @@ cookies set by web pages on disk. This variable is bound to t during the preparation of a "*Help*" buffer. +++ -** Timestamps like (1 . 1000) now work without warnings being generated. -For example, (time-add nil '(1 . 1000)) no longer warns that the -(1 . 1000) acts like (1000 . 1000000). This warning, which was a +** Timestamps like '(1 . 1000)' now work without warnings being generated. +For example, '(time-add nil '(1 . 1000))' no longer warns that the +'(1 . 1000)' acts like '(1000 . 1000000)'. This warning, which was a temporary transition aid for Emacs 27, has served its purpose. +++ diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index f0ceabe568..98192bd96d 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -38,6 +38,7 @@ (declare-function dired-compress-file "dired-aux") (declare-function dired-remove-file "dired-aux") (defvar dired-compress-file-suffixes) +;; Added in Emacs 28.1. (defvar process-file-return-signal-string) (defvar vc-handled-backends) (defvar vc-bzr-program) @@ -136,6 +137,12 @@ be auto-detected by Tramp. The string is used in `tramp-methods'.") +(defcustom tramp-use-scp-direct-remote-copying nil + "Whether to use direct copying between two remote hosts." + :group 'tramp + :version "29.1" + :type 'boolean) + ;; Initialize `tramp-methods' with the supported methods. ;;;###tramp-autoload (tramp--with-startup @@ -172,7 +179,7 @@ The string is used in `tramp-methods'.") (tramp-remote-shell-args ("-c")) (tramp-copy-program "scp") (tramp-copy-args (("-P" "%p") ("-p" "%k") - ("%x") ("-q") ("-r") ("%c"))) + ("%x") ("%y") ("-q") ("-r") ("%c"))) (tramp-copy-keep-date t) (tramp-copy-recursive t))) (add-to-list 'tramp-methods @@ -188,7 +195,7 @@ The string is used in `tramp-methods'.") (tramp-remote-shell-args ("-c")) (tramp-copy-program "scp") (tramp-copy-args (("-P" "%p") ("-p" "%k") - ("%x") ("-q") ("-r") ("%c"))) + ("%x") ("%y") ("-q") ("-r") ("%c"))) (tramp-copy-keep-date t) (tramp-copy-recursive t))) (add-to-list 'tramp-methods @@ -2240,200 +2247,210 @@ the uid and gid from FILENAME." (op filename newname ok-if-already-exists keep-date) "Invoke `scp' program to copy. The method used must be an out-of-band method." - (let* ((t1 (tramp-tramp-file-p filename)) - (t2 (tramp-tramp-file-p newname)) - (orig-vec (tramp-dissect-file-name (if t1 filename newname))) + (let* ((v1 (and (tramp-tramp-file-p filename) + (tramp-dissect-file-name filename))) + (v2 (and (tramp-tramp-file-p newname) + (tramp-dissect-file-name newname))) + (v (or v1 v2)) copy-program copy-args copy-env copy-keep-date listener spec options source target remote-copy-program remote-copy-args p) - (with-parsed-tramp-file-name (if t1 filename newname) nil - (if (and t1 t2) - - ;; Both are Tramp files. We shall optimize it when the - ;; methods for FILENAME and NEWNAME are the same. - (let* ((dir-flag (file-directory-p filename)) - (tmpfile (tramp-compat-make-temp-file localname dir-flag))) - (if dir-flag - (setq tmpfile - (expand-file-name - (file-name-nondirectory newname) tmpfile))) - (unwind-protect - (progn - (tramp-do-copy-or-rename-file-out-of-band - op filename tmpfile ok-if-already-exists keep-date) - (tramp-do-copy-or-rename-file-out-of-band - 'rename tmpfile newname ok-if-already-exists keep-date)) - ;; Save exit. - (ignore-errors - (if dir-flag - (delete-directory - (expand-file-name ".." tmpfile) 'recursive) - (delete-file tmpfile))))) - - ;; Check which ones of source and target are Tramp files. - (setq source (funcall - (if (and (string-equal method "rsync") - (file-directory-p filename) - (not (file-exists-p newname))) - #'file-name-as-directory - #'identity) - (if t1 - (tramp-make-copy-program-file-name v) - (tramp-compat-file-name-unquote filename))) - target (if t2 - (tramp-make-copy-program-file-name v) - (tramp-compat-file-name-unquote newname))) - - ;; Check for user. There might be an interactive setting. - (setq user (or (tramp-file-name-user v) - (tramp-get-connection-property v "login-as" nil))) - - ;; Check for listener port. - (when (tramp-get-method-parameter v 'tramp-remote-copy-args) - (setq listener (number-to-string (+ 50000 (random 10000)))) - (while - (zerop (tramp-call-process v "nc" nil nil nil "-z" host listener)) - (setq listener (number-to-string (+ 50000 (random 10000)))))) - - ;; Compose copy command. - (setq options - (format-spec - (tramp-ssh-controlmaster-options v) - (format-spec-make - ?t (tramp-get-connection-property - (tramp-get-connection-process v) "temp-file" ""))) - spec (list - ?h (or host "") ?u (or user "") ?p (or port "") - ?r listener ?c options ?k (if keep-date " " "") - ?n (concat "2>" (tramp-get-remote-null-device v)) - ?x (tramp-scp-strict-file-name-checking v)) - copy-program (tramp-get-method-parameter v 'tramp-copy-program) - copy-keep-date (tramp-get-method-parameter - v 'tramp-copy-keep-date) - copy-args - ;; " " has either been a replacement of "%k" (when - ;; keep-date argument is non-nil), or a replacement for - ;; the whole keep-date sublist. - (delete " " (apply #'tramp-expand-args v 'tramp-copy-args spec)) - ;; `tramp-ssh-controlmaster-options' is a string instead - ;; of a list. Unflatten it. - copy-args - (tramp-compat-flatten-tree - (mapcar - (lambda (x) (if (tramp-compat-string-search " " x) - (split-string x) x)) - copy-args)) - copy-env (apply #'tramp-expand-args v 'tramp-copy-env spec) - remote-copy-program - (tramp-get-method-parameter v 'tramp-remote-copy-program) - remote-copy-args - (apply #'tramp-expand-args v 'tramp-remote-copy-args spec)) - - ;; Check for local copy program. - (unless (executable-find copy-program) - (tramp-error - v 'file-error "Cannot find local copy program: %s" copy-program)) - - ;; Install listener on the remote side. The prompt must be - ;; consumed later on, when the process does not listen anymore. - (when remote-copy-program - (unless (with-tramp-connection-property - v (concat "remote-copy-program-" remote-copy-program) - (tramp-find-executable - v remote-copy-program (tramp-get-remote-path v))) - (tramp-error - v 'file-error - "Cannot find remote listener: %s" remote-copy-program)) - (setq remote-copy-program - (mapconcat - #'identity - (append - (list remote-copy-program) remote-copy-args - (list (if t1 (concat "<" source) (concat ">" target)) "&")) - " ")) - (tramp-send-command v remote-copy-program) - (with-timeout - (60 (tramp-error - v 'file-error - "Listener process not running on remote host: `%s'" - remote-copy-program)) - (tramp-send-command v (format "netstat -l | grep -q :%s" listener)) - (while (not (tramp-send-command-and-check v nil)) - (tramp-send-command - v (format "netstat -l | grep -q :%s" listener))))) + (if (and v1 v2 (zerop (length (tramp-scp-direct-remote-copying v1 v2)))) - (with-temp-buffer + ;; Both are Tramp files. We cannot use direct remote copying. + (let* ((dir-flag (file-directory-p filename)) + (tmpfile (tramp-compat-make-temp-file + (tramp-file-name-localname v1) dir-flag))) + (if dir-flag + (setq tmpfile + (expand-file-name + (file-name-nondirectory newname) tmpfile))) (unwind-protect - ;; The default directory must be remote. - (let ((default-directory - (file-name-directory (if t1 filename newname))) - (process-environment (copy-sequence process-environment))) - ;; Set the transfer process properties. - (tramp-set-connection-property - v "process-name" (buffer-name (current-buffer))) - (tramp-set-connection-property - v "process-buffer" (current-buffer)) - (when copy-env - (tramp-message - orig-vec 6 "%s=\"%s\"" - (car copy-env) (string-join (cdr copy-env) " ")) - (setenv (car copy-env) (string-join (cdr copy-env) " "))) - (setq - copy-args - (append - copy-args - (if remote-copy-program - (list (if t1 (concat ">" target) (concat "<" source))) - (list source target))) - ;; Use an asynchronous process. By this, password - ;; can be handled. We don't set a timeout, because - ;; the copying of large files can last longer than 60 - ;; secs. - p (let ((default-directory tramp-compat-temporary-file-directory)) - (apply - #'start-process - (tramp-get-connection-name v) - (tramp-get-connection-buffer v) - copy-program copy-args))) - (tramp-message orig-vec 6 "%s" (string-join (process-command p) " ")) - (process-put p 'vector orig-vec) - (process-put p 'adjust-window-size-function #'ignore) - (set-process-query-on-exit-flag p nil) + (progn + (tramp-do-copy-or-rename-file-out-of-band + op filename tmpfile ok-if-already-exists keep-date) + (tramp-do-copy-or-rename-file-out-of-band + 'rename tmpfile newname ok-if-already-exists keep-date)) + ;; Save exit. + (ignore-errors + (if dir-flag + (delete-directory + (expand-file-name ".." tmpfile) 'recursive) + (delete-file tmpfile))))) + + ;; Check which ones of source and target are Tramp files. + (setq source (funcall + (if (and (string-equal (tramp-file-name-method v) "rsync") + (file-directory-p filename) + (not (file-exists-p newname))) + #'file-name-as-directory + #'identity) + (if v1 + (tramp-make-copy-program-file-name v1) + (tramp-compat-file-name-unquote filename))) + target (if v2 + (tramp-make-copy-program-file-name v2) + (tramp-compat-file-name-unquote newname))) + + ;; Check for listener port. + (when (tramp-get-method-parameter v 'tramp-remote-copy-args) + (setq listener (number-to-string (+ 50000 (random 10000)))) + (while + (zerop (tramp-call-process + v "nc" nil nil nil "-z" (tramp-file-name-host v) listener)) + (setq listener (number-to-string (+ 50000 (random 10000)))))) + + ;; Compose copy command. + (setq options + (format-spec + (tramp-ssh-controlmaster-options v) + (format-spec-make + ?t (tramp-get-connection-property + (tramp-get-connection-process v) "temp-file" ""))) + spec (list + ;; "%h" and "%u" do not happen in `tramp-copy-args' + ;; of `scp', so it is save to use `v'. + ?h (or (tramp-file-name-host v) "") + ?u (or (tramp-file-name-user v) + ;; There might be an interactive setting. + (tramp-get-connection-property v "login-as" nil) + "") + ;; For direct remote copying, the port must be the + ;; same for source and target. + ?p (or (tramp-file-name-port v) "") + ?r listener ?c options ?k (if keep-date " " "") + ?n (concat "2>" (tramp-get-remote-null-device v)) + ?x (tramp-scp-strict-file-name-checking v) + ?y (tramp-scp-direct-remote-copying v1 v2)) + copy-program (tramp-get-method-parameter v 'tramp-copy-program) + copy-keep-date (tramp-get-method-parameter + v 'tramp-copy-keep-date) + copy-args + ;; " " has either been a replacement of "%k" (when + ;; keep-date argument is non-nil), or a replacement for + ;; the whole keep-date sublist. + (delete " " (apply #'tramp-expand-args v 'tramp-copy-args spec)) + ;; `tramp-ssh-controlmaster-options' is a string instead + ;; of a list. Unflatten it. + copy-args + (tramp-compat-flatten-tree + (mapcar + (lambda (x) (if (tramp-compat-string-search " " x) + (split-string x) x)) + copy-args)) + copy-env (apply #'tramp-expand-args v 'tramp-copy-env spec) + remote-copy-program + (tramp-get-method-parameter v 'tramp-remote-copy-program) + remote-copy-args + (apply #'tramp-expand-args v 'tramp-remote-copy-args spec)) + + ;; Check for local copy program. + (unless (executable-find copy-program) + (tramp-error + v 'file-error "Cannot find local copy program: %s" copy-program)) + + ;; Install listener on the remote side. The prompt must be + ;; consumed later on, when the process does not listen anymore. + (when remote-copy-program + (unless (with-tramp-connection-property + v (concat "remote-copy-program-" remote-copy-program) + (tramp-find-executable + v remote-copy-program (tramp-get-remote-path v))) + (tramp-error + v 'file-error + "Cannot find remote listener: %s" remote-copy-program)) + (setq remote-copy-program + (mapconcat + #'identity + (append + (list remote-copy-program) remote-copy-args + (list (if v1 (concat "<" source) (concat ">" target)) "&")) + " ")) + (tramp-send-command v remote-copy-program) + (with-timeout + (60 (tramp-error + v 'file-error + "Listener process not running on remote host: `%s'" + remote-copy-program)) + (tramp-send-command v (format "netstat -l | grep -q :%s" listener)) + (while (not (tramp-send-command-and-check v nil)) + (tramp-send-command + v (format "netstat -l | grep -q :%s" listener))))) + + (with-temp-buffer + (unwind-protect + ;; The default directory must be remote. + (let ((default-directory + (file-name-directory (if v1 filename newname))) + (process-environment (copy-sequence process-environment))) + ;; Set the transfer process properties. + (tramp-set-connection-property + v "process-name" (buffer-name (current-buffer))) + (tramp-set-connection-property + v "process-buffer" (current-buffer)) + (when copy-env + (tramp-message + v 6 "%s=\"%s\"" + (car copy-env) (string-join (cdr copy-env) " ")) + (setenv (car copy-env) (string-join (cdr copy-env) " "))) + (setq + copy-args + (append + copy-args + (if remote-copy-program + (list (if v1 (concat ">" target) (concat "<" source))) + (list source target))) + ;; Use an asynchronous process. By this, password can + ;; be handled. We don't set a timeout, because the + ;; copying of large files can last longer than 60 secs. + p (let ((default-directory + tramp-compat-temporary-file-directory)) + (apply + #'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + copy-program copy-args))) + (tramp-message v 6 "%s" (string-join (process-command p) " ")) + (process-put p 'vector v) + (process-put p 'adjust-window-size-function #'ignore) + (set-process-query-on-exit-flag p nil) + + ;; We must adapt `tramp-local-end-of-line' for sending + ;; the password. Also, we indicate that perhaps several + ;; password prompts might appear. + (let ((tramp-local-end-of-line tramp-rsh-end-of-line) + (tramp-password-prompt-not-unique (and v1 v2))) + (tramp-process-actions + p v nil tramp-actions-copy-out-of-band))) + + ;; Reset the transfer process properties. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") + ;; Clear the remote prompt. + (when (and remote-copy-program + (not (tramp-send-command-and-check v nil))) + ;; Houston, we have a problem! Likely, the listener is + ;; still running, so let's clear everything (but the + ;; cached password). + (tramp-cleanup-connection v 'keep-debug 'keep-password)))) + + ;; Handle KEEP-DATE argument. + (when (and keep-date (not copy-keep-date)) + (tramp-compat-set-file-times + newname + (file-attribute-modification-time (file-attributes filename)) + (unless ok-if-already-exists 'nofollow))) + + ;; Set the mode. + (unless (and keep-date copy-keep-date) + (ignore-errors + (set-file-modes newname (tramp-default-file-modes filename))))) - ;; We must adapt `tramp-local-end-of-line' for - ;; sending the password. - (let ((tramp-local-end-of-line tramp-rsh-end-of-line)) - (tramp-process-actions - p v nil tramp-actions-copy-out-of-band))) - - ;; Reset the transfer process properties. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer") - ;; Clear the remote prompt. - (when (and remote-copy-program - (not (tramp-send-command-and-check v nil))) - ;; Houston, we have a problem! Likely, the listener is - ;; still running, so let's clear everything (but the - ;; cached password). - (tramp-cleanup-connection v 'keep-debug 'keep-password)))) - - ;; Handle KEEP-DATE argument. - (when (and keep-date (not copy-keep-date)) - (tramp-compat-set-file-times - newname - (file-attribute-modification-time (file-attributes filename)) - (unless ok-if-already-exists 'nofollow))) - - ;; Set the mode. - (unless (and keep-date copy-keep-date) - (ignore-errors - (set-file-modes newname (tramp-default-file-modes filename))))) - - ;; If the operation was `rename', delete the original file. - (unless (eq op 'copy) - (if (file-regular-p filename) - (delete-file filename) - (delete-directory filename 'recursive)))))) + ;; If the operation was `rename', delete the original file. + (unless (eq op 'copy) + (if (file-regular-p filename) + (delete-file filename) + (delete-directory filename 'recursive))))) (defun tramp-sh-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." @@ -4806,7 +4823,7 @@ Goes through the list `tramp-inline-compress-commands'." ((stringp tramp-scp-strict-file-name-checking) tramp-scp-strict-file-name-checking) - ;; Determine the options. + ;; Determine the option. (t (setq tramp-scp-strict-file-name-checking "") (let ((case-fold-search t)) (ignore-errors @@ -4822,6 +4839,78 @@ Goes through the list `tramp-inline-compress-commands'." (setq tramp-scp-strict-file-name-checking "-T"))))))) tramp-scp-strict-file-name-checking))) +(defun tramp-scp-direct-remote-copying (vec1 vec2) + "Return the direct remote copying argument of the local scp." + (cond + ((or (not tramp-use-scp-direct-remote-copying) (null vec1) (null vec2) + (not (tramp-get-process vec1)) + (not (equal (tramp-file-name-port vec1) (tramp-file-name-port vec2))) + (null (assoc "%y" (tramp-get-method-parameter vec1 'tramp-copy-args))) + (null (assoc "%y" (tramp-get-method-parameter vec2 'tramp-copy-args)))) + "") + + ((let ((case-fold-search t)) + (and + ;; Check, whether "scp" supports "-R" option. + (with-tramp-connection-property nil "scp-R" + (when (executable-find "scp") + (with-temp-buffer + (tramp-call-process vec1 "scp" nil t nil "-R") + (goto-char (point-min)) + (not (search-forward-regexp + "\\(illegal\\|unknown\\) option -- R" nil 'noerror))))) + + ;; Check, that RemoteCommand is not used. + (with-tramp-connection-property (tramp-get-process vec1) "remote-command" + (let ((command `("ssh" "-G" ,(tramp-file-name-host vec1)))) + (with-temp-buffer + (tramp-call-process + vec1 tramp-encoding-shell nil t nil + tramp-encoding-command-switch + (mapconcat #'identity command " ")) + (goto-char (point-min)) + (not (search-forward "remotecommand" nil 'noerror))))) + + ;; Check hostkeys. + (with-tramp-connection-property + (tramp-get-process vec1) + (concat "direct-remote-copying-" + (tramp-make-tramp-file-name vec2 'noloc)) + (let ((command + (append + `("ssh" "-G" ,(tramp-file-name-host vec2) "|" + "grep" "-i" "^hostname" "|" "cut" "-d\" \"" "-f2" "|" + "ssh-keyscan" "-f" "-") + (when (tramp-file-name-port vec2) + `("-p" ,(tramp-file-name-port vec2))))) + found string) + (with-temp-buffer + ;; Check hostkey of VEC2, seen from VEC1. + (tramp-send-command vec1 (mapconcat #'identity command " ")) + ;; Check hostkey of VEC2, seen locally. + (tramp-call-process + vec1 tramp-encoding-shell nil t nil tramp-encoding-command-switch + (mapconcat #'identity command " ")) + (goto-char (point-min)) + (while (and (not found) (not (eobp))) + (setq string + (buffer-substring + (line-beginning-position) (line-end-position)) + string + (and + (string-match "^[^# ]+ \\S-+ \\(\\S-+\\)$" string) + (match-string 1 string)) + found + (and string + (with-current-buffer (tramp-get-buffer vec1) + (goto-char (point-min)) + (search-forward string nil 'noerror)))) + (forward-line)) + found))))) + "-R") + + (t "-3"))) + (defun tramp-timeout-session (vec) "Close the connection VEC after a session timeout. If there is just some editing, retry it after 5 seconds." @@ -5975,9 +6064,6 @@ function cell is returned to be applied on a buffer." ;; ;; * Use lsh instead of ssh. (Alfred M. Szmidt) ;; -;; * Optimize out-of-band copying when both methods are scp-like (not -;; rsync). -;; ;; * Keep a second connection open for out-of-band methods like scp or ;; rsync. ;; diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index b258121549..c6e55ff688 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -255,6 +255,8 @@ pair of the form (KEY VALUE). The following KEYs are defined: - \"%n\" expands to \"2>/dev/null\". - \"%x\" is replaced by the `tramp-scp-strict-file-name-checking' argument if it is supported. + - \"%y\" is replaced by the `tramp-scp-direct-remote-copying' + argument if it is supported. The existence of `tramp-login-args', combined with the absence of `tramp-copy-args', is an indication that the @@ -1387,6 +1389,11 @@ Will be called once the password has been verified by successful authentication.") (put 'tramp-password-save-function 'tramp-suppress-trace t) +(defvar tramp-password-prompt-not-unique nil + "Whether several passwords might be requested. +This shouldn't be set explicitly. It is let-bound, for example +during direct remote copying with scp.") + (defconst tramp-completion-file-name-handler-alist '((file-name-all-completions . tramp-completion-handle-file-name-all-completions) @@ -4751,7 +4758,9 @@ of." ;; Let's check whether a wrong password has been sent already. ;; Sometimes, the process returns a new password request ;; immediately after rejecting the previous (wrong) one. - (unless (tramp-get-connection-property vec "first-password-request" nil) + (unless (or tramp-password-prompt-not-unique + (tramp-get-connection-property + vec "first-password-request" nil)) (tramp-clear-passwd vec)) (goto-char (point-min)) (tramp-check-for-regexp proc tramp-process-action-regexp) @@ -4759,7 +4768,13 @@ of." ;; We don't call `tramp-send-string' in order to hide the ;; password from the debug buffer and the traces. (process-send-string - proc (concat (tramp-read-passwd proc) tramp-local-end-of-line)) + proc + (concat + (funcall + (if tramp-password-prompt-not-unique + #'tramp-read-passwd-without-cache #'tramp-read-passwd) + proc) + tramp-local-end-of-line)) ;; Hide password prompt. (narrow-to-region (point-max) (point-max)))) t) @@ -5705,8 +5720,7 @@ verbosity of 6." ;; tramp-cache-read-persistent-data t)'" instead. (defun tramp-read-passwd (proc &optional prompt) "Read a password from user (compat function). -Consults the auth-source package. -Invokes `password-read' if available, `read-passwd' else." +Consults the auth-source package." (let* (;; If `auth-sources' contains "~/.authinfo.gpg", and ;; `exec-path' contains a relative file name like ".", it ;; could happen that the "gpg" command is not found. So we @@ -5783,6 +5797,21 @@ Invokes `password-read' if available, `read-passwd' else." (put #'tramp-read-passwd 'tramp-suppress-trace t) +(defun tramp-read-passwd-without-cache (proc &optional prompt) + "Read a password from user (compat function)." + ;; We suspend the timers while reading the password. + (let ((stimers (with-timeout-suspend))) + (unwind-protect + (password-read + (or prompt + (with-current-buffer (process-buffer proc) + (tramp-check-for-regexp proc tramp-password-prompt-regexp) + (match-string 0)))) + ;; Reenable the timers. + (with-timeout-unsuspend stimers)))) + +(put #'tramp-read-passwd-without-cache 'tramp-suppress-trace t) + (defun tramp-clear-passwd (vec) "Clear password cache for connection related to VEC." (let ((method (tramp-file-name-method vec)) commit 1edde2fc7a1a82b0e65d2b7a4237e7c18d0bc0c1 Author: Lars Ingebrigtsen Date: Sat Jan 22 16:44:25 2022 +0100 Mark nil vc-follow-symlinks as safe * lisp/vc/vc-hooks.el (vc-follow-symlinks): A nil value should be safe for file-local (bug#33264). diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el index e71796b745..9c49e94781 100644 --- a/lisp/vc/vc-hooks.el +++ b/lisp/vc/vc-hooks.el @@ -143,6 +143,7 @@ visited and a warning displayed." (const :tag "Visit link and warn" nil) (const :tag "Follow link" t)) :group 'vc) +(put 'vc-follow-symlinks 'safe-local-variable #'null) (defcustom vc-display-status t "If non-nil, display revision number and lock status in mode line. commit 79e54a1b757dcc127e5dd82fb492227164cb78c6 Author: Lars Ingebrigtsen Date: Sat Jan 22 16:37:14 2022 +0100 Use load-read-function in byte-compile-from-buffer * lisp/emacs-lisp/bytecomp.el (byte-compile-from-buffer): Use load-read-function. * src/lread.c (syms_of_lread): Adjust doc string (bug#33723). diff --git a/etc/NEWS b/etc/NEWS index 95e53852ce..048f6d5598 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -872,6 +872,10 @@ Emacs buffers, like indentation and the like. The new ert function * Incompatible Lisp Changes in Emacs 29.1 +--- +** 'byte-compile-from-buffer' now uses 'load-read-function'. +It previously called 'read' directly. + ** User option 'mail-source-ignore-errors' is now obsolete. The whole mechanism for prompting users to continue in case of mail-source errors has been removed, so this option is no longer @@ -977,6 +981,7 @@ functions. * Lisp Changes in Emacs 29.1 ++++ ** New function 'readablep'. This function says whether an object can be written out and then read back by the Emacs Lisp reader. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 7dfe21441b..436783819f 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2294,7 +2294,7 @@ With argument ARG, insert value in current buffer after the form." (setq byte-compile-read-position (point) byte-compile-last-position byte-compile-read-position) (let* ((lread--unescaped-character-literals nil) - (form (read inbuffer)) + (form (funcall load-read-function inbuffer)) (warning (byte-run--unescaped-character-literals-warning))) (when warning (byte-compile-warn "%s" warning)) (byte-compile-toplevel-file-form form))) diff --git a/src/lread.c b/src/lread.c index 2eff20f15d..a0af98fa0f 100644 --- a/src/lread.c +++ b/src/lread.c @@ -5272,7 +5272,9 @@ of the file, regardless of whether or not it has the `.elc' extension. */); Vcurrent_load_list = Qnil; DEFVAR_LISP ("load-read-function", Vload_read_function, - doc: /* Function used by `load' and `eval-region' for reading expressions. + doc: /* Function used for reading expressions. +It is used by `load', `eval-region' and `byte-compile-from-buffer'. + Called with a single argument (the stream from which to read). The default is to use the function `read'. */); DEFSYM (Qread, "read"); commit 3b33a143806c9bc845ccb0fdc19b09f2a49afbe6 Author: Lars Ingebrigtsen Date: Sat Jan 22 16:24:42 2022 +0100 Clarify Vprint_unreadable_function doc string * src/print.c (syms_of_print): Clarify Vprint_unreadable_function doc string diff --git a/src/print.c b/src/print.c index e9a83d6d5d..7440a82f6f 100644 --- a/src/print.c +++ b/src/print.c @@ -2501,14 +2501,14 @@ priorities. Values other than nil or t are also treated as doc: /* If non-nil, a function to call when printing unreadable objects. By default, Emacs printing functions (like `prin1') print unreadable objects as \"#<...>\", where \"...\" describes the object (for -instance, \"#\"). If this variable is non-nil, -it should be a function which will be called to print the object instead. - -The function will be called with two arguments: the object to be printed, and -the NOESCAPE flag (see `prin1-to-string'). If this function returns nil, the -object will be printed as usual. If it returns a string, that string -will then be printed. If the function returns anything else, the -object will not be printed. */); +instance, \"#\"). + +If non-nil, it should be a function that will be called with two +arguments: the object to be printed, and the NOESCAPE flag (see +`prin1-to-string'). If this function returns nil, the object will be +printed as usual. If it returns a string, that string will then be +printed. If the function returns anything else, the object will not +be printed. */); Vprint_unreadable_function = Qnil; DEFSYM (Qprint_unreadable_function, "print-unreadable-function"); } commit 71b433f0358807dca722c5b0b178d108b9d13436 Author: Eli Zaretskii Date: Sat Jan 22 16:49:06 2022 +0200 Fix documentation of 'unprintable' stuff * src/print.c (syms_of_print) : * doc/lispref/streams.texi (Input Functions, Output Variables): Improve the documentation of 'print-unreadable-function' and 'readablep'. Add indexing and cross-references. diff --git a/doc/lispref/streams.texi b/doc/lispref/streams.texi index b93a7610fa..784adb9bd5 100644 --- a/doc/lispref/streams.texi +++ b/doc/lispref/streams.texi @@ -359,10 +359,12 @@ non-@code{nil} value and does nothing except flushing pending output. @end defun @defun readablep object -This predicate says whether @var{object} can be written out and then -read back by the Emacs Lisp reader. If it can't, this function -returns @code{nil}, and if it can, a printed representation (via -@code{prin1}) of @var{object} is returned. +@cindex readable syntax +This predicate says whether @var{object} has @dfn{readable syntax}, +i.e., it can be written out and then read back by the Emacs Lisp +reader. If it can't, this function returns @code{nil}; if it can, +this function returns a printed representation (via @code{prin1}, +@pxref{Output Functions}) of @var{object}. @end defun @node Output Streams @@ -889,8 +891,8 @@ instance: @end example If this variable is non-@code{nil}, it should be a function that will -be called to handle printing of these objects. The first argument is -the object, and the second argument is the @var{noescape} flag used by +be called to handle printing of these objects. The function will be +called with two arguments: the object and the @var{noescape} flag used by the printing functions (@pxref{Output Functions}). The function should return either @code{nil} (print nothing), or a diff --git a/src/print.c b/src/print.c index 4d9feb55ac..e9a83d6d5d 100644 --- a/src/print.c +++ b/src/print.c @@ -2498,15 +2498,15 @@ priorities. Values other than nil or t are also treated as staticpro (&print_prune_charset_plist); DEFVAR_LISP ("print-unreadable-function", Vprint_unreadable_function, - doc: /* Function called when printing unreadable objects. + doc: /* If non-nil, a function to call when printing unreadable objects. By default, Emacs printing functions (like `prin1') print unreadable -objects like \"#<...>\", where \"...\" describes the object (for +objects as \"#<...>\", where \"...\" describes the object (for instance, \"#\"). If this variable is non-nil, it should be a function which will be called to print the object instead. -It will be called with two arguments: The object to be printed, and -noescape (see `prin1-to-string'). If this function returns nil, the -object will be printed as normal. If it returns a string, that string +The function will be called with two arguments: the object to be printed, and +the NOESCAPE flag (see `prin1-to-string'). If this function returns nil, the +object will be printed as usual. If it returns a string, that string will then be printed. If the function returns anything else, the object will not be printed. */); Vprint_unreadable_function = Qnil; commit 41846901e22e824f02796012164c51df0297c6ec Author: Lars Ingebrigtsen Date: Sat Jan 22 15:42:59 2022 +0100 Improve dired-do-create-files slightly * lisp/dired-aux.el (dired-do-create-files): Expand slightly upon the doc string (bug#35367). Suggested by Mike Kupfer . diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 637f8695f3..41c45b4e51 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -2145,18 +2145,23 @@ Prompt user for a target directory in which to create the new one file is marked. The initial suggestion for target is the Dired buffer's current directory (or, if `dired-dwim-target' is non-nil, the current directory of a neighboring Dired window). + OP-SYMBOL is the symbol for the operation. Function `dired-mark-pop-up' will determine whether pop-ups are appropriate for this OP-SYMBOL. + FILE-CREATOR and OPERATION as in `dired-create-files'. + ARG as in `dired-get-marked-files'. + Optional arg MARKER-CHAR as in `dired-create-files'. + Optional arg OP1 is an alternate form for OPERATION if there is only one file. + Optional arg HOW-TO determines how to treat the target. If HOW-TO is nil, use `file-directory-p' to determine if the target is a directory. If so, the marked file(s) are created - inside that directory. Otherwise, the target is a plain file; - an error is raised unless there is exactly one marked file. + inside that directory. If HOW-TO is t, target is always treated as a plain file. Otherwise, HOW-TO should be a function of one argument, TARGET. If its return value is nil, TARGET is regarded as a plain file. @@ -2169,6 +2174,11 @@ Optional arg HOW-TO determines how to treat the target. target - the name of the target itself. The rest of elements of the list returned by HOW-TO are optional arguments for the function that is the first element of the list. + + This can be useful because by default, copying a single file + would replace the tar file. But this could be overridden to + add or replace entries in the tar file. + For any other return value, TARGET is treated as a directory." (or op1 (setq op1 operation)) (let* ((fn-list (dired-get-marked-files nil arg nil nil t)) @@ -2417,7 +2427,7 @@ If FILE already exists, signal an error." (defvar dired-copy-how-to-fn nil "Either nil or a function used by `dired-do-copy' to determine target. -See HOW-TO argument for `dired-do-create-files'.") +See HOW-TO argument for `dired-do-create-files' for an explanation.") ;;;###autoload (defun dired-do-copy (&optional arg) commit 573ec193be37dbac105c1047c6d52deaa388ac66 Author: Lars Ingebrigtsen Date: Sat Jan 22 15:13:19 2022 +0100 Speed up multisession--set-value-sqlite slightly * lisp/emacs-lisp/multisession.el (multisession--set-value-sqlite): Use `readablep'. diff --git a/lisp/emacs-lisp/multisession.el b/lisp/emacs-lisp/multisession.el index 25307594c6..d6f1ab98fa 100644 --- a/lisp/emacs-lisp/multisession.el +++ b/lisp/emacs-lisp/multisession.el @@ -218,10 +218,9 @@ DOC should be a doc string, and ARGS are keywords as applicable to (let ((print-length nil) (print-circle t) (print-level nil)) - (prin1-to-string value)))) - (condition-case nil - (ignore (read-from-string pvalue)) - (error (error "Unable to store unreadable value: %s" pvalue))) + (readablep value)))) + (when (and value (not pvalue)) + (error "Unable to store unreadable value: %s" value)) (sqlite-execute multisession--db "insert into multisession(package, key, sequence, value) values(?, ?, 1, ?) on conflict(package, key) do update set sequence = sequence + 1, value = ?" commit f047d3c5137e75ea22713e1e7a6f715e6544299a Author: Lars Ingebrigtsen Date: Sat Jan 22 15:11:17 2022 +0100 Add new function 'readablep' * doc/lispref/streams.texi (Input Functions): Document it. * lisp/subr.el (readablep): New function (bug#52566). diff --git a/doc/lispref/streams.texi b/doc/lispref/streams.texi index 5ab6cf5777..b93a7610fa 100644 --- a/doc/lispref/streams.texi +++ b/doc/lispref/streams.texi @@ -358,6 +358,13 @@ mode for @var{stream}. On POSIX hosts, it always returns a non-@code{nil} value and does nothing except flushing pending output. @end defun +@defun readablep object +This predicate says whether @var{object} can be written out and then +read back by the Emacs Lisp reader. If it can't, this function +returns @code{nil}, and if it can, a printed representation (via +@code{prin1}) of @var{object} is returned. +@end defun + @node Output Streams @section Output Streams @cindex stream (for printing) diff --git a/etc/NEWS b/etc/NEWS index 02e7a462a1..95e53852ce 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -977,6 +977,10 @@ functions. * Lisp Changes in Emacs 29.1 +** New function 'readablep'. +This function says whether an object can be written out and then +read back by the Emacs Lisp reader. + +++ ** New variable 'print-unreadable-function'. This variable allows changing how Emacs prints unreadable objects. diff --git a/lisp/subr.el b/lisp/subr.el index 81c0233853..29b9b6dfcf 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -6561,4 +6561,17 @@ signalled. If NOERROR, the non-loop parts of the chain is returned." (push func chain)) chain)))) +(defun readablep (object) + "Say whether OBJECT has a readable syntax. +This means that OBJECT can be printed out and then read back +again by the Lisp reader. This function returns nil if OBJECT is +unreadable, and the printed representation (from `prin1') of +OBJECT if it is readable." + (declare (side-effect-free t)) + (catch 'unreadable + (let ((print-unreadable-function + (lambda (_object _escape) + (throw 'unreadable nil)))) + (prin1-to-string object)))) + ;;; subr.el ends here diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 512b654535..e027c68d0b 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -1024,5 +1024,9 @@ final or penultimate step during initialization.")) (should (equal (function-alias-p 'subr-tests--d t) '(subr-tests--e)))) +(ert-deftest test-readablep () + (should (readablep "foo")) + (should-not (readablep (list (make-marker))))) + (provide 'subr-tests) ;;; subr-tests.el ends here commit e4d2a7894b4294a31a4311fa81a3644ea06028e5 Author: Lars Ingebrigtsen Date: Sat Jan 22 15:06:33 2022 +0100 Add new variable print-unreadable-function * doc/lispref/streams.texi (Output Variables): Document it. * src/print.c (print_vectorlike): Use the variable. (syms_of_print): New variable print-unreadable-function (bug#52566). diff --git a/doc/lispref/streams.texi b/doc/lispref/streams.texi index c6b3397ae1..5ab6cf5777 100644 --- a/doc/lispref/streams.texi +++ b/doc/lispref/streams.texi @@ -872,6 +872,32 @@ If non-@code{nil}, this variable enables detection of circular and shared structure in printing. @xref{Circular Objects}. @end defvar +@defvar print-unreadable-function +By default, Emacs prints unreadable objects as @samp{#<...>"}. For +instance: + +@example +(prin1-to-string (make-marker)) + @result{} "#" +@end example + +If this variable is non-@code{nil}, it should be a function that will +be called to handle printing of these objects. The first argument is +the object, and the second argument is the @var{noescape} flag used by +the printing functions (@pxref{Output Functions}). + +The function should return either @code{nil} (print nothing), or a +string (which will be printed), or any other object (which means that +the object should be printed normally). For instance: + +@example +(let ((print-unreadable-function + (lambda (object escape) "hello"))) + (prin1-to-string (make-marker))) + @result{} "hello" +@end example +@end defvar + @defvar print-gensym If non-@code{nil}, this variable enables detection of uninterned symbols (@pxref{Creating Symbols}) in printing. When this is enabled, diff --git a/etc/NEWS b/etc/NEWS index 87b009d5e2..02e7a462a1 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -977,12 +977,16 @@ functions. * Lisp Changes in Emacs 29.1 --- ++++ +** New variable 'print-unreadable-function'. +This variable allows changing how Emacs prints unreadable objects. + +--- ** The variable 'polling-period' now accepts floating point values. This means Emacs can now poll for input during Lisp execution more frequently than once in a second. --- +--- ** New function 'bidi-string-strip-control-characters'. This utility function is meant for displaying strings when it's essential that there's no bidirectional context. diff --git a/src/print.c b/src/print.c index a3c9011215..4d9feb55ac 100644 --- a/src/print.c +++ b/src/print.c @@ -1387,6 +1387,7 @@ static bool print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, char *buf) { + /* First do all the vectorlike types that have a readable syntax. */ switch (PSEUDOVECTOR_TYPE (XVECTOR (obj))) { case PVEC_BIGNUM: @@ -1398,8 +1399,240 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, strout (str, len, len, printcharfun); SAFE_FREE (); } + return true; + + case PVEC_BOOL_VECTOR: + { + EMACS_INT size = bool_vector_size (obj); + ptrdiff_t size_in_bytes = bool_vector_bytes (size); + ptrdiff_t real_size_in_bytes = size_in_bytes; + unsigned char *data = bool_vector_uchar_data (obj); + + int len = sprintf (buf, "#&%"pI"d\"", size); + strout (buf, len, len, printcharfun); + + /* Don't print more bytes than the specified maximum. + Negative values of print-length are invalid. Treat them + like a print-length of nil. */ + if (FIXNATP (Vprint_length) + && XFIXNAT (Vprint_length) < size_in_bytes) + size_in_bytes = XFIXNAT (Vprint_length); + + for (ptrdiff_t i = 0; i < size_in_bytes; i++) + { + maybe_quit (); + unsigned char c = data[i]; + if (c == '\n' && print_escape_newlines) + print_c_string ("\\n", printcharfun); + else if (c == '\f' && print_escape_newlines) + print_c_string ("\\f", printcharfun); + else if (c > '\177' + || (print_escape_control_characters && c_iscntrl (c))) + { + /* Use octal escapes to avoid encoding issues. */ + octalout (c, data, i + 1, size_in_bytes, printcharfun); + } + else + { + if (c == '\"' || c == '\\') + printchar ('\\', printcharfun); + printchar (c, printcharfun); + } + } + + if (size_in_bytes < real_size_in_bytes) + print_c_string (" ...", printcharfun); + printchar ('\"', printcharfun); + } + return true; + + case PVEC_HASH_TABLE: + { + struct Lisp_Hash_Table *h = XHASH_TABLE (obj); + /* Implement a readable output, e.g.: + #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */ + /* Always print the size. */ + int len = sprintf (buf, "#s(hash-table size %"pD"d", + HASH_TABLE_SIZE (h)); + strout (buf, len, len, printcharfun); + + if (!NILP (h->test.name)) + { + print_c_string (" test ", printcharfun); + print_object (h->test.name, printcharfun, escapeflag); + } + + if (!NILP (h->weak)) + { + print_c_string (" weakness ", printcharfun); + print_object (h->weak, printcharfun, escapeflag); + } + + print_c_string (" rehash-size ", printcharfun); + print_object (Fhash_table_rehash_size (obj), + printcharfun, escapeflag); + + print_c_string (" rehash-threshold ", printcharfun); + print_object (Fhash_table_rehash_threshold (obj), + printcharfun, escapeflag); + + if (h->purecopy) + { + print_c_string (" purecopy ", printcharfun); + print_object (h->purecopy ? Qt : Qnil, printcharfun, escapeflag); + } + + print_c_string (" data ", printcharfun); + + /* Print the data here as a plist. */ + ptrdiff_t real_size = HASH_TABLE_SIZE (h); + ptrdiff_t size = h->count; + + /* Don't print more elements than the specified maximum. */ + if (FIXNATP (Vprint_length) && XFIXNAT (Vprint_length) < size) + size = XFIXNAT (Vprint_length); + + printchar ('(', printcharfun); + ptrdiff_t j = 0; + for (ptrdiff_t i = 0; i < real_size; i++) + { + Lisp_Object key = HASH_KEY (h, i); + if (!EQ (key, Qunbound)) + { + if (j++) printchar (' ', printcharfun); + print_object (key, printcharfun, escapeflag); + printchar (' ', printcharfun); + print_object (HASH_VALUE (h, i), printcharfun, escapeflag); + if (j == size) + break; + } + } + + if (j < h->count) + { + if (j) + printchar (' ', printcharfun); + print_c_string ("...", printcharfun); + } + + print_c_string ("))", printcharfun); + } + return true; + + case PVEC_RECORD: + { + ptrdiff_t size = PVSIZE (obj); + + /* Don't print more elements than the specified maximum. */ + ptrdiff_t n + = (FIXNATP (Vprint_length) && XFIXNAT (Vprint_length) < size + ? XFIXNAT (Vprint_length) : size); + + print_c_string ("#s(", printcharfun); + for (ptrdiff_t 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); + } + return true; + + case PVEC_SUB_CHAR_TABLE: + case PVEC_COMPILED: + case PVEC_CHAR_TABLE: + case PVEC_NORMAL_VECTOR: + { + ptrdiff_t size = ASIZE (obj); + if (COMPILEDP (obj)) + { + printchar ('#', printcharfun); + size &= PSEUDOVECTOR_SIZE_MASK; + } + if (CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj)) + { + /* Print a char-table as if it were a vector, + lumping the parent and default slots in with the + character slots. But add #^ as a prefix. */ + + /* Make each lowest sub_char_table start a new line. + Otherwise we'll make a line extremely long, which + results in slow redisplay. */ + if (SUB_CHAR_TABLE_P (obj) + && XSUB_CHAR_TABLE (obj)->depth == 3) + printchar ('\n', printcharfun); + print_c_string ("#^", printcharfun); + if (SUB_CHAR_TABLE_P (obj)) + printchar ('^', printcharfun); + size &= PSEUDOVECTOR_SIZE_MASK; + } + if (size & PSEUDOVECTOR_FLAG) + return false; + + printchar ('[', printcharfun); + + int idx = SUB_CHAR_TABLE_P (obj) ? SUB_CHAR_TABLE_OFFSET : 0; + Lisp_Object tem; + ptrdiff_t real_size = size; + + /* For a sub char-table, print heading non-Lisp data first. */ + if (SUB_CHAR_TABLE_P (obj)) + { + int i = sprintf (buf, "%d %d", XSUB_CHAR_TABLE (obj)->depth, + XSUB_CHAR_TABLE (obj)->min_char); + strout (buf, i, i, printcharfun); + } + + /* Don't print more elements than the specified maximum. */ + if (FIXNATP (Vprint_length) + && XFIXNAT (Vprint_length) < size) + size = XFIXNAT (Vprint_length); + + for (int i = idx; i < size; i++) + { + if (i) printchar (' ', printcharfun); + tem = AREF (obj, i); + print_object (tem, printcharfun, escapeflag); + } + if (size < real_size) + print_c_string (" ...", printcharfun); + printchar (']', printcharfun); + } + return true; + + default: break; + } + + /* Then do all the pseudovector types that don't have a readable + syntax. First check whether this is handled by + `print-unreadable-function'. */ + if (!NILP (Vprint_unreadable_function) + && FUNCTIONP (Vprint_unreadable_function)) + { + ptrdiff_t count = SPECPDL_INDEX (); + /* Bind `print-unreadable-function' to nil to avoid accidental + infinite recursion in the function called. */ + Lisp_Object func = Vprint_unreadable_function; + specbind (Qprint_unreadable_function, Qnil); + Lisp_Object result = CALLN (Ffuncall, func, obj, + escapeflag? Qt: Qnil); + unbind_to (count, Qnil); + + if (!NILP (result)) + { + if (STRINGP (result)) + print_string (result, printcharfun); + /* It's handled, so stop processing here. */ + return true; + } + } + /* Not handled; print unreadable object. */ + switch (PSEUDOVECTOR_TYPE (XVECTOR (obj))) + { case PVEC_MARKER: print_c_string ("#name, printcharfun); break; - case PVEC_BOOL_VECTOR: - { - EMACS_INT size = bool_vector_size (obj); - ptrdiff_t size_in_bytes = bool_vector_bytes (size); - ptrdiff_t real_size_in_bytes = size_in_bytes; - unsigned char *data = bool_vector_uchar_data (obj); - - int len = sprintf (buf, "#&%"pI"d\"", size); - strout (buf, len, len, printcharfun); - - /* Don't print more bytes than the specified maximum. - Negative values of print-length are invalid. Treat them - like a print-length of nil. */ - if (FIXNATP (Vprint_length) - && XFIXNAT (Vprint_length) < size_in_bytes) - size_in_bytes = XFIXNAT (Vprint_length); - - for (ptrdiff_t i = 0; i < size_in_bytes; i++) - { - maybe_quit (); - unsigned char c = data[i]; - if (c == '\n' && print_escape_newlines) - print_c_string ("\\n", printcharfun); - else if (c == '\f' && print_escape_newlines) - print_c_string ("\\f", printcharfun); - else if (c > '\177' - || (print_escape_control_characters && c_iscntrl (c))) - { - /* Use octal escapes to avoid encoding issues. */ - octalout (c, data, i + 1, size_in_bytes, printcharfun); - } - else - { - if (c == '\"' || c == '\\') - printchar ('\\', printcharfun); - printchar (c, printcharfun); - } - } - - if (size_in_bytes < real_size_in_bytes) - print_c_string (" ...", printcharfun); - printchar ('\"', printcharfun); - } - break; - case PVEC_SUBR: print_c_string ("#symbol_name, printcharfun); @@ -1578,79 +1766,6 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, } break; - case PVEC_HASH_TABLE: - { - struct Lisp_Hash_Table *h = XHASH_TABLE (obj); - /* Implement a readable output, e.g.: - #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */ - /* Always print the size. */ - int len = sprintf (buf, "#s(hash-table size %"pD"d", - HASH_TABLE_SIZE (h)); - strout (buf, len, len, printcharfun); - - if (!NILP (h->test.name)) - { - print_c_string (" test ", printcharfun); - print_object (h->test.name, printcharfun, escapeflag); - } - - if (!NILP (h->weak)) - { - print_c_string (" weakness ", printcharfun); - print_object (h->weak, printcharfun, escapeflag); - } - - print_c_string (" rehash-size ", printcharfun); - print_object (Fhash_table_rehash_size (obj), - printcharfun, escapeflag); - - print_c_string (" rehash-threshold ", printcharfun); - print_object (Fhash_table_rehash_threshold (obj), - printcharfun, escapeflag); - - if (h->purecopy) - { - print_c_string (" purecopy ", printcharfun); - print_object (h->purecopy ? Qt : Qnil, printcharfun, escapeflag); - } - - print_c_string (" data ", printcharfun); - - /* Print the data here as a plist. */ - ptrdiff_t real_size = HASH_TABLE_SIZE (h); - ptrdiff_t size = h->count; - - /* Don't print more elements than the specified maximum. */ - if (FIXNATP (Vprint_length) && XFIXNAT (Vprint_length) < size) - size = XFIXNAT (Vprint_length); - - printchar ('(', printcharfun); - ptrdiff_t j = 0; - for (ptrdiff_t i = 0; i < real_size; i++) - { - Lisp_Object key = HASH_KEY (h, i); - if (!EQ (key, Qunbound)) - { - if (j++) printchar (' ', printcharfun); - print_object (key, printcharfun, escapeflag); - printchar (' ', printcharfun); - print_object (HASH_VALUE (h, i), printcharfun, escapeflag); - if (j == size) - break; - } - } - - if (j < h->count) - { - if (j) - printchar (' ', printcharfun); - print_c_string ("...", printcharfun); - } - - print_c_string ("))", printcharfun); - } - break; - case PVEC_BUFFER: if (!BUFFER_LIVE_P (XBUFFER (obj))) print_c_string ("#", printcharfun); @@ -1756,89 +1871,6 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, printchar ('>', printcharfun); break; - case PVEC_RECORD: - { - ptrdiff_t size = PVSIZE (obj); - - /* Don't print more elements than the specified maximum. */ - ptrdiff_t n - = (FIXNATP (Vprint_length) && XFIXNAT (Vprint_length) < size - ? XFIXNAT (Vprint_length) : size); - - print_c_string ("#s(", printcharfun); - for (ptrdiff_t 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: - case PVEC_NORMAL_VECTOR: - { - ptrdiff_t size = ASIZE (obj); - if (COMPILEDP (obj)) - { - printchar ('#', printcharfun); - size &= PSEUDOVECTOR_SIZE_MASK; - } - if (CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj)) - { - /* Print a char-table as if it were a vector, - lumping the parent and default slots in with the - character slots. But add #^ as a prefix. */ - - /* Make each lowest sub_char_table start a new line. - Otherwise we'll make a line extremely long, which - results in slow redisplay. */ - if (SUB_CHAR_TABLE_P (obj) - && XSUB_CHAR_TABLE (obj)->depth == 3) - printchar ('\n', printcharfun); - print_c_string ("#^", printcharfun); - if (SUB_CHAR_TABLE_P (obj)) - printchar ('^', printcharfun); - size &= PSEUDOVECTOR_SIZE_MASK; - } - if (size & PSEUDOVECTOR_FLAG) - return false; - - printchar ('[', printcharfun); - - int idx = SUB_CHAR_TABLE_P (obj) ? SUB_CHAR_TABLE_OFFSET : 0; - Lisp_Object tem; - ptrdiff_t real_size = size; - - /* For a sub char-table, print heading non-Lisp data first. */ - if (SUB_CHAR_TABLE_P (obj)) - { - int i = sprintf (buf, "%d %d", XSUB_CHAR_TABLE (obj)->depth, - XSUB_CHAR_TABLE (obj)->min_char); - strout (buf, i, i, printcharfun); - } - - /* Don't print more elements than the specified maximum. */ - if (FIXNATP (Vprint_length) - && XFIXNAT (Vprint_length) < size) - size = XFIXNAT (Vprint_length); - - for (int i = idx; i < size; i++) - { - if (i) printchar (' ', printcharfun); - tem = AREF (obj, i); - print_object (tem, printcharfun, escapeflag); - } - if (size < real_size) - print_c_string (" ...", printcharfun); - printchar (']', printcharfun); - } - break; - #ifdef HAVE_MODULES case PVEC_MODULE_FUNCTION: { @@ -2464,4 +2496,19 @@ priorities. Values other than nil or t are also treated as print_prune_charset_plist = Qnil; staticpro (&print_prune_charset_plist); + + DEFVAR_LISP ("print-unreadable-function", Vprint_unreadable_function, + doc: /* Function called when printing unreadable objects. +By default, Emacs printing functions (like `prin1') print unreadable +objects like \"#<...>\", where \"...\" describes the object (for +instance, \"#\"). If this variable is non-nil, +it should be a function which will be called to print the object instead. + +It will be called with two arguments: The object to be printed, and +noescape (see `prin1-to-string'). If this function returns nil, the +object will be printed as normal. If it returns a string, that string +will then be printed. If the function returns anything else, the +object will not be printed. */); + Vprint_unreadable_function = Qnil; + DEFSYM (Qprint_unreadable_function, "print-unreadable-function"); } diff --git a/test/src/print-tests.el b/test/src/print-tests.el index 4c7b339e0c..1ef0caf1a4 100644 --- a/test/src/print-tests.el +++ b/test/src/print-tests.el @@ -406,5 +406,16 @@ otherwise, use a different charset." (should (equal printed-nonprints "(55296 57343 778 65535 8194 8204)")))) +(ert-deftest test-unreadable () + (should (equal (prin1-to-string (make-marker)) "#")) + (let ((print-unreadable-function + (lambda (_object _escape) + "hello"))) + (should (equal (prin1-to-string (make-marker)) "hello"))) + (let ((print-unreadable-function + (lambda (_object _escape) + t))) + (should (equal (prin1-to-string (make-marker)) "")))) + (provide 'print-tests) ;;; print-tests.el ends here commit 7e596463bedafbb33461aa83075bc6a8a97f8faa Author: Po Lu Date: Sat Jan 22 21:51:46 2022 +0800 Add some menu bar help code on GNUstep * src/nsmenu.m ([EmacsMenu menu:willHighlightItem:]): Implement help event generation for GNUstep. diff --git a/src/nsmenu.m b/src/nsmenu.m index cad0ff6fe1..5df391bcbe 100644 --- a/src/nsmenu.m +++ b/src/nsmenu.m @@ -758,6 +758,32 @@ - (Lisp_Object)runMenuAt: (NSPoint)p forFrame: (struct frame *)f : Qnil; } +#ifdef NS_IMPL_GNUSTEP +/* The code below doesn't work on Mac OS X, because it runs a nested + Carbon-related event loop to track menu bar movement. + + But it works fine aside from that, so it will work on GNUstep if + they start to call `willHighlightItem'. */ +- (void) menu: (NSMenu *) menu willHighlightItem: (NSMenuItem *) item +{ + NSInteger idx = [item tag]; + struct frame *f = SELECTED_FRAME (); + Lisp_Object vec = f->menu_bar_vector; + Lisp_Object help, frame; + + if (idx >= ASIZE (vec)) + return; + + XSETFRAME (frame, f); + help = AREF (vec, idx + MENU_ITEMS_ITEM_HELP); + + if (STRINGP (help) || NILP (help)) + kbd_buffer_store_help_event (frame, help); + + raise (SIGIO); +} +#endif + #ifdef NS_IMPL_GNUSTEP - (void) close { @@ -809,10 +835,6 @@ - (NSRect)confinementRectForMenu:(NSMenu *)menu { return NSZeroRect; } - -- (void)menu:(NSMenu *)menu willHighlightItem:(NSMenuItem *)item -{ -} #endif @end /* EmacsMenu */ commit 15090d7c6fa54cc6598fa02b43404181be826e0b Author: Po Lu Date: Sat Jan 22 20:28:22 2022 +0800 Fix PGTK build with xwidgets * src/xwidget.c: Swap some preprocessor definitions around. Reported by Iñigo Serna . diff --git a/src/xwidget.c b/src/xwidget.c index fb66a17acd..822bed0349 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -39,8 +39,8 @@ along with GNU Emacs. If not, see . */ #include #include #include -#include #ifndef HAVE_PGTK +#include #include #else #include commit 82f818344e2525d3470266894674188fcb3c2fb5 Author: Po Lu Date: Sat Jan 22 20:22:30 2022 +0800 Fix GNUstep build warnings * src/nsmenu.m ([EmacsMenu menu:updateItem:atIndex:shouldCancel:]) ([EmacsMenu menuHasKeyEquivalent:forEvent:target:action:]) ([EmacsMenu numberOfItemsInMenu:]): New methods. diff --git a/src/nsmenu.m b/src/nsmenu.m index 4d3c752816..cad0ff6fe1 100644 --- a/src/nsmenu.m +++ b/src/nsmenu.m @@ -777,6 +777,25 @@ - (void) close /* GNUstep seems to have a number of required methods in NSMenuDelegate that are optional in Cocoa. */ +- (BOOL) menu: (NSMenu*) menu updateItem: (NSMenuItem*) item + atIndex: (NSInteger) index shouldCancel: (BOOL) shouldCancel +{ + return YES; +} + +- (BOOL) menuHasKeyEquivalent: (NSMenu*) menu + forEvent: (NSEvent*) event + target: (id*) target + action: (SEL*) action +{ + return NO; +} + +- (NSInteger) numberOfItemsInMenu: (NSMenu*) menu +{ + return [super numberOfItemsInMenu: menu]; +} + - (void) menuWillOpen:(NSMenu *)menu { } commit a0e6e67ac16b1d73e50b2af014a8319e2afe76a2 Author: Lars Ingebrigtsen Date: Sat Jan 22 13:14:36 2022 +0100 Fix HTML target marking in shr * lisp/net/shr.el (shr-descend): Use a marker (because we may be altering the text later for indentation), and mark the start, not the end of the tag (bug#53409). (shr-tag-a): Ditto. diff --git a/lisp/net/shr.el b/lisp/net/shr.el index ff14acfda7..6e0af06bed 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -630,7 +630,7 @@ size, and full-buffer size." (t (shr-generic dom))) (when-let ((id (dom-attr dom 'id))) - (push (cons id (point)) shr--link-targets)) + (push (cons id (set-marker (make-marker) start)) shr--link-targets)) ;; If style is set, then this node has set the color. (when style (shr-colorize-region @@ -1465,7 +1465,7 @@ ones, in case fg and bg are nil." (shr-generic dom) (when-let* ((id (and (not (dom-attr dom 'id)) ; Handled by `shr-descend'. (dom-attr dom 'name)))) ; Obsolete since HTML5. - (push (cons id (point)) shr--link-targets)) + (push (cons id (set-marker (make-marker) start)) shr--link-targets)) (when url (shr-urlify (or shr-start start) (shr-expand-url url) title) ;; Check whether the URL is suspicious. commit 07f32fa70a219637f6872655ba46e5293e607df4 Author: Lars Ingebrigtsen Date: Sat Jan 22 13:00:31 2022 +0100 Put the old label into the future history in reftex-change-label * lisp/textmodes/reftex-global.el (reftex-change-label): Put the old label into the future history so that it can be edited easily (bug#53417). diff --git a/lisp/textmodes/reftex-global.el b/lisp/textmodes/reftex-global.el index 5ab9ecd8db..2dbb4484a7 100644 --- a/lisp/textmodes/reftex-global.el +++ b/lisp/textmodes/reftex-global.el @@ -184,8 +184,8 @@ No active TAGS table is required." default)))) (if (string= from "") (setq from default)) (unless to - (setq to (read-string (format "Replace label %s with: " - from)))) + (setq to (read-string (format "Replace label %s with: " from) + nil nil from))) (reftex-query-replace-document (concat "{" (regexp-quote from) "}") (format "{%s}" to)))) commit bf3db92bd69de418ff58cef9f2b5c6e263d9d061 Author: Lars Ingebrigtsen Date: Sat Jan 22 12:36:29 2022 +0100 Fix the prompt in hi-lock-read-face-name * lisp/hi-lock.el (hi-lock-read-face-name): Fix the prompt after recent changes (bug#53255). diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el index 53e6f779b3..0a01d90cbb 100644 --- a/lisp/hi-lock.el +++ b/lisp/hi-lock.el @@ -729,10 +729,7 @@ with completion and history." face) (if (and hi-lock-auto-select-face (not current-prefix-arg)) (setq face (or (pop hi-lock--unused-faces) (car defaults))) - (setq face (symbol-name - (read-face-name - (format-prompt "Highlight using face" (car defaults)) - defaults))) + (setq face (symbol-name (read-face-name "Highlight using face" defaults))) ;; Update list of un-used faces. (setq hi-lock--unused-faces (remove face hi-lock--unused-faces)) ;; Grow the list of defaults. commit 90bc1afe69c82b3ad0e3ddcf8606fcf4d2e92e5f Author: Eli Zaretskii Date: Sat Jan 22 13:59:58 2022 +0200 ; * etc/NEWS: Improve entry about Outline mode changes. diff --git a/etc/NEWS b/etc/NEWS index 8cdc55d0e2..87b009d5e2 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -259,13 +259,14 @@ These will take you (respectively) to the next and previous "page". ** Outline Mode -*** Support for a default visibility state. +*** Support for customizing the default visibility state of headings. Customize the option 'outline-default-state' to define what headings -are visible when the mode is set. When equal to a number, the option -'outline-default-rules' determines the visibility of the subtree -starting at the corresponding level. Values are provided to show -a heading subtree unless the heading match a regexp, or its subtree -has long lines or is long. +will be visible after Outline mode is turned on. When equal to a +number, the option 'outline-default-rules' determines the visibility +of the subtree starting at the corresponding level. Values are +provided to control showing a heading subtree depending on whether the +heading matches a regexp, or on whether its subtree has long lines or +is itself too long. ** Outline Minor Mode commit c8375d8408387ca2061096174cab7534e2cdfafb Author: Matthias Meulien Date: Mon Jan 17 20:20:28 2022 +0100 Fix some doc strings in outline.el * lisp/outline.el (outline-default-state): Fix doc string. (outline-default-rules): Fix doc string. diff --git a/lisp/outline.el b/lisp/outline.el index 8e4af64370..4dbbaa26a0 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -1308,23 +1308,25 @@ convenient way to make a table of contents of the buffer." (defcustom outline-default-state nil "If non-nil, some headings are initially outlined. -Note that the default state is applied when the major mode is set -or when the command `outline-apply-default-state' is called -interactively. +Note that the default state is applied when Outline major and +minor modes are set or when the command +`outline-apply-default-state' is called interactively. -When nil, headings visibility is left unchanged. +When nil, no default state is defined and +`outline-apply-default-state' is a no-op. If equal to `outline-show-all', all text of buffer is shown. -If equal to `outline-show-only-headings', only headings are shown. +If equal to `outline-show-only-headings', show only headings, +whatever their level is. If equal to a number, show only headings up to and including the corresponding level. See `outline-default-rules' to customize -visibility of the subtree at the choosen level. +visibility of the subtree at that level. If equal to a lambda function or function name, this function is -expected to toggle headings visibility, and will be called after -the mode is enabled." +expected to toggle headings visibility, and will be +called without arguments after the mode is enabled." :version "29.1" :type '(choice (const :tag "Disabled" nil) (const :tag "Show all" outline-show-all) @@ -1335,6 +1337,9 @@ the mode is enabled." (defcustom outline-default-rules nil "Determines visibility of subtree starting at `outline-default-state' level. +The rules apply if and only if `outline-default-state' is a +number. + When nil, the subtree is hidden unconditionally. When equal to a list, each element should be one of the following: @@ -1350,10 +1355,11 @@ When equal to a list, each element should be one of the following: - `subtree-is-long' to only show the heading branches when its subtree contains more than `outline-default-line-count' lines. -- A lambda function or function name which will be evaluated with - point at the beginning of the heading and the match data set - appropriately, the function being expected to toggle the - heading visibility." +- A cons cell of the form (custom-function . FUNCTION) where + FUNCTION is a lambda function or function name which will be + called without arguments with point at the beginning of the + heading and the match data set appropriately, the function + being expected to toggle the heading visibility." :version "29.1" :type '(choice (const :tag "Hide subtree" nil) (set :tag "Show subtree unless" commit 65c4158c3cec1b3b2d389654b9fc52baa09d2e31 Author: Eli Zaretskii Date: Sat Jan 22 13:09:31 2022 +0200 ; * src/xdisp.c (Fbidi_find_overridden_directionality): Doc fix. diff --git a/src/xdisp.c b/src/xdisp.c index c695e466e7..af46d4da60 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -24884,15 +24884,17 @@ DEFUN ("bidi-find-overridden-directionality", doc: /* Return position between FROM and TO where directionality was overridden. This function returns the first character position in the specified -region of OBJECT where there is a character whose `bidi-class' property -is `L', but which was forced to display as `R' by a directional -override, and likewise with characters whose `bidi-class' is `R' -or `AL' that were forced to display as `L'. +region of OBJECT where characters have their bidirectional +properties affected in a way that might make its text look confusingly +on display. For example, characters whose `bidi-class' property is `L', +could be forced to display as `R' by a directional override, and +likewise characters whose `bidi-class' is `R' or `AL' that are +forced to display as `L'. If no such character is found, the function returns nil. OBJECT is a Lisp string or buffer to search for overridden -directionality, and defaults to the current buffer if nil or omitted. +directionality, and defaults to the current buffer if nil. OBJECT can also be a window, in which case the function will search the buffer displayed in that window. Passing the window instead of a buffer is preferable when the buffer is displayed in some window, @@ -24904,12 +24906,16 @@ of the text. It should be a symbol, either `left-to-right' or `right-to-left', and defaults to `left-to-right'. Strong directional characters `L', `R', and `AL' can have their -intrinsic directionality overridden by directional override -control characters RLO (u+202E) and LRO (u+202D). They can also -have their directionality affected by other formatting control -characters: LRE (u+202A), RLE (u+202B), LRI (u+2066), and RLI (u+2067). -See the function `get-char-code-property' for a way to inquire about -the `bidi-class' property of a character. */) +intrinsic directionality overridden by directional override control +characters RLO (u+202E) and LRO (u+202D). They can also have their +directionality affected by other formatting control characters: LRE +(u+202A), RLE (u+202B), LRI (u+2066), and RLI (u+2067). See the +function `get-char-code-property' for a way to inquire about the +`bidi-class' property of a character. Characters whose intrinsic +directionality is weak or neutral, such as numbers or punctuation +characters, can be forced to display in a very different place with +respect of its surrounding characters, so as to make the surrounding +text confuse the user regarding what the text says. */) (Lisp_Object from, Lisp_Object to, Lisp_Object object, Lisp_Object base_dir) { struct buffer *buf = current_buffer; commit 14d64a8adcc866deecd758b898e8ef2d836b354a (refs/remotes/origin/scratch/correct-warning-pos) Merge: bdd9b5b8a0 ebe334cdc2 Author: Alan Mackenzie Date: Sat Jan 22 11:02:50 2022 +0000 Merge branch 'master' into scratch/correct-warning-pos commit bd586121ac21e046f60f75eeb0200866c38d6f9f Author: Lars Ingebrigtsen Date: Sat Jan 22 11:56:13 2022 +0100 Make the test for existing multisession variables more sensible * lisp/emacs-lisp/multisession.el (multisession-edit-value): Unconfuse the code. diff --git a/lisp/emacs-lisp/multisession.el b/lisp/emacs-lisp/multisession.el index 4a293796a8..25307594c6 100644 --- a/lisp/emacs-lisp/multisession.el +++ b/lisp/emacs-lisp/multisession.el @@ -437,8 +437,8 @@ storage method to list." (let* ((object (or ;; If the multisession variable already exists, use ;; it (so that we update it). - (and (boundp (intern-soft (cdr id))) - (symbol-value (intern (cdr id)))) + (and (intern-soft (cdr id)) + (bound-and-true-p (intern (cdr id)))) ;; Create a new object. (make-multisession :package (car id) commit a604e877cd1f8096f8c428c88c5b960307c12f85 Author: Eli Zaretskii Date: Sat Jan 22 12:14:17 2022 +0200 ; Fix last change in 'textsec-bidi-controls-suspicious-p'. diff --git a/lisp/international/textsec.el b/lisp/international/textsec.el index adef64bfdf..6985f4f3ef 100644 --- a/lisp/international/textsec.el +++ b/lisp/international/textsec.el @@ -301,7 +301,9 @@ affected by bidi controls in STRING." ;; state at end of STRING which could then affect the following ;; text. (insert string "a1א:!") - (bidi-find-overridden-directionality 1 (point-max) nil))) + (let ((pos (bidi-find-overridden-directionality 1 (point-max) nil))) + (and (fixnump pos) + (1- pos))))) (defun textsec-name-suspicious-p (name) "Say whether NAME looks suspicious. commit bdd9b5b8a0d37dd09ee530c1dab3a44bee09e0f8 Author: Alan Mackenzie Date: Sat Jan 22 09:59:05 2022 +0000 Miscellaneous amendments to the scratch/correct-warning-pos branch * lisp/cedet/semantic/fw.el (semantic-alias-obsolete) (semantic-varalias-obsolete): Replace calls to byte-compile-warn with calls to byte-compile-warn-x (when it exists). * lisp/emacs-lisp/bytecomp.el (byte-compile-log-warning-function) (byte-compile--log-warning-for-byte-compile): Make the POSITION parameter no longer &optional (for the benefit of flymake on *.el). (byte-compile-log-warning): Replace a nil POSITION argument with an actual position. (byte-compile-file-form-require): Push the required symbol onto byte-compile-form-stack, for the benefit of `do-after-load-evaluation'. * lisp/keymap.el (define-keymap--compile): Replace four calls to byte-compile-warn with byte-compile-warn-x. * doc/lispref/elisp.texi (master menu): Add entries for Shorthands and Symbols with position. * doc/lispref/streams.texi (Input Functions): Document read-positioning-symbols. * doc/lispref/symbols.texi (Symbols): Add new menu entry. (Symbols with Position): New @section. diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index 3254a4dba8..91926e0579 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -448,6 +448,9 @@ Symbols * Creating Symbols:: How symbols are kept unique. * Symbol Properties:: Each symbol has a property list for recording miscellaneous information. +* Shorthands:: Properly organize your symbol names but + type less of them. +* Symbols with Position:: Symbol variants containing integer positions Symbol Properties diff --git a/doc/lispref/streams.texi b/doc/lispref/streams.texi index c6b3397ae1..4cc8b89234 100644 --- a/doc/lispref/streams.texi +++ b/doc/lispref/streams.texi @@ -326,6 +326,16 @@ For example: @end group @end example @end defun +@end defun + +@defun read-positioning-symbols &optional stream +This function reads one textual expression from @var{stream}, like +@code{read} does, but additionally positions the read symbols to the +positions in @var{stream} where they occurred. Only the symbol +@code{nil} is not positioned, this for efficiency reasons. +@xref{Symbols with Position}. This function is used by the byte +compiler. +@end defun @defvar standard-input This variable holds the default input stream---the stream that diff --git a/doc/lispref/symbols.texi b/doc/lispref/symbols.texi index a951e9be8a..f3a9e586e3 100644 --- a/doc/lispref/symbols.texi +++ b/doc/lispref/symbols.texi @@ -23,15 +23,15 @@ otherwise. @end defun @menu -* Symbol Components:: Symbols have names, values, function definitions +* Symbol Components:: Symbols have names, values, function definitions and property lists. -* Definitions:: A definition says how a symbol will be used. -* Creating Symbols:: How symbols are kept unique. -* Symbol Properties:: Each symbol has a property list +* Definitions:: A definition says how a symbol will be used. +* Creating Symbols:: How symbols are kept unique. +* Symbol Properties:: Each symbol has a property list for recording miscellaneous information. -* Shorthands:: Properly organize your symbol names but +* Shorthands:: Properly organize your symbol names but type less of them. - +* Symbols with Position:: Symbol variants containing integer positions @end menu @node Symbol Components @@ -432,8 +432,8 @@ symbol's property list cell (@pxref{Symbol Components}), in the form of a property list (@pxref{Property Lists}). @menu -* Symbol Plists:: Accessing symbol properties. -* Standard Properties:: Standard meanings of symbol properties. +* Symbol Plists:: Accessing symbol properties. +* Standard Properties:: Standard meanings of symbol properties. @end menu @node Symbol Plists @@ -751,3 +751,69 @@ those names. @item Symbol forms whose names start with @samp{#_} are not transformed. @end itemize + +@node Symbols with Position +@section Symbols with Position +@cindex symbols with position + +A @dfn{symbol with position} is a symbol, the @dfn{bare symbol}, +together with an unsigned integer called the @dfn{position}. These +objects are intended for use by the byte compiler, which records in +them the position of each symbol occurrence and uses those positions +in warning and error messages. + +The printed representation of a symbol with position uses the hash +notation outlined in @ref{Printed Representation}. It looks like +@samp{#}. It has no read syntax. You can cause +just the bare symbol to be printed by binding the variable +@code{print-symbols-bare} to non-@code{nil} around the print +operation. The byte compiler does this before writing its output to +the compiled Lisp file. + +For most purposes, when the flag variable +@code{symbols-with-pos-enabled} is non-@code{nil}, symbols with +positions behave just as bare symbols do. For example, @samp{(eq +# foo)} has a value @code{t} when that variable +is set (but nil when it isn't set). Most of the time in Emacs this +variable is @code{nil}, but the byte compiler binds it to @code{t} +when it runs. + +Typically, symbols with position are created by the byte compiler +calling the reader function @code{read-positioning-symbols} +(@pxref{Input Functions}). One can also be created with the function +@code{position-symbol}. + +@defvar symbols-with-pos-enabled +When this variable is non-@code{nil}, symbols with position behave +like the contained bare symbol. Emacs runs a little more slowly in +this case. +@end defvar + +@defvar print-symbols-bare +When bound to non-nil, the Lisp printer prints only the bare symbol of +a symbol with position, ignoring the position. +@end defvar + +@defun symbol-with-pos-p symbol. +This function returns @code{t} if @var{symbol} is a symbol with +position, @code{nil} otherwise. +@end defun + +@defun bare-symbol symbol +This function returns the bare symbol contained in @var{symbol}, or +@var{symbol} itself if it is already a bare symbol. For any other +type of object, it throws an error. +@end defun + +@defun symbol-with-pos-pos symbol +This function returns the position, a number, from a symbol with +position. For any other type of object, it throws an error. +@end defun + +@defun position-symbol sym pos +Make a new symbol with position. @var{sym} is either a bare symbol or +a symbol with position, and supplies the symbol part of the new +object. @var{pos} is either an integer which becomes the number part +of the new object, or a symbol with position whose position is used. +Emacs throws an error if either argument is invalid. +@end defun diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el index fd61751cb5..b7c3461a4d 100644 --- a/lisp/cedet/semantic/fw.el +++ b/lisp/cedet/semantic/fw.el @@ -191,12 +191,20 @@ will throw a warning when it encounters this symbol." (not (string-match "cedet" (macroexp-file-name))) ) (make-obsolete-overload oldfnalias newfn when) - (byte-compile-warn - "%s: `%s' obsoletes overload `%s'" - (macroexp-file-name) - newfn - (with-suppressed-warnings ((obsolete semantic-overload-symbol-from-function)) - (semantic-overload-symbol-from-function oldfnalias))))) + (if (fboundp 'byte-compile-warn-x) + (byte-compile-warn-x + newfn + "%s: `%s' obsoletes overload `%s'" + (macroexp-file-name) + newfn + (with-suppressed-warnings ((obsolete semantic-overload-symbol-from-function)) + (semantic-overload-symbol-from-function oldfnalias))) + (byte-compile-warn + "%s: `%s' obsoletes overload `%s'" + (macroexp-file-name) + newfn + (with-suppressed-warnings ((obsolete semantic-overload-symbol-from-function)) + (semantic-overload-symbol-from-function oldfnalias)))))) (defun semantic-varalias-obsolete (oldvaralias newvar when) "Make OLDVARALIAS an alias for variable NEWVAR. @@ -209,10 +217,14 @@ will throw a warning when it encounters this symbol." (error ;; Only throw this warning when byte compiling things. (when (macroexp-compiling-p) - (byte-compile-warn - "variable `%s' obsoletes, but isn't alias of `%s'" - newvar oldvaralias) - )))) + (if (fboundp 'byte-compile-warn-x) + (byte-compile-warn-x + newvar + "variable `%s' obsoletes, but isn't alias of `%s'" + newvar oldvaralias) + (byte-compile-warn + "variable `%s' obsoletes, but isn't alias of `%s'" + newvar oldvaralias)))))) ;;; Help debugging ;; diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 41d2126dbc..587819f36e 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1309,20 +1309,21 @@ Called with arguments (STRING POSITION FILL LEVEL). STRING is a message describing the problem. POSITION is a buffer position where the problem was detected. FILL is a prefix as in `warning-fill-prefix'. LEVEL is the level of the -problem (`:warning' or `:error'). POSITION, FILL and LEVEL may be -nil.") +problem (`:warning' or `:error'). FILL and LEVEL may be nil.") (defun byte-compile-log-warning (string &optional fill level) "Log a byte-compilation warning. STRING, FILL and LEVEL are as described in `byte-compile-log-warning-function', which see." (funcall byte-compile-log-warning-function - string nil + string + (or (byte-compile--warning-source-offset) + (point)) fill level)) -(defun byte-compile--log-warning-for-byte-compile (string &optional - _position +(defun byte-compile--log-warning-for-byte-compile (string _position + &optional fill level) "Log a message STRING in `byte-compile-log-buffer'. @@ -2653,8 +2654,11 @@ list that represents a doc string reference. (put 'require 'byte-hunk-handler 'byte-compile-file-form-require) (defun byte-compile-file-form-require (form) - (let ((args (mapcar 'eval (cdr form))) - hist-new prov-cons) + (let* ((args (mapcar 'eval (cdr form))) + ;; The following is for the byte-compile-warn in + ;; `do-after-load-evaluation' (in subr.el). + (byte-compile-form-stack (cons (car args) byte-compile-form-stack)) + hist-new prov-cons) (apply 'require args) ;; Record the functions defined by the require in `byte-compile-new-defuns'. diff --git a/lisp/keymap.el b/lisp/keymap.el index 3e9189fba4..ce566fd8af 100644 --- a/lisp/keymap.el +++ b/lisp/keymap.el @@ -462,18 +462,19 @@ If MESSAGE (and interactively), message the result." (keywordp (car args)) (not (eq (car args) :menu))) (unless (memq (car args) '(:full :keymap :parent :suppress :name :prefix)) - (byte-compile-warn "Invalid keyword: %s" (car args))) + (byte-compile-warn-x (car args) "Invalid keyword: %s" (car args))) (setq args (cdr args)) (when (null args) - (byte-compile-warn "Uneven number of keywords in %S" form)) + (byte-compile-warn-x form "Uneven number of keywords in %S" form)) (setq args (cdr args))) ;; Bindings. (while args - (let ((key (pop args))) + (let* ((wargs args) + (key (pop args))) (when (and (stringp key) (not (key-valid-p key))) - (byte-compile-warn "Invalid `kbd' syntax: %S" key))) + (byte-compile-warn-x wargs "Invalid `kbd' syntax: %S" key))) (when (null args) - (byte-compile-warn "Uneven number of key bindings in %S" form)) + (byte-compile-warn-x form "Uneven number of key bindings in %S" form)) (setq args (cdr args))) form) commit 682b6df6bfc7af98a28b54bd925cd33dead2c25d Author: Eli Zaretskii Date: Sat Jan 22 11:58:05 2022 +0200 Improve detection of suspicious uses of bidi controls * lisp/international/textsec.el (textsec-bidi-controls-suspicious-p): New function. (textsec-name-suspicious-p): Use it. * test/lisp/international/textsec-tests.el (test-suspicious-name): Enable the test that was previously failing with 'bidi-find-overridden-directionality'. diff --git a/lisp/international/textsec.el b/lisp/international/textsec.el index 223c0d5c92..adef64bfdf 100644 --- a/lisp/international/textsec.el +++ b/lisp/international/textsec.el @@ -287,6 +287,22 @@ certain other unusual mixtures of characters." ((string-match-p "\\`\\.\\|\\.\\'\\|\\.\\." local) (format "`%s' contains invalid dots" local)))) +(defun textsec-bidi-controls-suspicious-p (string) + "Return non-nil of STRING uses bidi controls in suspicious ways. +If STRING doesn't include any suspicious uses of bidirectional +formatting control characters, return nil. Otherwise, return the +index of the first character in STRING affected by such suspicious +use of bidi controls. If the returned value is beyond the length +of STRING, it means any text following STRING on display might be +affected by bidi controls in STRING." + (with-temp-buffer + ;; We add a string that's representative of some text that could + ;; follow STRING, with the purpose of detecting residual bidi + ;; state at end of STRING which could then affect the following + ;; text. + (insert string "a1א:!") + (bidi-find-overridden-directionality 1 (point-max) nil))) + (defun textsec-name-suspicious-p (name) "Say whether NAME looks suspicious. NAME is (for instance) the free-text display name part of an @@ -310,10 +326,11 @@ other unusual mixtures of characters." ?\N{arabic letter mark}))))) name) ;; We have bidirectional formatting characters, but check - ;; whether they affect LTR characters. If not, it's not - ;; suspicious. - (bidi-find-overridden-directionality 0 (length name) name)) - (format "The string contains bidirectional control characters")) + ;; whether they affect any other characters in suspicious + ;; ways. If not, NAME is not suspicious. + (fixnump (textsec-bidi-controls-suspicious-p name))) + (format "`%s' contains suspicious uses of bidirectional control characters" + name)) ((textsec-suspicious-nonspacing-p name)))) (defun textsec-suspicious-nonspacing-p (string) diff --git a/test/lisp/international/textsec-tests.el b/test/lisp/international/textsec-tests.el index c3c7e9b59a..ee0af66d99 100644 --- a/test/lisp/international/textsec-tests.el +++ b/test/lisp/international/textsec-tests.el @@ -136,10 +136,8 @@ (should (textsec-name-suspicious-p "LÅRS INGEBRIGTSEN")) (should-not (textsec-name-suspicious-p "LÅRS INGEBRIGTSEN")) - ;;; FIXME -- this test fail with `bidi-find-overridden-directionality'. - (when nil - (should (textsec-name-suspicious-p - "Lars Ingebrigtsen\N{LEFT-TO-RIGHT OVERRIDE}"))) + (should (textsec-name-suspicious-p + "Lars Ingebrigtsen\N{LEFT-TO-RIGHT OVERRIDE}")) (should (textsec-name-suspicious-p "Lars Ingebrigtsen\N{LEFT-TO-RIGHT OVERRIDE}f")) (should-not (textsec-name-suspicious-p commit ebe334cdc234de2897263aed4c05ac7088c11857 Author: Po Lu Date: Sat Jan 22 09:51:30 2022 +0000 Prevent raw bytes from being displayed as help text on Haiku * src/haikumenu.c (digest_menu_items): Don't set encoded text into the menu item vector. diff --git a/src/haikumenu.c b/src/haikumenu.c index 2ceb0ff365..2922981cb3 100644 --- a/src/haikumenu.c +++ b/src/haikumenu.c @@ -142,10 +142,7 @@ digest_menu_items (void *first_menu, int start, int menu_items_used, } if (STRINGP (help) && STRING_MULTIBYTE (help)) - { - help = ENCODE_UTF_8 (help); - ASET (menu_items, i + MENU_ITEMS_ITEM_HELP, help); - } + help = ENCODE_UTF_8 (help); if (i + MENU_ITEMS_ITEM_LENGTH < menu_items_used && NILP (AREF (menu_items, i + MENU_ITEMS_ITEM_LENGTH))) commit 2b72558527fd2f31274f665244ad84fe90a19bd5 Author: Po Lu Date: Sat Jan 22 16:16:26 2022 +0800 Use locale coding system to decode XIM preedit text * src/xfns.c (x_xim_text_to_utf8_unix): XIMs typically return text in the locale coding system, so use that instead. diff --git a/src/xfns.c b/src/xfns.c index a1435d5351..7123198724 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -3051,7 +3051,7 @@ x_xim_text_to_utf8_unix (XIMText *text, ptrdiff_t *length) } nbytes = strlen (text->string.multi_byte); - setup_coding_system (Qutf_8_unix, &coding); + setup_coding_system (Vlocale_coding_system, &coding); coding.mode |= (CODING_MODE_LAST_BLOCK | CODING_MODE_SAFE_ENCODING); coding.source = (const unsigned char *) text->string.multi_byte; commit e58ecd01d51471e7e63d20ee059a5c26251220b7 Author: Thomas Fitzsimmons Date: Fri Jan 21 17:40:57 2022 -0500 EUDC: Fix a quoting bug in the BBDB backend * lisp/net/eudcb-bbdb.el (eudc-bbdb-query-internal): Fix a quoting bug introduced during lexical-binding conversion. diff --git a/lisp/net/eudcb-bbdb.el b/lisp/net/eudcb-bbdb.el index 60a3adbc34..e71dc238d0 100644 --- a/lisp/net/eudcb-bbdb.el +++ b/lisp/net/eudcb-bbdb.el @@ -233,7 +233,7 @@ RETURN-ATTRS is a list of attributes to return, defaulting to (setq bbdb-attrs (append bbdb-attrs (list (car query-attrs)))) (if (car query-attrs) ;; BEWARE: `bbdb-search' is a macro! - (setq records (eval `(bbdb-search records ,@bbdb-attrs) t))) + (setq records (eval `(bbdb-search (quote ,records) ,@bbdb-attrs) t))) (setq query-attrs (cdr query-attrs))) (mapc (lambda (record) (setq filtered (eudc-filter-duplicate-attributes record)) commit 3023e7ca3d911d431738551753e4cfb8e3e01ec5 Author: Alan Mackenzie Date: Sat Jan 15 17:36:12 2022 +0000 Remove the remnants of old position mechanism from scratch/correct-warning-pos Also correct one or two positions in macroexp-warn-and-return invocations. * lisp/emacs-lisp/bytecomp.el (byte-compile-read-position) (byte-compile-last-position, byte-compile-set-symbol-position): Remove. (byte-compile-warning-prefix, byte-compile-function-warn) (byte-compile-emit-callargs-warn, byte-compile-arglist-warn) (byte-compile-warn-about-unresolved-functions, compile-defun) (byte-compile-from-buffer, byte-compile-from-buffer) (byte-compile-file-form-defmumble, byte-compile-check-lambda-list) (byte-compile-lambda, byte-compile-form, byte-compile-normal-call) (byte-compile-check-variable, byte-compile-push-constant) (byte-compile-subr-wrong-args, byte-compile-negation-optimizer) (byte-compile-condition-case, byte-compile-defvar, byte-compile-autoload) (byte-compile-lambda-form): Remove the remnants of the old warning position mechanism. (byte-compile-function-warn): Replace byte-compile-last-position by a symbol-with-pos-pos call. (compile-defun): Use local variable start-read-position to fulfil purpose of old byte-compile-read-position. Push the just read FORM onto byte-compile-form-stack. * lisp/emacs-lisp/eieio.el (defclass): New mechanism to get the correct source warning position to macroexp-warn-and-return. * lisp/emacs-lisp/macroexp (macroexp--unfold-lambda): Correct the position argument given to macroexp-warn-and-return. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 7ddca19626..41d2126dbc 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1149,11 +1149,6 @@ message buffer `default-directory'." (t (insert (format "%s\n" string))))))) -(defvar byte-compile-read-position nil - "Character position we began the last `read' from.") -(defvar byte-compile-last-position nil - "Last known character position in the input.") - ;; copied from gnus-util.el (defsubst byte-compile-delete-first (elt list) (if (eq (car list) elt) @@ -1166,43 +1161,6 @@ message buffer `default-directory'." (setcdr list (cddr list))) total))) -;; The purpose of `byte-compile-set-symbol-position' is to attempt to -;; set `byte-compile-last-position' to the "current position" in the -;; raw source code. This is used for warning and error messages. -;; -;; The function should be called for most occurrences of symbols in -;; the forms being compiled, strictly in the order they occur in the -;; source code. It should never be called twice for any single -;; occurrence, and should not be called for symbols generated by the -;; byte compiler itself. -;; -;; The function works by scanning the elements in the alist -;; `read-symbol-positions-list' for the next match for the symbol -;; after the current value of `byte-compile-last-position', setting -;; that variable to the match's character position, then deleting the -;; matching element from the list. Thus the new value for -;; `byte-compile-last-position' is later than the old value unless, -;; perhaps, ALLOW-PREVIOUS is non-nil. -;; -;; So your're probably asking yourself: Isn't this function a gross -;; hack? And the answer, of course, would be yes. -(defun byte-compile-set-symbol-position (sym &optional allow-previous) - (when byte-compile-read-position - (let ((last byte-compile-last-position) - entry) - (while (progn - (setq entry (assq sym read-symbol-positions-list)) - (when entry - (setq byte-compile-last-position - (+ byte-compile-read-position (cdr entry)) - read-symbol-positions-list - (byte-compile-delete-first - entry read-symbol-positions-list))) - (and entry - (or (and allow-previous - (not (= last byte-compile-last-position))) - (> last byte-compile-last-position)))))))) - (defvar byte-compile-last-warned-form nil) (defvar byte-compile-last-logged-file nil) (defvar byte-compile-root-dir nil @@ -1269,34 +1227,14 @@ Return nil if such is not found." (t ""))) (offset (byte-compile--warning-source-offset)) (pos (if (and byte-compile-current-file - (integerp byte-compile-read-position) (or offset (not symbols-with-pos-enabled))) (with-current-buffer byte-compile-current-buffer - ;; (format "%d:%d:" - ;; (save-excursion - ;; (goto-char (if symbols-with-pos-enabled - ;; (+ byte-compile-read-position offset) - ;; byte-compile-last-position) - ;; ) - ;; (1+ (count-lines (point-min) (point-at-bol)))) - ;; (save-excursion - ;; (goto-char (if symbols-with-pos-enabled - ;; (+ byte-compile-read-position offset) - ;; byte-compile-last-position) - ;; ) - ;; (1+ (current-column)))) -;;;; EXPERIMENTAL STOUGH, 2018-11-22 - (let (old-l old-c new-l new-c) + (let (new-l new-c) (save-excursion - (goto-char byte-compile-last-position) - (setq old-l (1+ (count-lines (point-min) (point-at-bol))) - old-c (1+ (current-column))) (goto-char offset) (setq new-l (1+ (count-lines (point-min) (point-at-bol))) new-c (1+ (current-column))) - (format "%d:%d:%d:%d:" old-l old-c new-l new-c))) -;;;; END OF EXPERIMENTAL STOUGH - ) + (format "%d:%d:" new-l new-c)))) "")) (form (if (eq byte-compile-current-form :end) "end of data" (or byte-compile-current-form "toplevel form")))) @@ -1379,7 +1317,7 @@ nil.") STRING, FILL and LEVEL are as described in `byte-compile-log-warning-function', which see." (funcall byte-compile-log-warning-function - string byte-compile-last-position + string nil fill level)) @@ -1525,7 +1463,6 @@ when printing the error message." (t (format "%d-%d" (car signature) (cdr signature))))) (defun byte-compile-function-warn (f nargs def) - (byte-compile-set-symbol-position f) (when (and (get f 'byte-obsolete-info) (byte-compile-warning-enabled-p 'obsolete f)) (byte-compile-warn-obsolete f)) @@ -1542,11 +1479,14 @@ when printing the error message." (if cons (or (memq nargs (cddr cons)) (push nargs (cddr cons))) - (push (list f byte-compile-last-position nargs) + (push (list f + (if (symbol-with-pos-p f) + (symbol-with-pos-pos f) + 1) ; Should never happen. + nargs) byte-compile-unresolved-functions))))) (defun byte-compile-emit-callargs-warn (name actual-args min-args max-args) - (byte-compile-set-symbol-position name) (byte-compile-warn-x name "%s called with %d argument%s, but %s %s" @@ -1672,7 +1612,6 @@ extra args." max (car (nreverse nums))) (when (or (< min (car sig)) (and (cdr sig) (> max (cdr sig)))) - (byte-compile-set-symbol-position name) (byte-compile-warn-x name "%s being defined to take %s%s, but was previously called with %s" @@ -1692,7 +1631,6 @@ extra args." (let ((sig1 (byte-compile--function-signature old)) (sig2 (byte-compile-arglist-signature arglist))) (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2) - (byte-compile-set-symbol-position name) (byte-compile-warn-x name "%s %s used to take %s %s, now takes %s" @@ -1785,7 +1723,7 @@ It is too wide if it has any lines longer than the largest of (byte-compile--wide-docstring-p docs col)) (byte-compile-warn-x name - "%s%s docstring wider than %s characters" + "%s%sdocstring wider than %s characters" kind name col)))) form) @@ -1800,11 +1738,10 @@ It is too wide if it has any lines longer than the largest of (dolist (urf byte-compile-unresolved-functions) (let ((f (car urf))) (when (not (memq f byte-compile-new-defuns)) - (let ((byte-compile-last-position (cadr urf))) - (byte-compile-warn-x - f - (if (fboundp f) "the function `%s' might not be defined at runtime." "the function `%s' is not known to be defined.") - (car urf)))))))) + (byte-compile-warn-x + f + (if (fboundp f) "the function `%s' might not be defined at runtime." "the function `%s' is not known to be defined.") + (car urf))))))) nil) @@ -2266,8 +2203,7 @@ With argument ARG, insert value in current buffer after the form." (let* ((print-symbols-bare t) (byte-compile-current-file (current-buffer)) (byte-compile-current-buffer (current-buffer)) - (byte-compile-read-position (point)) - (byte-compile-last-position byte-compile-read-position) + (start-read-position (point)) (byte-compile-last-warned-form 'nothing) (value (eval (let ((read-with-symbol-positions (current-buffer)) @@ -2275,9 +2211,11 @@ With argument ARG, insert value in current buffer after the form." (symbols-with-pos-enabled t)) (displaying-byte-compile-warnings (byte-compile-sexp - (eval-sexp-add-defvars - (read-positioning-symbols (current-buffer)) - byte-compile-read-position)))) + (let ((form (read-positioning-symbols (current-buffer)))) + (push form byte-compile-form-stack) + (eval-sexp-add-defvars + form + start-read-position))))) lexical-binding))) (cond (arg (message "Compiling from buffer... done.") @@ -2287,8 +2225,6 @@ With argument ARG, insert value in current buffer after the form." (defun byte-compile-from-buffer (inbuffer) (let ((byte-compile-current-buffer inbuffer) - (byte-compile-read-position nil) - (byte-compile-last-position nil) ;; Prevent truncation of flonums and lists as we read and print them (float-output-format nil) (case-fold-search nil) @@ -2357,8 +2293,6 @@ With argument ARG, insert value in current buffer after the form." (= (following-char) ?\;)) (forward-line 1)) (not (eobp))) - (setq byte-compile-read-position (point) - byte-compile-last-position byte-compile-read-position) (let* ((lread--unescaped-character-literals nil) (form (read-positioning-symbols inbuffer)) (warning (byte-run--unescaped-character-literals-warning))) @@ -2366,9 +2300,6 @@ With argument ARG, insert value in current buffer after the form." (byte-compile-toplevel-file-form form))) ;; Compile pending forms at end of file. (byte-compile-flush-pending) - ;; Make warnings about unresolved functions - ;; give the end of the file as their position. - (setq byte-compile-last-position (point-max)) (byte-compile-warn-about-unresolved-functions))) byte-compile--outbuffer))) @@ -2786,7 +2717,6 @@ not to take responsibility for the actual compilation of the code." (bare-name (bare-symbol name)) (byte-compile-current-form name)) ; For warnings. - (byte-compile-set-symbol-position name) (push bare-name byte-compile-new-defuns) ;; When a function or macro is defined, add it to the call tree so that ;; we can tell when functions are not used. @@ -2845,8 +2775,6 @@ not to take responsibility for the actual compilation of the code." (symbolp (car-safe (cdr-safe body))) (car-safe (cdr-safe body)) (stringp (car-safe (cdr-safe (cdr-safe body))))) - ;; FIXME: We've done that already just above, so this looks wrong! - ;;(byte-compile-set-symbol-position name) (byte-compile-warn-x name "probable `\"' without `\\' in doc string of %s" bare-name)) @@ -3024,8 +2952,6 @@ If FORM is a lambda or a macro, byte-compile it as a function." (let (vars) (while list (let ((arg (car list))) - (when (symbolp arg) - (byte-compile-set-symbol-position arg)) (cond ((or (not (symbolp arg)) (macroexp--const-symbol-p arg t)) (error "Invalid lambda variable %s" arg)) @@ -3099,16 +3025,11 @@ If FORM is a lambda or a macro, byte-compile it as a function." (defun byte-compile-lambda (fun &optional add-lambda reserved-csts) "Byte-compile a lambda-expression and return a valid function. The value is usually a compiled function but may be the original -lambda-expression. -When ADD-LAMBDA is non-nil, the symbol `lambda' is added as head -of the list FUN and `byte-compile-set-symbol-position' is not called. -Use this feature to avoid calling `byte-compile-set-symbol-position' -for symbols generated by the byte compiler itself." +lambda-expression." (if add-lambda (setq fun (cons 'lambda fun)) (unless (eq 'lambda (car-safe fun)) - (error "Not a lambda list: %S" fun)) - (byte-compile-set-symbol-position 'lambda)) + (error "Not a lambda list: %S" fun))) (byte-compile-docstring-length-warn fun) (byte-compile-check-lambda-list (nth 1 fun)) (let* ((arglist (nth 1 fun)) @@ -3131,7 +3052,6 @@ for symbols generated by the byte compiler itself." (byte-compile--warn-lexical-dynamic var 'lambda)))) ;; Process the interactive spec. (when int - (byte-compile-set-symbol-position 'interactive) ;; Skip (interactive) if it is in front (the most usual location). (if (eq int (car body)) (setq body (cdr body))) @@ -3416,13 +3336,9 @@ for symbols generated by the byte compiler itself." (cond ((not (consp form)) (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form)) - (when (symbolp form) - (byte-compile-set-symbol-position form)) (byte-compile-constant (if (symbolp form) (bare-symbol form) form))) ((and byte-compile--for-effect byte-compile-delete-errors) - (when (symbolp form) - (byte-compile-set-symbol-position form)) (setq byte-compile--for-effect nil)) (t (byte-compile-variable-ref (bare-symbol form))))) @@ -3501,7 +3417,6 @@ for symbols generated by the byte compiler itself." (byte-compile-annotate-call-tree form)) (when (and byte-compile--for-effect (eq (car form) 'mapcar) (byte-compile-warning-enabled-p 'mapcar 'mapcar)) - (byte-compile-set-symbol-position 'mapcar) (byte-compile-warn-x (car form) "`mapcar' called for effect; use `mapc' or `dolist' instead")) @@ -3634,8 +3549,6 @@ for symbols generated by the byte compiler itself." (defun byte-compile-check-variable (var access-type) "Do various error checks before a use of the variable VAR." - (when (symbolp var) - (byte-compile-set-symbol-position var)) (cond ((or (not (symbolp var)) (macroexp--const-symbol-p var)) (when (byte-compile-warning-enabled-p 'constants (and (symbolp var) var)) @@ -3739,7 +3652,6 @@ assignment (i.e. `setq')." ;; This ignores byte-compile--for-effect. (defun byte-compile-push-constant (const) (when (symbolp const) - (byte-compile-set-symbol-position const) (setq const (bare-symbol const))) (byte-compile-out 'byte-constant @@ -3895,7 +3807,6 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (defun byte-compile-subr-wrong-args (form n) - (byte-compile-set-symbol-position (car form)) (byte-compile-warn-x (car form) "`%s' called with %d arg%s, but requires %s" (car form) (length (cdr form)) @@ -4831,7 +4742,6 @@ binding slots have been popped." ;; Even when optimization is off, /= is optimized to (not (= ...)). (defun byte-compile-negation-optimizer (form) ;; an optimizer for forms where is less efficient than (not ) - (byte-compile-set-symbol-position (car form)) (list 'not (cons (or (get (car form) 'byte-compile-negated-op) (error @@ -4881,7 +4791,6 @@ binding slots have been popped." (cons (byte-compile-make-tag) clause)) failure-handlers)) (endtag (byte-compile-make-tag))) - (byte-compile-set-symbol-position 'condition-case) (unless (symbolp var) (byte-compile-warn-x var "`%s' is not a variable-name or nil (in condition-case)" var)) @@ -4994,7 +4903,6 @@ binding slots have been popped." (var (nth 1 form)) (value (nth 2 form)) (string (nth 3 form))) - (byte-compile-set-symbol-position fun) (when (or (> (length form) 4) (and (eq fun 'defconst) (null (cddr form)))) (let ((ncall (length (cdr form)))) @@ -5027,7 +4935,6 @@ binding slots have been popped." `',var))))) (defun byte-compile-autoload (form) - (byte-compile-set-symbol-position 'autoload) (and (macroexp-const-p (nth 1 form)) (macroexp-const-p (nth 5 form)) (memq (eval (nth 5 form)) '(t macro)) ; macro-p @@ -5042,7 +4949,6 @@ binding slots have been popped." ;; Lambdas in valid places are handled as special cases by various code. ;; The ones that remain are errors. (defun byte-compile-lambda-form (_form) - (byte-compile-set-symbol-position 'lambda) (error "`lambda' used as function name is invalid")) ;; Compile normally, but deal with warnings for the function being defined. diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index e6a5685b5e..820e8383d8 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -181,9 +181,11 @@ and reference them using the function `class-option'." ;; Is there an initarg, but allocation of class? (when (and initarg (eq alloc :class)) - (push (format "Meaningless :initarg for class allocated slot '%S'" - sname) - warnings)) + (push + (cons sname + (format "Meaningless :initarg for class allocated slot '%S'" + sname)) + warnings)) (let ((init (plist-get soptions :initform))) (unless (or (macroexp-const-p init) @@ -194,8 +196,9 @@ and reference them using the function `class-option'." ;; heuristic says and if it disagrees with normal evaluation ;; then tweak the initform to make it fit and emit ;; a warning accordingly. - (push (format "Ambiguous initform needs quoting: %S" init) - warnings))) + (push + (cons init (format "Ambiguous initform needs quoting: %S" init)) + warnings))) ;; Anyone can have an accessor function. This creates a function ;; of the specified name, and also performs a `defsetf' if applicable @@ -242,8 +245,8 @@ This method is obsolete." `(progn ,@(mapcar (lambda (w) - (macroexp-warn-and-return w ; W is probably a poor choice for a position. - w `(progn ',w) nil 'compile-only)) + (macroexp-warn-and-return + (car w) (cdr w) `(progn ',(cdr w)) nil 'compile-only)) warnings) ;; This test must be created right away so we can have self- ;; referencing classes. ei, a class whose slot can contain only diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 27a7a8f8cf..256092599b 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -162,6 +162,8 @@ Other uses risk returning non-nil value that point to the wrong file." #'macroexp-warn-and-return "28.1") (defun macroexp-warn-and-return (arg msg form &optional category compile-only) "Return code equivalent to FORM labeled with warning MSG. +ARG is a symbol (or a form) giving the source code position of FORM +for the message. It should normally be a symbol with position. CATEGORY is the category of the warning, like the categories that can appear in `byte-compile-warnings'. COMPILE-ONLY non-nil means no warning should be emitted if the code @@ -287,7 +289,7 @@ is executed without being compiled first." (setq arglist (cdr arglist))) (if values (macroexp-warn-and-return - name + arglist (format (if (eq values 'too-few) "attempt to open-code `%s' with too few arguments" "attempt to open-code `%s' with too many arguments") commit d87a34597c9f0be967f75ff8cfd0ace4392da63f Merge: 57b698f159 d29291d665 Author: Alan Mackenzie Date: Fri Jan 14 19:28:07 2022 +0000 Merge branch 'master' into scratch/correct-warning-pos Merge branch: commit d29291d665e808307126bf52c3e748fef78f0f9c (HEAD -> master, origin/master, origin/HEAD) Author: Stefan Monnier Date: Fri Jan 14 12:26:30 2022 -0500 (macroexp--expand-all): Fix bug#53227 and bug#46636 commit 57b698f15913385aec7bc9745016b961c0aa5c55 Author: Alan Mackenzie Date: Fri Jan 14 19:06:04 2022 +0000 Commit fixes and enhancements to the scratch/correct-warning-pos branch No longer strip positions from symbols before each use of a form, instead relying on the low level C routines to do the right thing. Instead strip them from miscellaneous places where this is needed. Stip them alson in `function-put'. Push forms onto byte-compile-form-stack and pop them "by hand" rather than by binding the variable at each pushing, so that it will still have its data after an error has been thrown and caught by a condition case. This gives an source position to the ensuing error message. * lisp/emacs-lisp/byte-run.el (byte-run--ssp-seen, byte-run--circular-list-p) (byte-run--strip-s-p-1, byte-run-strip-symbol-positions): New functions and variables, which together implement stripping of symbol positions. The latest (?final) version modifies the argument in place rather than making a copy. (function-put): Strip symbol positions from all of the arguments before doing the `put'. * lisp/emacs-lisp/bytecomp.el (byte-compile--form-stack): has been renamed to byte-compile-form-stack and moved to macroexp.el. (byte-compile-initial-macro-environment (eval-and-compile)): Replace macroexpand-all-toplevel with macroexpand--all-toplevel. (displaying-byte-compile-warnings): bind byte-compile-form-stack here. (byte-compile-toplevel-file-form, byte-compile-form): Push the top level form onto byte-compile-form-stack (whereas formally the variable was bound at each pushing). Manually pop this from of the variable at the end of the function. * lisp/emacs-lisp/cl-macs.el (cl-define-compiler-macro): Remove the symbol stripping. * lisp/emacs-lisp/comp.el (comp--native-compile): Set max-specpdl-size to at least 5000 (previously it was 2500). Bind print-symbols-bare to t. * lisp/emacs-lisp/macroexp.el (byte-compile-form-stack): Definition move here from bytecomp.el for easier compilation. (byte-compile-strip-symbol-positions and associated functions): Removed. (macro--expand-all): push argument FORM onto byte-compile-form-stack at the start of this function, and pop it off at the end. (internal-macroexpand-for-load): No longer strip symbol positions. Bind symbols-with-pos-enabled and print-symbols-bare to t. * lisp/help.el (help--make-usage): Strip any position from argument ARG. * src/fns.c (Fput): No longer strip symbol positions from any of the arguments. diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index f324bcd971..fedc10cea4 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -30,6 +30,83 @@ ;;; Code: +(defvar byte-run--ssp-seen nil + "Which conses/vectors/records have been processed in strip-symbol-positions? +The value is a hash table, the key being the old element and the value being +the corresponding new element of the same type. + +The purpose of this is to detect circular structures.") + +(defalias 'byte-run--circular-list-p + #'(lambda (l) + "Return non-nil when the list L is a circular list. +Note that this algorithm doesn't check any circularity in the +CARs of list elements." + (let ((hare l) + (tortoise l)) + (condition-case err + (progn + (while (progn + (setq hare (cdr (cdr hare)) + tortoise (cdr tortoise)) + (not (or (eq tortoise hare) + (null hare))))) + (eq tortoise hare)) + (wrong-type-argument nil) + (error (signal (car err) (cdr err))))))) + +(defalias 'byte-run--strip-s-p-1 + #'(lambda (arg) + "Strip all positions from symbols in ARG, modifying ARG. +Return the modified ARG." + (cond + ((symbol-with-pos-p arg) + (bare-symbol arg)) + + ((consp arg) + (let* ((round (byte-run--circular-list-p arg)) + (hash (and round (gethash arg byte-run--ssp-seen)))) + (or hash + (let ((a arg) new) + (while + (progn + (when round + (puthash a new byte-run--ssp-seen)) + (setq new (byte-run--strip-s-p-1 (car a))) + (when (not (eq new (car a))) ; For read-only things. + (setcar a new)) + (and (consp (cdr a)) + (not + (setq hash + (and round + (gethash (cdr a) byte-run--ssp-seen)))))) + (setq a (cdr a))) + (setq new (byte-run--strip-s-p-1 (cdr a))) + (when (not (eq new (cdr a))) + (setcdr a (or hash new))) + arg)))) + + ((or (vectorp arg) (recordp arg)) + (let ((hash (gethash arg byte-run--ssp-seen))) + (or hash + (let* ((len (length arg)) + (i 0) + new) + (puthash arg arg byte-run--ssp-seen) + (while (< i len) + (setq new (byte-run--strip-s-p-1 (aref arg i))) + (when (not (eq new (aref arg i))) + (aset arg i new)) + (setq i (1+ i))) + arg)))) + + (t arg)))) + +(defalias 'byte-run-strip-symbol-positions + #'(lambda (arg) + (setq byte-run--ssp-seen (make-hash-table :test 'eq)) + (byte-run--strip-s-p-1 arg))) + (defalias 'function-put ;; We don't want people to just use `put' because we can't conveniently ;; hook into `put' to remap old properties to new ones. But for now, there's @@ -38,7 +115,9 @@ "Set FUNCTION's property PROP to VALUE. The namespace for PROP is shared with symbols. So far, FUNCTION can only be a symbol, not a lambda expression." - (put function prop value))) + (put (bare-symbol function) + (byte-run-strip-symbol-positions prop) + (byte-run-strip-symbol-positions value)))) (function-put 'defmacro 'doc-string-elt 3) (function-put 'defmacro 'lisp-indent-function 2) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index b3197a9702..7ddca19626 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -460,12 +460,6 @@ Filled in `cconv-analyze-form' but initialized and consulted here.") (defvar byte-compiler-error-flag) -(defvar byte-compile--form-stack nil - "Dynamic list of successive enclosing forms. -This is used by the warning message routines to determine a -source code position. The most accessible element is the current -most deeply nested form.") - (defun byte-compile-recurse-toplevel (form non-toplevel-case) "Implement `eval-when-compile' and `eval-and-compile'. Return the compile-time value of FORM." @@ -506,9 +500,8 @@ Return the compile-time value of FORM." byte-compile-new-defuns)) (setf result (byte-compile-eval - (macroexp-strip-symbol-positions (byte-compile-top-level - (byte-compile-preprocess form)))))))) + (byte-compile-preprocess form))))))) (list 'quote result)))) (eval-and-compile . ,(lambda (&rest body) (byte-compile-recurse-toplevel @@ -517,10 +510,11 @@ Return the compile-time value of FORM." ;; Don't compile here, since we don't know ;; whether to compile as byte-compile-form ;; or byte-compile-file-form. - (let ((expanded - (macroexpand--all-toplevel - form - macroexpand-all-environment))) + (let* ((print-symbols-bare t) + (expanded + (macroexpand--all-toplevel + form + macroexpand-all-environment))) (eval expanded lexical-binding) expanded))))) (with-suppressed-warnings @@ -1248,10 +1242,10 @@ Here, \"first\" is by a depth first search." (t 0)))) (defun byte-compile--warning-source-offset () - "Return a source offset from `byte-compile--form-stack'. + "Return a source offset from `byte-compile-form-stack'. Return nil if such is not found." (catch 'offset - (dolist (form byte-compile--form-stack) + (dolist (form byte-compile-form-stack) (let ((s (byte-compile--first-symbol form))) (if (symbol-with-pos-p s) (throw 'offset (symbol-with-pos-pos s))))))) @@ -1406,7 +1400,6 @@ function directly; use `byte-compile-warn' or (defun byte-compile-warn (format &rest args) "Issue a byte compiler warning; use (format-message FORMAT ARGS...) for message." - (setq args (mapcar #'macroexp-strip-symbol-positions args)) (setq format (apply #'format-message format args)) (if byte-compile-error-on-warn (error "%s" format) ; byte-compile-file catches and logs it @@ -1417,7 +1410,7 @@ function directly; use `byte-compile-warn' or ARG is the source element (likely a symbol with position) central to the warning, intended to supply source position information. FORMAT and ARGS are as in `byte-compile-warn'." - (let ((byte-compile--form-stack (cons arg byte-compile--form-stack))) + (let ((byte-compile-form-stack (cons arg byte-compile-form-stack))) (apply #'byte-compile-warn format args))) (defun byte-compile-warn-obsolete (symbol) @@ -1867,7 +1860,8 @@ It is too wide if it has any lines longer than the largest of (warning-series-started (and (markerp warning-series) (eq (marker-buffer warning-series) - (get-buffer byte-compile-log-buffer))))) + (get-buffer byte-compile-log-buffer)))) + (byte-compile-form-stack byte-compile-form-stack)) (if (or (eq warning-series 'byte-compile-warning-series) warning-series-started) ;; warning-series does come from compilation, @@ -2257,10 +2251,7 @@ See also `emacs-lisp-byte-compile-and-load'." (write-region (point-min) (point-max) dynvar-file))))) (if load (load target-file)) - t))) - ;; Strip positions from symbols for the native compiler. - (setq byte-to-native-top-level-forms - (macroexp-strip-symbol-positions byte-to-native-top-level-forms)))) + t))))) ;;; compiling a single function ;;;###autoload @@ -2272,7 +2263,8 @@ With argument ARG, insert value in current buffer after the form." (save-excursion (end-of-defun) (beginning-of-defun) - (let* ((byte-compile-current-file (current-buffer)) + (let* ((print-symbols-bare t) + (byte-compile-current-file (current-buffer)) (byte-compile-current-buffer (current-buffer)) (byte-compile-read-position (point)) (byte-compile-last-position byte-compile-read-position) @@ -2319,7 +2311,7 @@ With argument ARG, insert value in current buffer after the form." (read-symbol-positions-list nil) ;; #### This is bound in b-c-close-variables. ;; (byte-compile-warnings byte-compile-warnings) - ) + (symbols-with-pos-enabled t)) (byte-compile-close-variables (with-current-buffer (setq byte-compile--outbuffer @@ -2432,11 +2424,10 @@ Call from the source buffer." ;; it here. (when byte-native-compiling ;; Spill output for the native compiler here - (push - (macroexp-strip-symbol-positions - (make-byte-to-native-top-level :form form :lexical lexical-binding)) - byte-to-native-top-level-forms)) - (let ((print-escape-newlines t) + (push (make-byte-to-native-top-level :form form :lexical lexical-binding) + byte-to-native-top-level-forms)) + (let ((print-symbols-bare t) + (print-escape-newlines t) (print-length nil) (print-level nil) (print-quoted t) @@ -2471,8 +2462,8 @@ list that represents a doc string reference. ;; in the input buffer (now current), not in the output buffer. (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) (with-current-buffer byte-compile--outbuffer - (let (position) - + (let (position + (print-symbols-bare t)) ;; Insert the doc string, and make it a comment with #@LENGTH. (and (>= (nth 1 info) 0) dynamic-docstrings @@ -2596,13 +2587,16 @@ list that represents a doc string reference. ;; byte-hunk-handlers cannot call this! (defun byte-compile-toplevel-file-form (top-level-form) - (let ((byte-compile--form-stack - (cons top-level-form byte-compile--form-stack))) - (byte-compile-recurse-toplevel - top-level-form - (lambda (form) - (let ((byte-compile-current-form nil)) ; close over this for warnings. - (byte-compile-file-form (byte-compile-preprocess form t))))))) + ;; (let ((byte-compile-form-stack + ;; (cons top-level-form byte-compile-form-stack))) + (push top-level-form byte-compile-form-stack) + (prog1 + (byte-compile-recurse-toplevel + top-level-form + (lambda (form) + (let ((byte-compile-current-form nil)) ; close over this for warnings. + (byte-compile-file-form (byte-compile-preprocess form t))))) + (pop byte-compile-form-stack))) ;; byte-hunk-handlers can call this. (defun byte-compile-file-form (form) @@ -2635,8 +2629,7 @@ list that represents a doc string reference. ;; byte-compile-noruntime-functions, in case we have an autoload ;; of foo-func following an (eval-when-compile (require 'foo)). (unless (fboundp funsym) - (push (macroexp-strip-symbol-positions - (cons funsym (cons 'autoload (cdr (cdr form))))) + (push (cons funsym (cons 'autoload (cdr (cdr form)))) byte-compile-function-environment)) ;; If an autoload occurs _before_ the first call to a function, ;; byte-compile-callargs-warn does not add an entry to @@ -2652,7 +2645,8 @@ list that represents a doc string reference. (delq (assq funsym byte-compile-unresolved-functions) byte-compile-unresolved-functions))))) (if (stringp (nth 3 form)) - (prog1 (macroexp-strip-symbol-positions form) + (prog1 + form (byte-compile-docstring-length-warn form)) ;; No doc string, so we can compile this as a normal form. (byte-compile-keep-pending form 'byte-compile-normal-call))) @@ -2692,8 +2686,7 @@ list that represents a doc string reference. (byte-compile-top-level (nth 2 form) nil 'file))) ((symbolp (nth 2 form)) (setcar (cddr form) (bare-symbol (nth 2 form)))) - (t (setcar (cddr form) - (macroexp-strip-symbol-positions (nth 2 form))))) + (t (setcar (cddr form) (nth 2 form)))) (setcar form (bare-symbol (car form))) (if (symbolp (nth 1 form)) (setcar (cdr form) (bare-symbol (nth 1 form)))) @@ -2775,8 +2768,7 @@ list that represents a doc string reference. (defun byte-compile-file-form-make-obsolete (form) (prog1 (byte-compile-keep-pending form) (apply 'make-obsolete - (mapcar 'eval - (macroexp-strip-symbol-positions (cdr form)))))) + (mapcar 'eval (cdr form))))) (defun byte-compile-file-form-defmumble (name macro arglist body rest) "Process a `defalias' for NAME. @@ -2894,14 +2886,13 @@ not to take responsibility for the actual compilation of the code." (when byte-native-compiling ;; Spill output for the native compiler here. (push - (macroexp-strip-symbol-positions (if macro (make-byte-to-native-top-level :form `(defalias ',name '(macro . ,code) nil) :lexical lexical-binding) (make-byte-to-native-func-def :name name - :byte-func code))) - byte-to-native-top-level-forms)) + :byte-func code)) + byte-to-native-top-level-forms)) ;; Output the form by hand, that's much simpler than having ;; b-c-output-file-form analyze the defalias. (byte-compile-output-docform @@ -3020,9 +3011,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." (setq fun (eval fun t))) (if macro (push 'macro fun)) (if (symbolp form) (fset form fun)) - fun))) - (setq byte-to-native-top-level-forms - (macroexp-strip-symbol-positions byte-to-native-top-level-forms))))))) + fun)))))))) (defun byte-compile-sexp (sexp) "Compile and return SEXP." @@ -3169,8 +3158,7 @@ for symbols generated by the byte compiler itself." ;; which may include "calls" to ;; internal-make-closure (Bug#29988). lexical-binding) - (setq int (macroexp-strip-symbol-positions `(interactive ,newform))) - (setq int (macroexp-strip-symbol-positions int))))) + (setq int `(interactive ,newform))))) ((cdr int) ; Invalid (interactive . something). (byte-compile-warn-x int "malformed interactive spec: %s" int)))) @@ -3185,7 +3173,7 @@ for symbols generated by the byte compiler itself." (byte-compile-make-lambda-lexenv arglistvars)) reserved-csts)) - (bare-arglist (macroexp-strip-symbol-positions arglist))) + (bare-arglist arglist)) ;; Build the actual byte-coded function. (cl-assert (eq 'byte-code (car-safe compiled))) (let ((out @@ -3208,9 +3196,7 @@ for symbols generated by the byte compiler itself." (cond ;; We have some command modes, so use the vector form. (command-modes - (list (vector (nth 1 int) - (macroexp-strip-symbol-positions - command-modes)))) + (list (vector (nth 1 int) command-modes))) ;; No command modes, use the simple form with just the ;; interactive spec. (int @@ -3425,8 +3411,8 @@ for symbols generated by the byte compiler itself." ;; byte-compile--for-effect flag too.) ;; (defun byte-compile-form (form &optional for-effect) - (let ((byte-compile--for-effect for-effect) - (byte-compile--form-stack (cons form byte-compile--form-stack))) + (let ((byte-compile--for-effect for-effect)) + (push form byte-compile-form-stack) (cond ((not (consp form)) (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form)) @@ -3500,7 +3486,8 @@ for symbols generated by the byte compiler itself." (setq byte-compile--for-effect nil)) ((byte-compile-normal-call form))) (if byte-compile--for-effect - (byte-compile-discard)))) + (byte-compile-discard)) + (pop byte-compile-form-stack))) (defun byte-compile-normal-call (form) (when (and (symbolp (car form)) @@ -3756,8 +3743,7 @@ assignment (i.e. `setq')." (setq const (bare-symbol const))) (byte-compile-out 'byte-constant - (byte-compile-get-constant - (macroexp-strip-symbol-positions const)))) + (byte-compile-get-constant const))) ;; Compile those primitive ordinary functions ;; which have special byte codes just for speed. @@ -4591,7 +4577,7 @@ Return (TAIL VAR TEST CASES), where: (dolist (case cases) (setq tag (byte-compile-make-tag) - test-objects (macroexp-strip-symbol-positions (car case)) + test-objects (car case) body (cdr case)) (byte-compile-out-tag tag) (dolist (value test-objects) @@ -5241,9 +5227,9 @@ OP and OPERAND are as passed to `byte-compile-out'." ;;; call tree stuff (defun byte-compile-annotate-call-tree (form) - (let ((current-form (macroexp-strip-symbol-positions + (let ((current-form (byte-run-strip-symbol-positions byte-compile-current-form)) - (bare-car-form (macroexp-strip-symbol-positions (car form))) + (bare-car-form (byte-run-strip-symbol-positions (car form))) entry) ;; annotate the current call (if (setq entry (assq bare-car-form byte-compile-call-tree)) @@ -5463,8 +5449,6 @@ already up-to-date." (if (null (batch-byte-compile-file (car command-line-args-left))) (setq error t)))) (setq command-line-args-left (cdr command-line-args-left))) - (setq byte-to-native-top-level-forms - (macroexp-strip-symbol-positions byte-to-native-top-level-forms)) (kill-emacs (if error 1 0)))) (defun batch-byte-compile-file (file) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index ecfa8801bf..470168177c 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3517,9 +3517,8 @@ and then returning foo." `(eval-and-compile ;; Name the compiler-macro function, so that `symbol-file' can find it. (cl-defun ,fname ,(if (memq '&whole args) (delq '&whole args) - (cons '_cl-whole-arg - (macroexp-strip-symbol-positions args))) - ,@(macroexp-strip-symbol-positions body)) + (cons '_cl-whole-arg args)) + ,@body) (put ',func 'compiler-macro #',fname)))) ;;;###autoload diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 225272f020..dd5ad5a440 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -4004,7 +4004,9 @@ the deferred compilation mechanism." (signal 'native-compiler-error (list "Not a function symbol or file" function-or-file))) (catch 'no-native-compile - (let* ((data function-or-file) + (let* ((print-symbols-bare t) + (max-specpdl-size (max max-specpdl-size 5000)) + (data function-or-file) (comp-native-compiling t) (byte-native-qualities nil) (symbols-with-pos-enabled t) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 663856a8fb..faf0b1619e 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -28,82 +28,21 @@ ;;; Code: +(defvar byte-compile-form-stack nil + "Dynamic list of successive enclosing forms. +This is used by the warning message routines to determine a +source code position. The most accessible element is the current +most deeply nested form. + +Normally a form is manually pushed onto the list at the beginning +of `byte-compile-form', etc., and manually popped off at its end. +This is to preserve the data in it in the event of a +condition-case handling a signaled error.") + ;; Bound by the top-level `macroexpand-all', and modified to include any ;; macros defined by `defmacro'. (defvar macroexpand-all-environment nil) -(defvar macroexp--ssp-conses-seen nil - "Which conses have been processed in a strip-symbol-positions operation?") -(defvar macroexp--ssp-vectors-seen nil - "Which vectors have been processed in a strip-symbol-positions operation?") -(defvar macroexp--ssp-records-seen nil - "Which records have been processed in a strip-symbol-positions operation?") - -(defun macroexp--strip-s-p-2 (arg) - "Strip all positions from symbols in ARG, destructively modifying ARG. -Return the modified ARG." - (cond - ((symbolp arg) - (bare-symbol arg)) - ((consp arg) - (unless (and macroexp--ssp-conses-seen - (gethash arg macroexp--ssp-conses-seen)) - (if macroexp--ssp-conses-seen - (puthash arg t macroexp--ssp-conses-seen)) - (let ((a arg)) - (while (consp (cdr a)) - (setcar a (macroexp--strip-s-p-2 (car a))) - (setq a (cdr a))) - (setcar a (macroexp--strip-s-p-2 (car a))) - ;; (if (cdr a) - (unless (bare-symbol-p (cdr a)) ; includes (unpositioned) nil. - (setcdr a (macroexp--strip-s-p-2 (cdr a)))))) - arg) - ((vectorp arg) - (unless (and macroexp--ssp-vectors-seen - (gethash arg macroexp--ssp-vectors-seen)) - (if macroexp--ssp-vectors-seen - (puthash arg t macroexp--ssp-vectors-seen)) - (let ((i 0) - (len (length arg))) - (while (< i len) - (aset arg i (macroexp--strip-s-p-2 (aref arg i))) - (setq i (1+ i))))) - arg) - ((recordp arg) - (unless (and macroexp--ssp-records-seen - (gethash arg macroexp--ssp-records-seen)) - (if macroexp--ssp-records-seen - (puthash arg t macroexp--ssp-records-seen)) - (let ((i 0) - (len (length arg))) - (while (< i len) - (aset arg i (macroexp--strip-s-p-2 (aref arg i))) - (setq i (1+ i))))) - arg) - (t arg))) - -(defun byte-compile-strip-s-p-1 (arg) - "Strip all positions from symbols in ARG, destructively modifying ARG. -Return the modified ARG." - (condition-case err - (progn - (setq macroexp--ssp-conses-seen nil) - (setq macroexp--ssp-vectors-seen nil) - (setq macroexp--ssp-records-seen nil) - (macroexp--strip-s-p-2 arg)) - (recursion-error - (dolist (tab '(macroexp--ssp-conses-seen macroexp--ssp-vectors-seen - macroexp--ssp-records-seen)) - (set tab (make-hash-table :test 'eq))) - (macroexp--strip-s-p-2 arg)) - (error (signal (car err) (cdr err))))) - -(defun macroexp-strip-symbol-positions (arg) - "Strip all positions from symbols (recursively) in ARG. Don't modify ARG." - (let ((arg1 (copy-tree arg t))) - (byte-compile-strip-s-p-1 arg1))) - (defun macroexp--cons (car cdr original-cons) "Return ORIGINAL-CONS if the car/cdr of it is `eq' to CAR and CDR, respectively. If not, return (CAR . CDR)." @@ -378,120 +317,122 @@ Only valid during macro-expansion." "Expand all macros in FORM. This is an internal version of `macroexpand-all'. Assumes the caller has bound `macroexpand-all-environment'." - (if (eq (car-safe form) 'backquote-list*) - ;; Special-case `backquote-list*', as it is normally a macro that - ;; generates exceedingly deep expansions from relatively shallow input - ;; forms. We just process it `in reverse' -- first we expand all the - ;; arguments, _then_ we expand the top-level definition. - (macroexpand (macroexp--all-forms form 1) - macroexpand-all-environment) - ;; Normal form; get its expansion, and then expand arguments. - (setq form (macroexp-macroexpand form macroexpand-all-environment)) - ;; FIXME: It'd be nice to use `byte-optimize--pcase' here, but when - ;; I tried it, it broke the bootstrap :-( - (pcase form - (`(cond . ,clauses) - (macroexp--cons 'cond (macroexp--all-clauses clauses) form)) - (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare)) - (macroexp--cons - 'condition-case - (macroexp--cons err - (macroexp--cons (macroexp--expand-all body) - (macroexp--all-clauses handlers 1) - (cddr form)) - (cdr form)) - form)) - (`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_) - (push name macroexp--dynvars) - (macroexp--all-forms form 2)) - (`(function ,(and f `(lambda . ,_))) - (let ((macroexp--dynvars macroexp--dynvars)) - (macroexp--cons 'function - (macroexp--cons (macroexp--all-forms f 2) - nil - (cdr form)) - form))) - (`(,(or 'function 'quote) . ,_) form) - (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) - pcase--dontcare)) - (let ((macroexp--dynvars macroexp--dynvars)) - (macroexp--cons - fun - (macroexp--cons - (macroexp--all-clauses bindings 1) - (if (null body) - (macroexp-unprogn - (macroexp-warn-and-return - fun - (format "Empty %s body" fun) - nil nil 'compile-only)) - (macroexp--all-forms body)) - (cdr form)) - form))) - (`(,(and fun `(lambda . ,_)) . ,args) - ;; Embedded lambda in function position. - ;; If the byte-optimizer is loaded, try to unfold this, - ;; i.e. rewrite it to (let () ). We'd do it in the optimizer - ;; anyway, but doing it here (i.e. earlier) can sometimes avoid the - ;; creation of a closure, thus resulting in much better code. - (let ((newform (macroexp--unfold-lambda form))) - (if (eq newform form) - ;; Unfolding failed for some reason, avoid infinite recursion. - (macroexp--cons (macroexp--all-forms fun 2) - (macroexp--all-forms args) - form) - (macroexp--expand-all newform)))) - - (`(funcall . ,(or `(,exp . ,args) pcase--dontcare)) - (let ((eexp (macroexp--expand-all exp)) - (eargs (macroexp--all-forms args))) - ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' - ;; has a compiler-macro, or to unfold it. - (pcase eexp - (`#',f (macroexp--expand-all `(,f . ,eargs))) - (_ `(funcall ,eexp . ,eargs))))) - (`(,func . ,_) - (let ((handler (function-get func 'compiler-macro)) - (funargs (function-get func 'funarg-positions))) - ;; Check functions quoted with ' rather than with #' - (dolist (funarg funargs) - (let ((arg (nth funarg form))) - (when (and (eq 'quote (car-safe arg)) - (eq 'lambda (car-safe (cadr arg)))) - (setcar (nthcdr funarg form) - (macroexp-warn-and-return - (cadr arg) - (format "%S quoted with ' rather than with #'" - (let ((f (cadr arg))) - (if (symbolp f) f `(lambda ,(nth 1 f) ...)))) - arg))))) - ;; Macro expand compiler macros. This cannot be delayed to - ;; byte-optimize-form because the output of the compiler-macro can - ;; use macros. - (if (null handler) - ;; No compiler macro. We just expand each argument (for - ;; setq/setq-default this works alright because the variable names - ;; are symbols). - (macroexp--all-forms form 1) - ;; If the handler is not loaded yet, try (auto)loading the - ;; function itself, which may in turn load the handler. - (unless (functionp handler) - (with-demoted-errors "macroexp--expand-all: %S" - (autoload-do-load (indirect-function func) func))) - (let ((newform (macroexp--compiler-macro handler form))) - (if (eq form newform) - ;; The compiler macro did not find anything to do. - (if (equal form (setq newform (macroexp--all-forms form 1))) - form - ;; Maybe after processing the args, some new opportunities - ;; appeared, so let's try the compiler macro again. - (setq form (macroexp--compiler-macro handler newform)) - (if (eq newform form) - newform - (macroexp--expand-all newform))) - (macroexp--expand-all newform)))))) - - (_ form)))) + (push form byte-compile-form-stack) + (prog1 + (if (eq (car-safe form) 'backquote-list*) + ;; Special-case `backquote-list*', as it is normally a macro that + ;; generates exceedingly deep expansions from relatively shallow input + ;; forms. We just process it `in reverse' -- first we expand all the + ;; arguments, _then_ we expand the top-level definition. + (macroexpand (macroexp--all-forms form 1) + macroexpand-all-environment) + ;; Normal form; get its expansion, and then expand arguments. + (setq form (macroexp-macroexpand form macroexpand-all-environment)) + ;; FIXME: It'd be nice to use `byte-optimize--pcase' here, but when + ;; I tried it, it broke the bootstrap :-( + (pcase form + (`(cond . ,clauses) + (macroexp--cons 'cond (macroexp--all-clauses clauses) form)) + (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare)) + (macroexp--cons + 'condition-case + (macroexp--cons err + (macroexp--cons (macroexp--expand-all body) + (macroexp--all-clauses handlers 1) + (cddr form)) + (cdr form)) + form)) + (`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_) + (push name macroexp--dynvars) + (macroexp--all-forms form 2)) + (`(function ,(and f `(lambda . ,_))) + (let ((macroexp--dynvars macroexp--dynvars)) + (macroexp--cons 'function + (macroexp--cons (macroexp--all-forms f 2) + nil + (cdr form)) + form))) + (`(,(or 'function 'quote) . ,_) form) + (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) + pcase--dontcare)) + (let ((macroexp--dynvars macroexp--dynvars)) + (macroexp--cons + fun + (macroexp--cons + (macroexp--all-clauses bindings 1) + (if (null body) + (macroexp-unprogn + (macroexp-warn-and-return + fun + (format "Empty %s body" fun) + nil nil 'compile-only)) + (macroexp--all-forms body)) + (cdr form)) + form))) + (`(,(and fun `(lambda . ,_)) . ,args) + ;; Embedded lambda in function position. + ;; If the byte-optimizer is loaded, try to unfold this, + ;; i.e. rewrite it to (let () ). We'd do it in the optimizer + ;; anyway, but doing it here (i.e. earlier) can sometimes avoid the + ;; creation of a closure, thus resulting in much better code. + (let ((newform (macroexp--unfold-lambda form))) + (if (eq newform form) + ;; Unfolding failed for some reason, avoid infinite recursion. + (macroexp--cons (macroexp--all-forms fun 2) + (macroexp--all-forms args) + form) + (macroexp--expand-all newform)))) + (`(funcall . ,(or `(,exp . ,args) pcase--dontcare)) + (let ((eexp (macroexp--expand-all exp)) + (eargs (macroexp--all-forms args))) + ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' + ;; has a compiler-macro, or to unfold it. + (pcase eexp + (`#',f (macroexp--expand-all `(,f . ,eargs))) + (_ `(funcall ,eexp . ,eargs))))) + (`(,func . ,_) + (let ((handler (function-get func 'compiler-macro)) + (funargs (function-get func 'funarg-positions))) + ;; Check functions quoted with ' rather than with #' + (dolist (funarg funargs) + (let ((arg (nth funarg form))) + (when (and (eq 'quote (car-safe arg)) + (eq 'lambda (car-safe (cadr arg)))) + (setcar (nthcdr funarg form) + (macroexp-warn-and-return + (cadr arg) + (format "%S quoted with ' rather than with #'" + (let ((f (cadr arg))) + (if (symbolp f) f `(lambda ,(nth 1 f) ...)))) + arg))))) + ;; Macro expand compiler macros. This cannot be delayed to + ;; byte-optimize-form because the output of the compiler-macro can + ;; use macros. + (if (null handler) + ;; No compiler macro. We just expand each argument (for + ;; setq/setq-default this works alright because the variable names + ;; are symbols). + (macroexp--all-forms form 1) + ;; If the handler is not loaded yet, try (auto)loading the + ;; function itself, which may in turn load the handler. + (unless (functionp handler) + (with-demoted-errors "macroexp--expand-all: %S" + (autoload-do-load (indirect-function func) func))) + (let ((newform (macroexp--compiler-macro handler form))) + (if (eq form newform) + ;; The compiler macro did not find anything to do. + (if (equal form (setq newform (macroexp--all-forms form 1))) + form + ;; Maybe after processing the args, some new opportunities + ;; appeared, so let's try the compiler macro again. + (setq form (macroexp--compiler-macro handler newform)) + (if (eq newform form) + newform + (macroexp--expand-all newform))) + (macroexp--expand-all newform)))))) + + (_ form))) + (pop byte-compile-form-stack))) ;; Record which arguments expect functions, so we can warn when those ;; are accidentally quoted with ' rather than with #' @@ -781,39 +722,40 @@ test of free variables in the following ways: (defun internal-macroexpand-for-load (form full-p) ;; Called from the eager-macroexpansion in readevalloop. - (setq form (macroexp-strip-symbol-positions form)) - (cond - ;; Don't repeat the same warning for every top-level element. - ((eq 'skip (car macroexp--pending-eager-loads)) form) - ;; If we detect a cycle, skip macro-expansion for now, and output a warning - ;; with a trimmed backtrace. - ((and load-file-name (member load-file-name macroexp--pending-eager-loads)) - (let* ((bt (delq nil - (mapcar #'macroexp--trim-backtrace-frame - (macroexp--backtrace)))) - (elem `(load ,(file-name-nondirectory load-file-name))) - (tail (member elem (cdr (member elem bt))))) - (if tail (setcdr tail (list '…))) - (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt))) - (if macroexp--debug-eager - (debug 'eager-macroexp-cycle) - (message "Warning: Eager macro-expansion skipped due to cycle:\n %s" - (mapconcat #'prin1-to-string (nreverse bt) " => "))) - (push 'skip macroexp--pending-eager-loads) - form)) - (t - (condition-case err - (let ((macroexp--pending-eager-loads - (cons load-file-name macroexp--pending-eager-loads))) - (if full-p - (macroexpand--all-toplevel form) - (macroexpand form))) - (error - ;; Hopefully this shouldn't happen thanks to the cycle detection, - ;; but in case it does happen, let's catch the error and give the - ;; code a chance to macro-expand later. - (message "Eager macro-expansion failure: %S" err) - form))))) + (let ((symbols-with-pos-enabled t) + (print-symbols-bare t)) + (cond + ;; Don't repeat the same warning for every top-level element. + ((eq 'skip (car macroexp--pending-eager-loads)) form) + ;; If we detect a cycle, skip macro-expansion for now, and output a warning + ;; with a trimmed backtrace. + ((and load-file-name (member load-file-name macroexp--pending-eager-loads)) + (let* ((bt (delq nil + (mapcar #'macroexp--trim-backtrace-frame + (macroexp--backtrace)))) + (elem `(load ,(file-name-nondirectory load-file-name))) + (tail (member elem (cdr (member elem bt))))) + (if tail (setcdr tail (list '…))) + (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt))) + (if macroexp--debug-eager + (debug 'eager-macroexp-cycle) + (message "Warning: Eager macro-expansion skipped due to cycle:\n %s" + (mapconcat #'prin1-to-string (nreverse bt) " => "))) + (push 'skip macroexp--pending-eager-loads) + form)) + (t + (condition-case err + (let ((macroexp--pending-eager-loads + (cons load-file-name macroexp--pending-eager-loads))) + (if full-p + (macroexpand--all-toplevel form) + (macroexpand form))) + (error + ;; Hopefully this shouldn't happen thanks to the cycle detection, + ;; but in case it does happen, let's catch the error and give the + ;; code a chance to macro-expand later. + (message "Eager macro-expansion failure: %S" err) + form)))))) ;; ¡¡¡ Big Ugly Hack !!! ;; src/bootstrap-emacs is mostly used to compile .el files, so it needs diff --git a/lisp/help.el b/lisp/help.el index b142cce845..983f39479c 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -2069,7 +2069,7 @@ the same names as used in the original source code, when possible." ((symbolp arg) (let ((name (symbol-name arg))) (cond - ((string-match "\\`&" name) arg) + ((string-match "\\`&" name) (bare-symbol arg)) ((string-match "\\`_." name) (intern (upcase (substring name 1)))) (t (intern (upcase name)))))) diff --git a/src/fns.c b/src/fns.c index 9f39d56dd3..ade30fca41 100644 --- a/src/fns.c +++ b/src/fns.c @@ -2414,11 +2414,6 @@ It can be retrieved with `(get SYMBOL PROPNAME)'. */) (Lisp_Object symbol, Lisp_Object propname, Lisp_Object value) { CHECK_SYMBOL (symbol); - if (symbols_with_pos_enabled) - { - propname = call1 (intern ("macroexp-strip-symbol-positions"), propname); - value = call1 (intern ("macroexp-strip-symbol-positions"), value); - } set_symbol_plist (symbol, Fplist_put (XSYMBOL (symbol)->u.s.plist, propname, value)); return value; commit 2128cd8c08da84ab40608ac5db0fecfce733cfad Merge: 4e77177b06 18dac47255 Author: Alan Mackenzie Date: Tue Jan 11 21:57:54 2022 +0000 Merge branch 'master' into scratch/correct-warning-pos commit 4e77177b063f9da8a48709aa3ef416d0ac21837b Author: Alan Mackenzie Date: Fri Dec 31 23:17:28 2021 +0000 Try to make scratch/correct-warning-pos build on Windows and not segfault * src/comp.c (emit_EQ): Replace calls to gcc_jit_context_new_location with NULLs. (Fcomp__init_ctxt): Remove the register_emitter call for Qsymbol_with_pos_p, which was causing a segfault. diff --git a/src/comp.c b/src/comp.c index 834656897e..73555c0d2c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1490,13 +1490,13 @@ emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) return emit_OR ( gcc_jit_context_new_comparison ( - comp.ctxt, gcc_jit_context_new_location (comp.ctxt, "comp.c", __LINE__, 0), + comp.ctxt, NULL, GCC_JIT_COMPARISON_EQ, emit_XLI (x), emit_XLI (y)), emit_AND ( gcc_jit_lvalue_as_rvalue ( gcc_jit_rvalue_dereference (comp.f_symbols_with_pos_enabled_ref, - gcc_jit_context_new_location (comp.ctxt, "comp.c", __LINE__, 0))), + NULL)), emit_OR ( emit_AND ( emit_SYMBOL_WITH_POS_P (x), @@ -4561,7 +4561,6 @@ Return t on success. */) register_emitter (Qnumberp, emit_numperp); register_emitter (Qintegerp, emit_integerp); register_emitter (Qcomp_maybe_gc_or_quit, emit_maybe_gc_or_quit); - register_emitter (Qsymbol_with_pos_p, emit_SYMBOL_WITH_POS_P); } comp.ctxt = gcc_jit_context_acquire (); commit ff9af1f1f69264bcbb7b926363293e55a6b3f330 Author: Alan Mackenzie Date: Fri Dec 31 21:21:46 2021 +0000 Miscellaneous enhancements to scratch/correct-warning-pos. 1. Check the type (symbol with position) of the argument given to the native compiled version of SYMBOL_WITH_POS_SYM. 2. Handle infinite recursion caused by circular lists, etc., in macroexp-strip-symbol-positions by using hash tables. 3. Read byte compiled functions without giving symbols positions. * lisp/emacs-lisp/comp.el (comp-finalize-relocs): Add symbol-with-pos-p into the list of relocated symbols. * lisp/emacs-lisp/macroexp.el (macroexp--ssp-conses-seen) (macroexp--ssp-vectors-seen, macroexp--ssp-records-seen): Renamed, and animated as hash tables. (macroexp--strip-s-p-2): Optionally tests for the presence of an argument in one of the above hash tables, so as to handle otherwise infinite recursion. (byte-compile-strip-s-p-1): Add a condition-case to handle infinite recursion caused by circular lists etc., using the above hash tables as required. * src/comp.c (comp_t): New element symbol_with_pos_sym. (emit_SYMBOL_WITH_POS_SYM): Amend just to call the new SYMBOL_WITH_POS_SYM. (emit_CHECK_SYMBOL_WITH_POS, define_SYMBOL_WITH_POS_SYM): New functions. (Fcomp__init_ctxt): Register an emitter for Qsymbol_with_pos_p. (Fcomp__compile_ctxt_to_file): Call define_SYMBOL_WITH_POS_SYM. (syms_of_comp): Define Qsymbol_with_pos_p. * src/data.c (syms_of_data): Define a new error symbol Qrecursion_error, an error category for the new error symbols Qexcessive_variable_binding and Qexcessive_lisp_nesting. * src/eval.c (grow_specpdl): Change the signal_error call to an xsignal0 call using the new error symbol Qexcessive_variable_binding. (eval_sub, Ffuncall): Change the `error' calls to xsignal using the new error symbol Qexcessive_lisp_nesting. * src/lread.c (read1): When reading a compiled function, read the components of the vector without giving its symbols a position. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8581fe8066..1912d0d003 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3576,7 +3576,7 @@ Update all insn accordingly." ;; Symbols imported by C inlined functions. We do this here because ;; is better to add all objs to the relocation containers before we ;; compacting them. - (mapc #'comp-add-const-to-relocs '(nil t consp listp)) + (mapc #'comp-add-const-to-relocs '(nil t consp listp symbol-with-pos-p)) (let* ((d-default (comp-ctxt-d-default comp-ctxt)) (d-default-idx (comp-data-container-idx d-default)) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index dafd549763..11204f7f7f 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -32,11 +32,11 @@ ;; macros defined by `defmacro'. (defvar macroexpand-all-environment nil) -(defvar byte-compile--ssp-conses-seen nil +(defvar macroexp--ssp-conses-seen nil "Which conses have been processed in a strip-symbol-positions operation?") -(defvar byte-compile--ssp-vectors-seen nil +(defvar macroexp--ssp-vectors-seen nil "Which vectors have been processed in a strip-symbol-positions operation?") -(defvar byte-compile--ssp-records-seen nil +(defvar macroexp--ssp-records-seen nil "Which records have been processed in a strip-symbol-positions operation?") (defun macroexp--strip-s-p-2 (arg) @@ -46,8 +46,10 @@ Return the modified ARG." ((symbolp arg) (bare-symbol arg)) ((consp arg) - (unless (memq arg byte-compile--ssp-conses-seen) - ;; (push arg byte-compile--ssp-conses-seen) + (unless (and macroexp--ssp-conses-seen + (gethash arg macroexp--ssp-conses-seen)) + (if macroexp--ssp-conses-seen + (puthash arg t macroexp--ssp-conses-seen)) (let ((a arg)) (while (consp (cdr a)) (setcar a (macroexp--strip-s-p-2 (car a))) @@ -58,8 +60,10 @@ Return the modified ARG." (setcdr a (macroexp--strip-s-p-2 (cdr a)))))) arg) ((vectorp arg) - (unless (memq arg byte-compile--ssp-vectors-seen) - (push arg byte-compile--ssp-vectors-seen) + (unless (and macroexp--ssp-vectors-seen + (gethash arg macroexp--ssp-vectors-seen)) + (if macroexp--ssp-vectors-seen + (puthash arg t macroexp--ssp-vectors-seen)) (let ((i 0) (len (length arg))) (while (< i len) @@ -67,8 +71,10 @@ Return the modified ARG." (setq i (1+ i))))) arg) ((recordp arg) - (unless (memq arg byte-compile--ssp-records-seen) - (push arg byte-compile--ssp-records-seen) + (unless (and macroexp--ssp-records-seen + (gethash arg macroexp--ssp-records-seen)) + (if macroexp--ssp-records-seen + (puthash arg t macroexp--ssp-records-seen)) (let ((i 0) (len (length arg))) (while (< i len) @@ -80,10 +86,18 @@ Return the modified ARG." (defun byte-compile-strip-s-p-1 (arg) "Strip all positions from symbols in ARG, destructively modifying ARG. Return the modified ARG." - (setq byte-compile--ssp-conses-seen nil) - (setq byte-compile--ssp-vectors-seen nil) - (setq byte-compile--ssp-records-seen nil) - (macroexp--strip-s-p-2 arg)) + (condition-case err + (progn + (setq macroexp--ssp-conses-seen nil) + (setq macroexp--ssp-vectors-seen nil) + (setq macroexp--ssp-records-seen nil) + (macroexp--strip-s-p-2 arg)) + (recursion-error + (dolist (tab '(macroexp--ssp-conses-seen macroexp--ssp-vectors-seen + macroexp--ssp-records-seen)) + (set tab (make-hash-table :test 'eq))) + (macroexp--strip-s-p-2 arg)) + (error (signal (car err) (cdr err))))) (defun macroexp-strip-symbol-positions (arg) "Strip all positions from symbols (recursively) in ARG. Don't modify ARG." diff --git a/src/comp.c b/src/comp.c index ac38c2131f..834656897e 100644 --- a/src/comp.c +++ b/src/comp.c @@ -574,6 +574,7 @@ typedef struct { gcc_jit_type *lisp_symbol_with_position_type; gcc_jit_type *lisp_symbol_with_position_ptr_type; gcc_jit_function *get_symbol_with_position; + gcc_jit_function *symbol_with_pos_sym; /* struct jmp_buf. */ gcc_jit_struct *jmp_buf_s; /* struct handler. */ @@ -1475,21 +1476,12 @@ emit_SYMBOL_WITH_POS_SYM (gcc_jit_rvalue *obj) { emit_comment ("SYMBOL_WITH_POS_SYM"); - gcc_jit_rvalue *tmp2, *swp; - gcc_jit_lvalue *tmpl; - - gcc_jit_rvalue *args[] = { obj }; - swp = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.get_symbol_with_position, - 1, - args); - tmpl = gcc_jit_rvalue_dereference (swp, gcc_jit_context_new_location (comp.ctxt, "comp.c", __LINE__, 0)); - tmp2 = gcc_jit_lvalue_as_rvalue (tmpl); - return - gcc_jit_rvalue_access_field (tmp2, - NULL, - comp.lisp_symbol_with_position_sym); + gcc_jit_rvalue *arg [] = { obj }; + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.symbol_with_pos_sym, + 1, + arg); } static gcc_jit_rvalue * @@ -1858,6 +1850,29 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) args)); } +static void +emit_CHECK_SYMBOL_WITH_POS (gcc_jit_rvalue *x) +{ + emit_comment ("CHECK_SYMBOL_WITH_POS"); + + gcc_jit_rvalue *args[] = + { gcc_jit_context_new_cast (comp.ctxt, + NULL, + emit_SYMBOL_WITH_POS_P (x), + comp.int_type), + emit_lisp_obj_rval (Qsymbol_with_pos_p), + x }; + + gcc_jit_block_add_eval ( + comp.block, + NULL, + gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.check_type, + 3, + args)); +} + static gcc_jit_rvalue * emit_car_addr (gcc_jit_rvalue *c) { @@ -3886,6 +3901,48 @@ define_GET_SYMBOL_WITH_POSITION (void) 1, args, false)); } +static void define_SYMBOL_WITH_POS_SYM (void) +{ + gcc_jit_rvalue *tmpr, *swp; + gcc_jit_lvalue *tmpl; + + gcc_jit_param *param [] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "a") }; + comp.symbol_with_pos_sym = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_INTERNAL, + comp.lisp_obj_type, + "SYMBOL_WITH_POS_SYM", + 1, + param, + 0); + + DECL_BLOCK (entry_block, comp.symbol_with_pos_sym); + comp.func = comp.symbol_with_pos_sym; + comp.block = entry_block; + + emit_CHECK_SYMBOL_WITH_POS (gcc_jit_param_as_rvalue (param [0])); + + gcc_jit_rvalue *args[] = { gcc_jit_param_as_rvalue (param [0]) }; + + swp = gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.get_symbol_with_position, + 1, + args); + tmpl = gcc_jit_rvalue_dereference (swp, NULL); + tmpr = gcc_jit_lvalue_as_rvalue (tmpl); + gcc_jit_block_end_with_return (entry_block, + NULL, + gcc_jit_rvalue_access_field ( + tmpr, + NULL, + comp.lisp_symbol_with_position_sym)); +} + static void define_CHECK_IMPURE (void) { @@ -4504,6 +4561,7 @@ Return t on success. */) register_emitter (Qnumberp, emit_numperp); register_emitter (Qintegerp, emit_integerp); register_emitter (Qcomp_maybe_gc_or_quit, emit_maybe_gc_or_quit); + register_emitter (Qsymbol_with_pos_p, emit_SYMBOL_WITH_POS_P); } comp.ctxt = gcc_jit_context_acquire (); @@ -4820,6 +4878,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, define_PSEUDOVECTORP (); define_GET_SYMBOL_WITH_POSITION (); define_CHECK_TYPE (); + define_SYMBOL_WITH_POS_SYM (); define_CHECK_IMPURE (); define_bool_to_lisp_obj (); define_setcar_setcdr (); @@ -5618,6 +5677,7 @@ compiled one. */); DEFSYM (Qnumberp, "numberp"); DEFSYM (Qintegerp, "integerp"); DEFSYM (Qcomp_maybe_gc_or_quit, "comp-maybe-gc-or-quit"); + DEFSYM (Qsymbol_with_pos_p, "symbol-with-pos-p"); /* Allocation classes. */ DEFSYM (Qd_default, "d-default"); diff --git a/src/data.c b/src/data.c index 1f2af6f474..6d9c0aef93 100644 --- a/src/data.c +++ b/src/data.c @@ -3969,7 +3969,7 @@ A is a bool vector, B is t or nil, and I is an index into A. */) void syms_of_data (void) { - Lisp_Object error_tail, arith_tail; + Lisp_Object error_tail, arith_tail, recursion_tail; DEFSYM (Qquote, "quote"); DEFSYM (Qlambda, "lambda"); @@ -4004,6 +4004,10 @@ syms_of_data (void) DEFSYM (Qmark_inactive, "mark-inactive"); DEFSYM (Qinhibited_interaction, "inhibited-interaction"); + DEFSYM (Qrecursion_error, "recursion-error"); + DEFSYM (Qexcessive_variable_binding, "excessive-variable-binding"); + DEFSYM (Qexcessive_lisp_nesting, "excessive-lisp-nesting"); + DEFSYM (Qlistp, "listp"); DEFSYM (Qconsp, "consp"); DEFSYM (Qbare_symbol_p, "bare-symbol-p"); @@ -4112,6 +4116,16 @@ syms_of_data (void) PUT_ERROR (Qunderflow_error, Fcons (Qrange_error, arith_tail), "Arithmetic underflow error"); + recursion_tail = pure_cons (Qrecursion_error, error_tail); + Fput (Qrecursion_error, Qerror_conditions, recursion_tail); + Fput (Qrecursion_error, Qerror_message, build_pure_c_string + ("Excessive recursive calling error")); + + PUT_ERROR (Qexcessive_variable_binding, recursion_tail, + "Variable binding depth exceeds max-specpdl-size"); + PUT_ERROR (Qexcessive_lisp_nesting, recursion_tail, + "Lisp nesting exceeds `max-lisp-eval-depth'"); + /* Types that type-of returns. */ DEFSYM (Qinteger, "integer"); DEFSYM (Qsymbol, "symbol"); diff --git a/src/eval.c b/src/eval.c index 94ad060773..5cb673ab22 100644 --- a/src/eval.c +++ b/src/eval.c @@ -2398,8 +2398,7 @@ grow_specpdl (void) if (max_specpdl_size < 400) max_size = max_specpdl_size = 400; if (max_size <= specpdl_size) - signal_error ("Variable binding depth exceeds max-specpdl-size", - Qnil); + xsignal0 (Qexcessive_variable_binding); } pdlvec = xpalloc (pdlvec, &pdlvecsize, 1, max_size + 1, sizeof *specpdl); specpdl = pdlvec + 1; @@ -2453,7 +2452,7 @@ eval_sub (Lisp_Object form) if (max_lisp_eval_depth < 100) max_lisp_eval_depth = 100; if (lisp_eval_depth > max_lisp_eval_depth) - error ("Lisp nesting exceeds `max-lisp-eval-depth'"); + xsignal0 (Qexcessive_lisp_nesting); } Lisp_Object original_fun = XCAR (form); @@ -3044,7 +3043,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) if (max_lisp_eval_depth < 100) max_lisp_eval_depth = 100; if (lisp_eval_depth > max_lisp_eval_depth) - error ("Lisp nesting exceeds `max-lisp-eval-depth'"); + xsignal0 (Qexcessive_lisp_nesting); } count = record_in_backtrace (args[0], &args[1], nargs - 1); diff --git a/src/lread.c b/src/lread.c index 1cc5acc6d3..835228439f 100644 --- a/src/lread.c +++ b/src/lread.c @@ -3225,7 +3225,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list, bool locate_syms) build them using function calls. */ Lisp_Object tmp; struct Lisp_Vector *vec; - tmp = read_vector (readcharfun, 1, locate_syms); + tmp = read_vector (readcharfun, 1, false); vec = XVECTOR (tmp); if (! (COMPILED_STACK_DEPTH < ASIZE (tmp) && (FIXNUMP (AREF (tmp, COMPILED_ARGLIST)) commit 1cd188799f86bcb13ad76e82e3436b1b7e9f9e9f Author: Alan Mackenzie Date: Thu Dec 30 10:14:58 2021 +0000 Make symbols with positions work with native compilation This version of the software should bootstrap Emacs successfully with native compilation enabled. * lisp/emacs-lisp/bytecomp.el (byte-compile-strip-s-p-1) (byte-compile-strip-symbol-positions): Rename and move to macroexp.el. Rename calls to these functions throughout the file. (byte-compile-initial-macro-environment): In the code sections for eval-when-compile and eval-and-compile, call macroexp-strip-symbol-positions before evaluating code. (byte-compile-file, byte-compile-output-file-form) (byte-compile-file-form-defmumble, byte-compile, batch-byte-compile): Call macroexp-strip-symbol-positions from code being passed to the native compiler. * lisp/emacs-lisp/cl-macs.el (cl-macs--strip-s-p-1) (cl-macs--strip-symbol-positions): Remove, replacing them with the renamed functions in macroexp.el. (cl-define-compiler-macro): Apply macroexp-strip-symbol-positions to ARGS and BODY. * lisp/emacs-lisp/comp.el (comp-limplify-lap-inst): Use `null' to compile byte-not rather than a compilation of `eq'. (comp--native-compile): bind symbols-with-pos-enabled to t. * lisp/emacs-lisp/macroexp.el (byte-compile--ssp-conses-seen) (byte-compile--ssp-vectors-seen, byte-compile--ssp-records-seen): Provisional auxiliary variables to support the following functions. (macroexp--strip-s-p-2, byte-compile-strip-s-p-1) (macroexp-strip-symbol-positions): Functions moved from bytecomp.el, renamed, and further developed. (macroexp--compiler-macro): Bind symbol-with-pos-enabled to t around the call to `handler'. (internal-macroexpand-for-load): Strip symbol positions from the form being eagerly expanded for macros. * src/comp.c (F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM): New macro for a relocation symbol. (comp_t): New elements bool_ptr_type, f_symbols_with_pos_enabled_ref, lisp_symbol_with_position, lisp_symbol_with_position_header, lisp_symbol_with_position_sym, lisp_symbol_with_position_pos, lisp_symbol_with_position_type, lisp_symbol_with_position_ptr_type, get_symbol_with_position. (helper_GET_SYMBOL_WITH_POSITION): New function. (emit_BASE_EQ): Function rename from emit_EQ. (emit_AND, emit_OR, emit_BARE_SYMBOL_P, emit_SYMBOL_WITH_POS_P) (emit_SYMBOL_WITH_POS_SYM): New functions. (emit_EQ): New function which handles symbols with position correctly. (emit_NILP): Use emit_BASE_EQ rather than emit_EQ. (emit_limple_insn): When emitting a conditional branch, check each operand for being a literal Qnil, and if one of them is, use emit_BASE_EQ rather than emit_EQ. (declare_runtime_imported_funcs): Declare helper_GET_SYMBOL_WITH_POSITION. (emit_ctxt_code): Export the global F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM. (define_lisp_symbol_with_position, define_GET_SYMBOL_WITH_POSITION): New functions. (Fcomp__init_ctxt): Initialise comp.bool_ptr_type, call the two new define_.... functions. (load_comp_unit): Initialise **f_symbols_with_pos_enabled_reloc. * src/fns.c (Fput): Strip positions from symbols in PROPNAME and VALUE. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 2f23fe743e..47b5d6ceca 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -465,36 +465,6 @@ This is used by the warning message routines to determine a source code position. The most accessible element is the current most deeply nested form.") -(defun byte-compile-strip-s-p-1 (arg) - "Strip all positions from symbols in ARG, destructively modifying ARG. -Return the modified ARG." - (cond - ((symbolp arg) - (bare-symbol arg)) - ((consp arg) - (let ((a arg)) - (while (consp (cdr a)) - (setcar a (byte-compile-strip-s-p-1 (car a))) - (setq a (cdr a))) - (setcar a (byte-compile-strip-s-p-1 (car a))) - ;; (if (cdr a) - (unless (bare-symbol-p (cdr a)) ; includes (unpositioned) nil. - (setcdr a (byte-compile-strip-s-p-1 (cdr a))))) - arg) - ((vectorp arg) - (let ((i 0) - (len (length arg))) - (while (< i len) - (aset arg i (byte-compile-strip-s-p-1 (aref arg i))) - (setq i (1+ i)))) - arg) - (t arg))) - -(defun byte-compile-strip-symbol-positions (arg) - "Strip all positions from symbols (recursively) in ARG. Don't modify ARG." - (let ((arg1 (copy-tree arg t))) - (byte-compile-strip-s-p-1 arg1))) - (defun byte-compile-recurse-toplevel (form non-toplevel-case) "Implement `eval-when-compile' and `eval-and-compile'. Return the compile-time value of FORM." @@ -535,8 +505,9 @@ Return the compile-time value of FORM." byte-compile-new-defuns)) (setf result (byte-compile-eval - (byte-compile-top-level - (byte-compile-preprocess form))))))) + (macroexp-strip-symbol-positions + (byte-compile-top-level + (byte-compile-preprocess form)))))))) (list 'quote result)))) (eval-and-compile . ,(lambda (&rest body) (byte-compile-recurse-toplevel @@ -547,10 +518,13 @@ Return the compile-time value of FORM." ;; or byte-compile-file-form. (let* ((print-symbols-bare t) (expanded - (macroexpand-all - form - macroexpand-all-environment))) - (eval expanded lexical-binding) + (macroexpand-all + form + macroexpand-all-environment))) + (eval + (macroexp-strip-symbol-positions + expanded) + lexical-binding) expanded))))) (with-suppressed-warnings . ,(lambda (warnings &rest body) @@ -1435,7 +1409,7 @@ function directly; use `byte-compile-warn' or (defun byte-compile-warn (format &rest args) "Issue a byte compiler warning; use (format-message FORMAT ARGS...) for message." - (setq args (mapcar #'byte-compile-strip-symbol-positions args)) + (setq args (mapcar #'macroexp-strip-symbol-positions args)) (setq format (apply #'format-message format args)) (if byte-compile-error-on-warn (error "%s" format) ; byte-compile-file catches and logs it @@ -2117,175 +2091,179 @@ See also `emacs-lisp-byte-compile-and-load'." ;; Force logging of the file name for each file compiled. (setq byte-compile-last-logged-file nil) - (let ((byte-compile-current-file filename) - (byte-compile-current-group nil) - (set-auto-coding-for-load t) - (byte-compile--seen-defvars nil) - (byte-compile--known-dynamic-vars - (byte-compile--load-dynvars (getenv "EMACS_DYNVARS_FILE"))) - target-file input-buffer output-buffer - byte-compile-dest-file byte-compiler-error-flag) - (setq target-file (byte-compile-dest-file filename)) - (setq byte-compile-dest-file target-file) - (with-current-buffer - ;; It would be cleaner to use a temp buffer, but if there was - ;; an error, we leave this buffer around for diagnostics. - ;; Its name is documented in the lispref. - (setq input-buffer (get-buffer-create - (concat " *Compiler Input*" - (if (zerop byte-compile-level) "" - (format "-%s" byte-compile-level))))) - (erase-buffer) - (setq buffer-file-coding-system nil) - ;; Always compile an Emacs Lisp file as multibyte - ;; unless the file itself forces unibyte with -*-coding: raw-text;-*- - (set-buffer-multibyte t) - (insert-file-contents filename) - ;; Mimic the way after-insert-file-set-coding can make the - ;; buffer unibyte when visiting this file. - (when (or (eq last-coding-system-used 'no-conversion) - (eq (coding-system-type last-coding-system-used) 5)) - ;; For coding systems no-conversion and raw-text..., - ;; edit the buffer as unibyte. - (set-buffer-multibyte nil)) - ;; Run hooks including the uncompression hook. - ;; If they change the file name, then change it for the output also. - (let ((buffer-file-name filename) - (dmm (default-value 'major-mode)) - ;; Ignore unsafe local variables. - ;; We only care about a few of them for our purposes. - (enable-local-variables :safe) - (enable-local-eval nil)) - (unwind-protect - (progn - (setq-default major-mode 'emacs-lisp-mode) - ;; Arg of t means don't alter enable-local-variables. - (delay-mode-hooks (normal-mode t))) - (setq-default major-mode dmm)) - ;; There may be a file local variable setting (bug#10419). - (setq buffer-read-only nil - filename buffer-file-name)) - ;; Don't inherit lexical-binding from caller (bug#12938). - (unless (local-variable-p 'lexical-binding) - (setq-local lexical-binding nil)) - ;; Set the default directory, in case an eval-when-compile uses it. - (setq default-directory (file-name-directory filename))) - ;; Check if the file's local variables explicitly specify not to - ;; compile this file. - (if (with-current-buffer input-buffer no-byte-compile) - (progn - ;; (message "%s not compiled because of `no-byte-compile: %s'" - ;; (byte-compile-abbreviate-file filename) - ;; (with-current-buffer input-buffer no-byte-compile)) - (when (and target-file (file-exists-p target-file)) - (message "%s deleted because of `no-byte-compile: %s'" - (byte-compile-abbreviate-file target-file) - (buffer-local-value 'no-byte-compile input-buffer)) - (condition-case nil (delete-file target-file) (error nil))) - ;; We successfully didn't compile this file. - 'no-byte-compile) - (when byte-compile-verbose - (message "Compiling %s..." filename)) - ;; It is important that input-buffer not be current at this call, - ;; so that the value of point set in input-buffer - ;; within byte-compile-from-buffer lingers in that buffer. - (setq output-buffer - (save-current-buffer - (let ((symbols-with-pos-enabled t) - (byte-compile-level (1+ byte-compile-level))) - (byte-compile-from-buffer input-buffer)))) - (if byte-compiler-error-flag - nil - (when byte-compile-verbose - (message "Compiling %s...done" filename)) - (kill-buffer input-buffer) - (with-current-buffer output-buffer - (when (and target-file - (or (not byte-native-compiling) - (and byte-native-compiling byte+native-compile))) - (goto-char (point-max)) - (insert "\n") ; aaah, unix. - (cond - ((and (file-writable-p target-file) - ;; We attempt to create a temporary file in the - ;; target directory, so the target directory must be - ;; writable. - (file-writable-p - (file-name-directory - ;; Need to expand in case TARGET-FILE doesn't - ;; include a directory (Bug#45287). - (expand-file-name target-file)))) - ;; We must disable any code conversion here. - (let* ((coding-system-for-write 'no-conversion) - ;; Write to a tempfile so that if another Emacs - ;; process is trying to load target-file (eg in a - ;; parallel bootstrap), it does not risk getting a - ;; half-finished file. (Bug#4196) - (tempfile - (make-temp-file (when (file-writable-p target-file) - (expand-file-name target-file)))) - (default-modes (default-file-modes)) - (temp-modes (logand default-modes #o600)) - (desired-modes (logand default-modes #o666)) - (kill-emacs-hook - (cons (lambda () (ignore-errors - (delete-file tempfile))) - kill-emacs-hook))) - (unless (= temp-modes desired-modes) - (set-file-modes tempfile desired-modes 'nofollow)) - (write-region (point-min) (point-max) tempfile nil 1) - ;; This has the intentional side effect that any - ;; hard-links to target-file continue to - ;; point to the old file (this makes it possible - ;; for installed files to share disk space with - ;; the build tree, without causing problems when - ;; emacs-lisp files in the build tree are - ;; recompiled). Previously this was accomplished by - ;; deleting target-file before writing it. - (if byte-native-compiling - ;; Defer elc final renaming. - (setf byte-to-native-output-file - (cons tempfile target-file)) - (rename-file tempfile target-file t))) - (or noninteractive - byte-native-compiling - (message "Wrote %s" target-file))) - ((file-writable-p target-file) - ;; In case the target directory isn't writable (see e.g. Bug#44631), - ;; try writing to the output file directly. We must disable any - ;; code conversion here. - (let ((coding-system-for-write 'no-conversion)) - (with-file-modes (logand (default-file-modes) #o666) - (write-region (point-min) (point-max) target-file nil 1))) - (or noninteractive (message "Wrote %s" target-file))) - (t - ;; This is just to give a better error message than write-region - (let ((exists (file-exists-p target-file))) - (signal (if exists 'file-error 'file-missing) - (list "Opening output file" - (if exists - "Cannot overwrite file" - "Directory not writable or nonexistent") - target-file)))))) - (kill-buffer (current-buffer))) - (if (and byte-compile-generate-call-tree - (or (eq t byte-compile-generate-call-tree) - (y-or-n-p (format "Report call tree for %s? " - filename)))) - (save-excursion - (display-call-tree filename))) - (let ((gen-dynvars (getenv "EMACS_GENERATE_DYNVARS"))) - (when (and gen-dynvars (not (equal gen-dynvars "")) - byte-compile--seen-defvars) - (let ((dynvar-file (concat target-file ".dynvars"))) - (message "Generating %s" dynvar-file) - (with-temp-buffer - (dolist (var (delete-dups byte-compile--seen-defvars)) - (insert (format "%S\n" (cons var filename)))) - (write-region (point-min) (point-max) dynvar-file))))) - (if load - (load target-file)) - t)))) + (prog1 + (let ((byte-compile-current-file filename) + (byte-compile-current-group nil) + (set-auto-coding-for-load t) + (byte-compile--seen-defvars nil) + (byte-compile--known-dynamic-vars + (byte-compile--load-dynvars (getenv "EMACS_DYNVARS_FILE"))) + target-file input-buffer output-buffer + byte-compile-dest-file byte-compiler-error-flag) + (setq target-file (byte-compile-dest-file filename)) + (setq byte-compile-dest-file target-file) + (with-current-buffer + ;; It would be cleaner to use a temp buffer, but if there was + ;; an error, we leave this buffer around for diagnostics. + ;; Its name is documented in the lispref. + (setq input-buffer (get-buffer-create + (concat " *Compiler Input*" + (if (zerop byte-compile-level) "" + (format "-%s" byte-compile-level))))) + (erase-buffer) + (setq buffer-file-coding-system nil) + ;; Always compile an Emacs Lisp file as multibyte + ;; unless the file itself forces unibyte with -*-coding: raw-text;-*- + (set-buffer-multibyte t) + (insert-file-contents filename) + ;; Mimic the way after-insert-file-set-coding can make the + ;; buffer unibyte when visiting this file. + (when (or (eq last-coding-system-used 'no-conversion) + (eq (coding-system-type last-coding-system-used) 5)) + ;; For coding systems no-conversion and raw-text..., + ;; edit the buffer as unibyte. + (set-buffer-multibyte nil)) + ;; Run hooks including the uncompression hook. + ;; If they change the file name, then change it for the output also. + (let ((buffer-file-name filename) + (dmm (default-value 'major-mode)) + ;; Ignore unsafe local variables. + ;; We only care about a few of them for our purposes. + (enable-local-variables :safe) + (enable-local-eval nil)) + (unwind-protect + (progn + (setq-default major-mode 'emacs-lisp-mode) + ;; Arg of t means don't alter enable-local-variables. + (delay-mode-hooks (normal-mode t))) + (setq-default major-mode dmm)) + ;; There may be a file local variable setting (bug#10419). + (setq buffer-read-only nil + filename buffer-file-name)) + ;; Don't inherit lexical-binding from caller (bug#12938). + (unless (local-variable-p 'lexical-binding) + (setq-local lexical-binding nil)) + ;; Set the default directory, in case an eval-when-compile uses it. + (setq default-directory (file-name-directory filename))) + ;; Check if the file's local variables explicitly specify not to + ;; compile this file. + (if (with-current-buffer input-buffer no-byte-compile) + (progn + ;; (message "%s not compiled because of `no-byte-compile: %s'" + ;; (byte-compile-abbreviate-file filename) + ;; (with-current-buffer input-buffer no-byte-compile)) + (when (and target-file (file-exists-p target-file)) + (message "%s deleted because of `no-byte-compile: %s'" + (byte-compile-abbreviate-file target-file) + (buffer-local-value 'no-byte-compile input-buffer)) + (condition-case nil (delete-file target-file) (error nil))) + ;; We successfully didn't compile this file. + 'no-byte-compile) + (when byte-compile-verbose + (message "Compiling %s..." filename)) + ;; It is important that input-buffer not be current at this call, + ;; so that the value of point set in input-buffer + ;; within byte-compile-from-buffer lingers in that buffer. + (setq output-buffer + (save-current-buffer + (let ((symbols-with-pos-enabled t) + (byte-compile-level (1+ byte-compile-level))) + (byte-compile-from-buffer input-buffer)))) + (if byte-compiler-error-flag + nil + (when byte-compile-verbose + (message "Compiling %s...done" filename)) + (kill-buffer input-buffer) + (with-current-buffer output-buffer + (when (and target-file + (or (not byte-native-compiling) + (and byte-native-compiling byte+native-compile))) + (goto-char (point-max)) + (insert "\n") ; aaah, unix. + (cond + ((and (file-writable-p target-file) + ;; We attempt to create a temporary file in the + ;; target directory, so the target directory must be + ;; writable. + (file-writable-p + (file-name-directory + ;; Need to expand in case TARGET-FILE doesn't + ;; include a directory (Bug#45287). + (expand-file-name target-file)))) + ;; We must disable any code conversion here. + (let* ((coding-system-for-write 'no-conversion) + ;; Write to a tempfile so that if another Emacs + ;; process is trying to load target-file (eg in a + ;; parallel bootstrap), it does not risk getting a + ;; half-finished file. (Bug#4196) + (tempfile + (make-temp-file (when (file-writable-p target-file) + (expand-file-name target-file)))) + (default-modes (default-file-modes)) + (temp-modes (logand default-modes #o600)) + (desired-modes (logand default-modes #o666)) + (kill-emacs-hook + (cons (lambda () (ignore-errors + (delete-file tempfile))) + kill-emacs-hook))) + (unless (= temp-modes desired-modes) + (set-file-modes tempfile desired-modes 'nofollow)) + (write-region (point-min) (point-max) tempfile nil 1) + ;; This has the intentional side effect that any + ;; hard-links to target-file continue to + ;; point to the old file (this makes it possible + ;; for installed files to share disk space with + ;; the build tree, without causing problems when + ;; emacs-lisp files in the build tree are + ;; recompiled). Previously this was accomplished by + ;; deleting target-file before writing it. + (if byte-native-compiling + ;; Defer elc final renaming. + (setf byte-to-native-output-file + (cons tempfile target-file)) + (rename-file tempfile target-file t))) + (or noninteractive + byte-native-compiling + (message "Wrote %s" target-file))) + ((file-writable-p target-file) + ;; In case the target directory isn't writable (see e.g. Bug#44631), + ;; try writing to the output file directly. We must disable any + ;; code conversion here. + (let ((coding-system-for-write 'no-conversion)) + (with-file-modes (logand (default-file-modes) #o666) + (write-region (point-min) (point-max) target-file nil 1))) + (or noninteractive (message "Wrote %s" target-file))) + (t + ;; This is just to give a better error message than write-region + (let ((exists (file-exists-p target-file))) + (signal (if exists 'file-error 'file-missing) + (list "Opening output file" + (if exists + "Cannot overwrite file" + "Directory not writable or nonexistent") + target-file)))))) + (kill-buffer (current-buffer))) + (if (and byte-compile-generate-call-tree + (or (eq t byte-compile-generate-call-tree) + (y-or-n-p (format "Report call tree for %s? " + filename)))) + (save-excursion + (display-call-tree filename))) + (let ((gen-dynvars (getenv "EMACS_GENERATE_DYNVARS"))) + (when (and gen-dynvars (not (equal gen-dynvars "")) + byte-compile--seen-defvars) + (let ((dynvar-file (concat target-file ".dynvars"))) + (message "Generating %s" dynvar-file) + (with-temp-buffer + (dolist (var (delete-dups byte-compile--seen-defvars)) + (insert (format "%S\n" (cons var filename)))) + (write-region (point-min) (point-max) dynvar-file))))) + (if load + (load target-file)) + t))) + ;; Strip positions from symbols for the native compiler. + (setq byte-to-native-top-level-forms + (macroexp-strip-symbol-positions byte-to-native-top-level-forms)))) ;;; compiling a single function ;;;###autoload @@ -2458,8 +2436,10 @@ Call from the source buffer." ;; it here. (when byte-native-compiling ;; Spill output for the native compiler here - (push (make-byte-to-native-top-level :form form :lexical lexical-binding) - byte-to-native-top-level-forms)) + (push + (macroexp-strip-symbol-positions + (make-byte-to-native-top-level :form form :lexical lexical-binding)) + byte-to-native-top-level-forms)) (let ((print-escape-newlines t) (print-length nil) (print-level nil) @@ -2659,7 +2639,7 @@ list that represents a doc string reference. ;; byte-compile-noruntime-functions, in case we have an autoload ;; of foo-func following an (eval-when-compile (require 'foo)). (unless (fboundp funsym) - (push (byte-compile-strip-symbol-positions + (push (macroexp-strip-symbol-positions (cons funsym (cons 'autoload (cdr (cdr form))))) byte-compile-function-environment)) ;; If an autoload occurs _before_ the first call to a function, @@ -2676,7 +2656,7 @@ list that represents a doc string reference. (delq (assq funsym byte-compile-unresolved-functions) byte-compile-unresolved-functions))))) (if (stringp (nth 3 form)) - (prog1 (byte-compile-strip-symbol-positions form) + (prog1 (macroexp-strip-symbol-positions form) (byte-compile-docstring-length-warn form)) ;; No doc string, so we can compile this as a normal form. (byte-compile-keep-pending form 'byte-compile-normal-call))) @@ -2717,7 +2697,7 @@ list that represents a doc string reference. ((symbolp (nth 2 form)) (setcar (cddr form) (bare-symbol (nth 2 form)))) (t (setcar (cddr form) - (byte-compile-strip-symbol-positions (nth 2 form))))) + (macroexp-strip-symbol-positions (nth 2 form))))) (setcar form (bare-symbol (car form))) (if (symbolp (nth 1 form)) (setcar (cdr form) (bare-symbol (nth 1 form)))) @@ -2800,7 +2780,7 @@ list that represents a doc string reference. (prog1 (byte-compile-keep-pending form) (apply 'make-obsolete (mapcar 'eval - (byte-compile-strip-symbol-positions (cdr form)))))) + (macroexp-strip-symbol-positions (cdr form)))))) ;; This handler is not necessary, but it makes the output from dont-compile ;; and similar macros cleaner. @@ -2926,13 +2906,15 @@ not to take responsibility for the actual compilation of the code." (if (not (stringp (documentation code t))) -1 4))) (when byte-native-compiling ;; Spill output for the native compiler here. - (push (if macro - (make-byte-to-native-top-level - :form `(defalias ',name '(macro . ,code) nil) - :lexical lexical-binding) - (make-byte-to-native-func-def :name name - :byte-func code)) - byte-to-native-top-level-forms)) + (push + (macroexp-strip-symbol-positions + (if macro + (make-byte-to-native-top-level + :form `(defalias ',name '(macro . ,code) nil) + :lexical lexical-binding) + (make-byte-to-native-func-def :name name + :byte-func code))) + byte-to-native-top-level-forms)) ;; Output the form by hand, that's much simpler than having ;; b-c-output-file-form analyze the defalias. (byte-compile-output-docform @@ -3020,37 +3002,40 @@ If FORM is a lambda or a macro, byte-compile it as a function." (macro (eq (car-safe fun) 'macro))) (if macro (setq fun (cdr fun))) - (cond - ;; Up until Emacs-24.1, byte-compile silently did nothing when asked to - ;; compile something invalid. So let's tune down the complaint from an - ;; error to a simple message for the known case where signaling an error - ;; causes problems. - ((byte-code-function-p fun) - (message "Function %s is already compiled" - (if (symbolp form) form "provided")) - fun) - (t - (let (final-eval) - (when (or (symbolp form) (eq (car-safe fun) 'closure)) - ;; `fun' is a function *value*, so try to recover its corresponding - ;; source code. - (setq lexical-binding (eq (car fun) 'closure)) - (setq fun (byte-compile--reify-function fun)) - (setq final-eval t)) - ;; Expand macros. - (setq fun (byte-compile-preprocess fun)) - (setq fun (byte-compile-top-level fun nil 'eval)) - (if (symbolp form) - ;; byte-compile-top-level returns an *expression* equivalent to the - ;; `fun' expression, so we need to evaluate it, tho normally - ;; this is not needed because the expression is just a constant - ;; byte-code object, which is self-evaluating. - (setq fun (eval fun t))) - (if final-eval - (setq fun (eval fun t))) - (if macro (push 'macro fun)) - (if (symbolp form) (fset form fun)) - fun))))))) + (prog1 + (cond + ;; Up until Emacs-24.1, byte-compile silently did nothing when asked to + ;; compile something invalid. So let's tune down the complaint from an + ;; error to a simple message for the known case where signaling an error + ;; causes problems. + ((byte-code-function-p fun) + (message "Function %s is already compiled" + (if (symbolp form) form "provided")) + fun) + (t + (let (final-eval) + (when (or (symbolp form) (eq (car-safe fun) 'closure)) + ;; `fun' is a function *value*, so try to recover its corresponding + ;; source code. + (setq lexical-binding (eq (car fun) 'closure)) + (setq fun (byte-compile--reify-function fun)) + (setq final-eval t)) + ;; Expand macros. + (setq fun (byte-compile-preprocess fun)) + (setq fun (byte-compile-top-level fun nil 'eval)) + (if (symbolp form) + ;; byte-compile-top-level returns an *expression* equivalent to the + ;; `fun' expression, so we need to evaluate it, tho normally + ;; this is not needed because the expression is just a constant + ;; byte-code object, which is self-evaluating. + (setq fun (eval fun t))) + (if final-eval + (setq fun (eval fun t))) + (if macro (push 'macro fun)) + (if (symbolp form) (fset form fun)) + fun))) + (setq byte-to-native-top-level-forms + (macroexp-strip-symbol-positions byte-to-native-top-level-forms))))))) (defun byte-compile-sexp (sexp) "Compile and return SEXP." @@ -3197,8 +3182,8 @@ for symbols generated by the byte compiler itself." ;; which may include "calls" to ;; internal-make-closure (Bug#29988). lexical-binding) - (setq int (byte-compile-strip-symbol-positions `(interactive ,newform))) - (setq int (byte-compile-strip-symbol-positions int))))) + (setq int (macroexp-strip-symbol-positions `(interactive ,newform))) + (setq int (macroexp-strip-symbol-positions int))))) ((cdr int) ; Invalid (interactive . something). (byte-compile-warn-x int "malformed interactive spec: %s" int)))) @@ -3213,7 +3198,7 @@ for symbols generated by the byte compiler itself." (byte-compile-make-lambda-lexenv arglistvars)) reserved-csts)) - (bare-arglist (byte-compile-strip-symbol-positions arglist))) + (bare-arglist (macroexp-strip-symbol-positions arglist))) ;; Build the actual byte-coded function. (cl-assert (eq 'byte-code (car-safe compiled))) (let ((out @@ -3237,7 +3222,7 @@ for symbols generated by the byte compiler itself." ;; We have some command modes, so use the vector form. (command-modes (list (vector (nth 1 int) - (byte-compile-strip-symbol-positions + (macroexp-strip-symbol-positions command-modes)))) ;; No command modes, use the simple form with just the ;; interactive spec. @@ -3785,7 +3770,7 @@ assignment (i.e. `setq')." (byte-compile-out 'byte-constant (byte-compile-get-constant - (byte-compile-strip-symbol-positions const)))) + (macroexp-strip-symbol-positions const)))) ;; Compile those primitive ordinary functions ;; which have special byte codes just for speed. @@ -4619,7 +4604,7 @@ Return (TAIL VAR TEST CASES), where: (dolist (case cases) (setq tag (byte-compile-make-tag) - test-objects (byte-compile-strip-symbol-positions (car case)) + test-objects (macroexp-strip-symbol-positions (car case)) body (cdr case)) (byte-compile-out-tag tag) (dolist (value test-objects) @@ -5265,7 +5250,7 @@ binding slots have been popped." (when (null form) (byte-compile-warn-x form "Uneven number of key bindings in %S" form)) (push (pop form) result)) - (byte-compile-strip-symbol-positions orig-form))) + (macroexp-strip-symbol-positions orig-form))) (put 'define-keymap--define 'byte-hunk-handler #'byte-compile-define-keymap--define) @@ -5332,9 +5317,9 @@ OP and OPERAND are as passed to `byte-compile-out'." ;;; call tree stuff (defun byte-compile-annotate-call-tree (form) - (let ((current-form (byte-compile-strip-symbol-positions + (let ((current-form (macroexp-strip-symbol-positions byte-compile-current-form)) - (bare-car-form (byte-compile-strip-symbol-positions (car form))) + (bare-car-form (macroexp-strip-symbol-positions (car form))) entry) ;; annotate the current call (if (setq entry (assq bare-car-form byte-compile-call-tree)) @@ -5552,8 +5537,10 @@ already up-to-date." (or (not (file-exists-p dest)) (file-newer-than-file-p source dest)))) (if (null (batch-byte-compile-file (car command-line-args-left))) - (setq error t)))) + (setq error t)))) (setq command-line-args-left (cdr command-line-args-left))) + (setq byte-to-native-top-level-forms + (macroexp-strip-symbol-positions byte-to-native-top-level-forms)) (kill-emacs (if error 1 0)))) (defun batch-byte-compile-file (file) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 3659a0c95a..fbcf0020e8 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -53,36 +53,6 @@ `(prog1 (car (cdr ,place)) (setq ,place (cdr (cdr ,place))))) -(defun cl-macs--strip-s-p-1 (arg) - "Strip all positions from symbols with position in ARG, destructively modifying ARG -Return the modified ARG." - (cond - ((symbolp arg) - (bare-symbol arg)) - ((consp arg) - (let ((a arg)) - (while (consp (cdr a)) - (setcar a (cl-macs--strip-s-p-1 (car a))) - (setq a (cdr a))) - (setcar a (cl-macs--strip-s-p-1 (car a))) - ;; (if (cdr a) - (unless (bare-symbol-p (cdr a)) ; includes (unpositioned) nil. - (setcdr a (cl-macs--strip-s-p-1 (cdr a))))) - arg) - ((vectorp arg) - (let ((i 0) - (len (length arg))) - (while (< i len) - (aset arg i (cl-macs--strip-s-p-1 (aref arg i))) - (setq i (1+ i)))) - arg) - (t arg))) - -(defun cl-macs--strip-symbol-positions (arg) - "Strip all positions from symbols (recursively) in ARG. Don't modify ARG." - (let ((arg1 (copy-tree arg t))) - (cl-macs--strip-s-p-1 arg1))) - (defvar cl--optimize-safety) (defvar cl--optimize-speed) @@ -3534,8 +3504,9 @@ and then returning foo." `(eval-and-compile ;; Name the compiler-macro function, so that `symbol-file' can find it. (cl-defun ,fname ,(if (memq '&whole args) (delq '&whole args) - (cons '_cl-whole-arg args)) - ,@body) + (cons '_cl-whole-arg + (macroexp-strip-symbol-positions args))) + ,@(macroexp-strip-symbol-positions body)) (put ',func 'compiler-macro #',fname)))) ;;;###autoload diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0a10505257..8581fe8066 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1829,9 +1829,7 @@ and the annotation emission." (byte-listp auto) (byte-eq auto) (byte-memq auto) - (byte-not - (comp-emit-set-call (comp-call 'eq (comp-slot-n (comp-sp)) - (make-comp-mvar :constant nil)))) + (byte-not null) (byte-car auto) (byte-cdr auto) (byte-cons auto) @@ -4017,6 +4015,7 @@ the deferred compilation mechanism." (let* ((data function-or-file) (comp-native-compiling t) (byte-native-qualities nil) + (symbols-with-pos-enabled t) ;; Have byte compiler signal an error when compilation fails. (byte-compile-debug t) (comp-ctxt (make-comp-ctxt :output output @@ -4060,10 +4059,10 @@ the deferred compilation mechanism." (signal (car err) (if (consp err-val) (cons function-or-file err-val) (list function-or-file err-val))))))) - (if (stringp function-or-file) - data - ;; So we return the compiled function. - (native-elisp-load data))))) + (if (stringp function-or-file) + data + ;; So we return the compiled function. + (native-elisp-load data))))) (defun native-compile-async-skip-p (file load selector) "Return non-nil if FILE's compilation should be skipped. diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 60fac98130..dafd549763 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -32,6 +32,64 @@ ;; macros defined by `defmacro'. (defvar macroexpand-all-environment nil) +(defvar byte-compile--ssp-conses-seen nil + "Which conses have been processed in a strip-symbol-positions operation?") +(defvar byte-compile--ssp-vectors-seen nil + "Which vectors have been processed in a strip-symbol-positions operation?") +(defvar byte-compile--ssp-records-seen nil + "Which records have been processed in a strip-symbol-positions operation?") + +(defun macroexp--strip-s-p-2 (arg) + "Strip all positions from symbols in ARG, destructively modifying ARG. +Return the modified ARG." + (cond + ((symbolp arg) + (bare-symbol arg)) + ((consp arg) + (unless (memq arg byte-compile--ssp-conses-seen) + ;; (push arg byte-compile--ssp-conses-seen) + (let ((a arg)) + (while (consp (cdr a)) + (setcar a (macroexp--strip-s-p-2 (car a))) + (setq a (cdr a))) + (setcar a (macroexp--strip-s-p-2 (car a))) + ;; (if (cdr a) + (unless (bare-symbol-p (cdr a)) ; includes (unpositioned) nil. + (setcdr a (macroexp--strip-s-p-2 (cdr a)))))) + arg) + ((vectorp arg) + (unless (memq arg byte-compile--ssp-vectors-seen) + (push arg byte-compile--ssp-vectors-seen) + (let ((i 0) + (len (length arg))) + (while (< i len) + (aset arg i (macroexp--strip-s-p-2 (aref arg i))) + (setq i (1+ i))))) + arg) + ((recordp arg) + (unless (memq arg byte-compile--ssp-records-seen) + (push arg byte-compile--ssp-records-seen) + (let ((i 0) + (len (length arg))) + (while (< i len) + (aset arg i (macroexp--strip-s-p-2 (aref arg i))) + (setq i (1+ i))))) + arg) + (t arg))) + +(defun byte-compile-strip-s-p-1 (arg) + "Strip all positions from symbols in ARG, destructively modifying ARG. +Return the modified ARG." + (setq byte-compile--ssp-conses-seen nil) + (setq byte-compile--ssp-vectors-seen nil) + (setq byte-compile--ssp-records-seen nil) + (macroexp--strip-s-p-2 arg)) + +(defun macroexp-strip-symbol-positions (arg) + "Strip all positions from symbols (recursively) in ARG. Don't modify ARG." + (let ((arg1 (copy-tree arg t))) + (byte-compile-strip-s-p-1 arg1))) + (defun macroexp--cons (car cdr original-cons) "Return ORIGINAL-CONS if the car/cdr of it is `eq' to CAR and CDR, respectively. If not, return (CAR . CDR)." @@ -96,10 +154,11 @@ each clause." (defun macroexp--compiler-macro (handler form) (condition-case-unless-debug err - (apply handler form (cdr form)) + (let ((symbols-with-pos-enabled t)) + (apply handler form (cdr form))) (error - (message "Compiler-macro error for %S: %S" (car form) err) - form))) + (message "Compiler-macro error for %S: Handler: %S\n%S" (car form) handler err) + form))) (defun macroexp--funcall-if-compiled (_form) "Pseudo function used internally by macroexp to delay warnings. @@ -683,6 +742,7 @@ test of free variables in the following ways: (defun internal-macroexpand-for-load (form full-p) ;; Called from the eager-macroexpansion in readevalloop. + (setq form (macroexp-strip-symbol-positions form)) (cond ;; Don't repeat the same warning for every top-level element. ((eq 'skip (car macroexp--pending-eager-loads)) form) diff --git a/src/comp.c b/src/comp.c index 5b947fc99b..ac38c2131f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -454,6 +454,7 @@ load_gccjit_if_necessary (bool mandatory) /* C symbols emitted for the load relocation mechanism. */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" +#define F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM "f_symbols_with_pos_enabled_reloc" #define PURE_RELOC_SYM "pure_reloc" #define DATA_RELOC_SYM "d_reloc" #define DATA_RELOC_IMPURE_SYM "d_reloc_imp" @@ -542,6 +543,7 @@ typedef struct { gcc_jit_type *emacs_int_type; gcc_jit_type *emacs_uint_type; gcc_jit_type *void_ptr_type; + gcc_jit_type *bool_ptr_type; gcc_jit_type *char_ptr_type; gcc_jit_type *ptrdiff_type; gcc_jit_type *uintptr_type; @@ -563,6 +565,15 @@ typedef struct { gcc_jit_field *lisp_cons_u_s_u_cdr; gcc_jit_type *lisp_cons_type; gcc_jit_type *lisp_cons_ptr_type; + /* struct Lisp_Symbol_With_Position */ + gcc_jit_rvalue *f_symbols_with_pos_enabled_ref; + gcc_jit_struct *lisp_symbol_with_position; + gcc_jit_field *lisp_symbol_with_position_header; + gcc_jit_field *lisp_symbol_with_position_sym; + gcc_jit_field *lisp_symbol_with_position_pos; + gcc_jit_type *lisp_symbol_with_position_type; + gcc_jit_type *lisp_symbol_with_position_ptr_type; + gcc_jit_function *get_symbol_with_position; /* struct jmp_buf. */ gcc_jit_struct *jmp_buf_s; /* struct handler. */ @@ -655,7 +666,10 @@ Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); Lisp_Object helper_unbind_n (Lisp_Object n); void helper_save_restriction (void); bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code); +struct Lisp_Symbol_With_Pos *helper_GET_SYMBOL_WITH_POSITION (Lisp_Object a); +/* Note: helper_link_table must match the list created by + `declare_runtime_imported_funcs'. */ void *helper_link_table[] = { wrong_type_argument, helper_PSEUDOVECTOR_TYPEP_XUNTAG, @@ -664,6 +678,7 @@ void *helper_link_table[] = record_unwind_protect_excursion, helper_unbind_n, helper_save_restriction, + helper_GET_SYMBOL_WITH_POSITION, record_unwind_current_buffer, set_internal, helper_unwind_protect, @@ -1328,9 +1343,9 @@ emit_XCONS (gcc_jit_rvalue *a) } static gcc_jit_rvalue * -emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) +emit_BASE_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) { - emit_comment ("EQ"); + emit_comment ("BASE_EQ"); return gcc_jit_context_new_comparison ( comp.ctxt, @@ -1340,6 +1355,30 @@ emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) emit_XLI (y)); } +static gcc_jit_rvalue * +emit_AND (gcc_jit_rvalue *x, gcc_jit_rvalue *y) +{ + return gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_AND, + comp.bool_type, + x, + y); +} + +static gcc_jit_rvalue * +emit_OR (gcc_jit_rvalue *x, gcc_jit_rvalue *y) +{ + return gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + x, + y); +} + static gcc_jit_rvalue * emit_TAGGEDP (gcc_jit_rvalue *obj, Lisp_Word_tag tag) { @@ -1401,6 +1440,94 @@ emit_CONSP (gcc_jit_rvalue *obj) return emit_TAGGEDP (obj, Lisp_Cons); } +static gcc_jit_rvalue * +emit_BARE_SYMBOL_P (gcc_jit_rvalue *obj) +{ + emit_comment ("BARE_SYMBOL_P"); + + return gcc_jit_context_new_cast (comp.ctxt, + NULL, + emit_TAGGEDP (obj, Lisp_Symbol), + comp.bool_type); +} + +static gcc_jit_rvalue * +emit_SYMBOL_WITH_POS_P (gcc_jit_rvalue *obj) +{ + emit_comment ("SYMBOL_WITH_POS_P"); + + gcc_jit_rvalue *args[] = + { obj, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + PVEC_SYMBOL_WITH_POS) + }; + + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.pseudovectorp, + 2, + args); +} + +static gcc_jit_rvalue * +emit_SYMBOL_WITH_POS_SYM (gcc_jit_rvalue *obj) +{ + emit_comment ("SYMBOL_WITH_POS_SYM"); + + gcc_jit_rvalue *tmp2, *swp; + gcc_jit_lvalue *tmpl; + + gcc_jit_rvalue *args[] = { obj }; + swp = gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.get_symbol_with_position, + 1, + args); + tmpl = gcc_jit_rvalue_dereference (swp, gcc_jit_context_new_location (comp.ctxt, "comp.c", __LINE__, 0)); + tmp2 = gcc_jit_lvalue_as_rvalue (tmpl); + return + gcc_jit_rvalue_access_field (tmp2, + NULL, + comp.lisp_symbol_with_position_sym); +} + +static gcc_jit_rvalue * +emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) +{ + return + emit_OR ( + gcc_jit_context_new_comparison ( + comp.ctxt, gcc_jit_context_new_location (comp.ctxt, "comp.c", __LINE__, 0), + GCC_JIT_COMPARISON_EQ, + emit_XLI (x), emit_XLI (y)), + emit_AND ( + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference (comp.f_symbols_with_pos_enabled_ref, + gcc_jit_context_new_location (comp.ctxt, "comp.c", __LINE__, 0))), + emit_OR ( + emit_AND ( + emit_SYMBOL_WITH_POS_P (x), + emit_OR ( + emit_AND ( + emit_SYMBOL_WITH_POS_P (y), + emit_BASE_EQ ( + emit_XLI (emit_SYMBOL_WITH_POS_SYM (x)), + emit_XLI (emit_SYMBOL_WITH_POS_SYM (y)))), + emit_AND ( + emit_BARE_SYMBOL_P (y), + emit_BASE_EQ ( + emit_XLI (emit_SYMBOL_WITH_POS_SYM (x)), + emit_XLI (y))))), + emit_AND ( + emit_BARE_SYMBOL_P (x), + emit_AND ( + emit_SYMBOL_WITH_POS_P (y), + emit_BASE_EQ ( + emit_XLI (x), + emit_XLI (emit_SYMBOL_WITH_POS_SYM (y)))))))); +} + static gcc_jit_rvalue * emit_FLOATP (gcc_jit_rvalue *obj) { @@ -1615,7 +1742,7 @@ static gcc_jit_rvalue * emit_NILP (gcc_jit_rvalue *x) { emit_comment ("NILP"); - return emit_EQ (x, emit_lisp_obj_rval (Qnil)); + return emit_BASE_EQ (x, emit_lisp_obj_rval (Qnil)); } static gcc_jit_rvalue * @@ -2095,7 +2222,13 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_block *target1 = retrive_block (arg[2]); gcc_jit_block *target2 = retrive_block (arg[3]); - emit_cond_jump (emit_EQ (a, b), target1, target2); + if ((CALL1I (comp-cstr-imm-vld-p, arg[0]) + && NILP (CALL1I (comp-cstr-imm, arg[0]))) + || (CALL1I (comp-cstr-imm-vld-p, arg[1]) + && NILP (CALL1I (comp-cstr-imm, arg[1])))) + emit_cond_jump (emit_BASE_EQ (a, b), target1, target2); + else + emit_cond_jump (emit_EQ (a, b), target1, target2); } else if (EQ (op, Qcond_jump_narg_leq)) { @@ -2714,7 +2847,8 @@ declare_imported_data (void) /* Declare as imported all the functions that are requested from the runtime. - These are either subrs or not. + These are either subrs or not. Note that the list created here must match + the array `helper_link_table'. */ static Lisp_Object declare_runtime_imported_funcs (void) @@ -2751,6 +2885,10 @@ declare_runtime_imported_funcs (void) ADD_IMPORTED (helper_save_restriction, comp.void_type, 0, NULL); + args[0] = comp.lisp_obj_type; + ADD_IMPORTED (helper_GET_SYMBOL_WITH_POSITION, comp.lisp_symbol_with_position_ptr_type, + 1, args); + ADD_IMPORTED (record_unwind_current_buffer, comp.void_type, 0, NULL); args[0] = args[1] = args[2] = comp.lisp_obj_type; @@ -2798,6 +2936,15 @@ emit_ctxt_code (void) gcc_jit_type_get_pointer (comp.thread_state_ptr_type), CURRENT_THREAD_RELOC_SYM)); + comp.f_symbols_with_pos_enabled_ref = + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + comp.bool_ptr_type, + F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM)); + comp.pure_ptr = gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_global ( @@ -2977,6 +3124,39 @@ define_lisp_cons (void) } +static void +define_lisp_symbol_with_position (void) +{ + comp.lisp_symbol_with_position_header = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.ptrdiff_type, + "header"); + comp.lisp_symbol_with_position_sym = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "sym"); + comp.lisp_symbol_with_position_pos = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "pos"); + gcc_jit_field *fields [3] = {comp.lisp_symbol_with_position_header, + comp.lisp_symbol_with_position_sym, + comp.lisp_symbol_with_position_pos}; + comp.lisp_symbol_with_position = + gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "comp_lisp_symbol_with_position", + 3, + fields); + comp.lisp_symbol_with_position_type = + gcc_jit_struct_as_type (comp.lisp_symbol_with_position); + comp.lisp_symbol_with_position_ptr_type = + gcc_jit_type_get_pointer (comp.lisp_symbol_with_position_type); +} + /* Opaque jmp_buf definition. */ static void @@ -3672,6 +3852,40 @@ define_PSEUDOVECTORP (void) comp.bool_type, 2, args, false)); } +static void +define_GET_SYMBOL_WITH_POSITION (void) +{ + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "a") }; + + comp.get_symbol_with_position = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_INTERNAL, + comp.lisp_symbol_with_position_ptr_type, + "GET_SYMBOL_WITH_POSITION", + 1, + param, + 0); + + DECL_BLOCK (entry_block, comp.get_symbol_with_position); + + comp.block = entry_block; + comp.func = comp.get_symbol_with_position; + + gcc_jit_rvalue *args[] = + { gcc_jit_param_as_rvalue (param[0]) }; + /* FIXME use XUNTAG now that's available. */ + gcc_jit_block_end_with_return ( + entry_block, + NULL, + emit_call (intern_c_string ("helper_GET_SYMBOL_WITH_POSITION"), + comp.lisp_symbol_with_position_ptr_type, + 1, args, false)); +} + static void define_CHECK_IMPURE (void) { @@ -4309,6 +4523,7 @@ Return t on success. */) gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG_LONG); comp.unsigned_long_long_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_LONG_LONG); + comp.bool_ptr_type = gcc_jit_type_get_pointer (comp.bool_type); comp.char_ptr_type = gcc_jit_type_get_pointer (comp.char_type); comp.emacs_int_type = gcc_jit_context_get_int_type (comp.ctxt, sizeof (EMACS_INT), @@ -4381,6 +4596,7 @@ Return t on success. */) /* Define data structures. */ define_lisp_cons (); + define_lisp_symbol_with_position (); define_jmp_buf (); define_handler_struct (); define_thread_state_struct (); @@ -4602,6 +4818,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, /* Define inline functions. */ define_CAR_CDR (); define_PSEUDOVECTORP (); + define_GET_SYMBOL_WITH_POSITION (); define_CHECK_TYPE (); define_CHECK_IMPURE (); define_bool_to_lisp_obj (); @@ -4734,6 +4951,14 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) code); } +struct Lisp_Symbol_With_Pos * +helper_GET_SYMBOL_WITH_POSITION (Lisp_Object a) +{ + if (!SYMBOL_WITH_POS_P (a)) + wrong_type_argument (Qwrong_type_argument, a); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Symbol_With_Pos); +} + /* `native-comp-eln-load-path' clean-up support code. */ @@ -5018,12 +5243,15 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, { struct thread_state ***current_thread_reloc = dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); + bool **f_symbols_with_pos_enabled_reloc = + dynlib_sym (handle, F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM); void **pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); Lisp_Object *data_imp_relocs = comp_u->data_imp_relocs; void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM); if (!(current_thread_reloc + && f_symbols_with_pos_enabled_reloc && pure_reloc && data_relocs && data_imp_relocs @@ -5035,6 +5263,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); *current_thread_reloc = ¤t_thread; + *f_symbols_with_pos_enabled_reloc = &symbols_with_pos_enabled; *pure_reloc = pure; /* Imported functions. */ @@ -5541,3 +5770,6 @@ be preloaded. */); defsubr (&Snative_comp_available_p); } +/* Local Variables: */ +/* c-file-offsets: ((arglist-intro . +)) */ +/* End: */ diff --git a/src/fns.c b/src/fns.c index 43df40aa9e..5df4ecfb36 100644 --- a/src/fns.c +++ b/src/fns.c @@ -2414,6 +2414,11 @@ It can be retrieved with `(get SYMBOL PROPNAME)'. */) (Lisp_Object symbol, Lisp_Object propname, Lisp_Object value) { CHECK_SYMBOL (symbol); + if (symbols_with_pos_enabled) + { + propname = call1 (intern ("macroexp-strip-symbol-positions"), propname); + value = call1 (intern ("macroexp-strip-symbol-positions"), value); + } set_symbol_plist (symbol, Fplist_put (XSYMBOL (symbol)->u.s.plist, propname, value)); return value; commit 8f1106ddf2a3861e9c1ebb9d8fa3d4087899de81 Author: Alan Mackenzie Date: Wed Dec 1 20:03:44 2021 +0000 Several amendments to scratch/correct-warning-pos. The position return by read-positioning-symbols is now the position in the buffer, rather than the offset from the start of a form, enabling warning positions in other parts of the buffer to be output. * src/lisp.h (lisp_h_EQ): Add XLI casts so that it compiles cleanly. * src/data.c (Fremove_pos_from_symbol): New DEFUN. * src/lread.c (readchar_count): renamed to readchar_offset. (read_internal_start) Initialize readchar_offset to the buffer's point when STREAM is a buffer. * lisp/emacs-lisp/bytecomp.el (byte-compile-warning-prefix): Amend to use OFFSET as a buffer position, not an offset from the start of a form. (byte-compile-warn): Remove symbol positions from any shape of ARGS, not just a symbol with position. * lisp/emacs-lisp/cconv.c (cconv-convert): In the :unused case, position the new IGNORE symbol with the VAR it has replaced. * lisp/emacs-lisp/macroexp.el (macroexp--warn-wrap, macroexp-warn-and-return): Add an extra position parameter to each. * lisp/emacs-lisp/bindat.el (bindat-type), lisp/emacs-lisp/byte-run.el (defmacro, defun), lisp/emacs-lisp/cconv.el (cconv--convert-func-body) (cconv-convert), lisp/emacs-lisp/cl-generic.el (cl-defmethod), lisp/emacs-lisp/cl-macs.el (cl-symbol-macrolet, cl-defstruct), lisp/emacs-lisp/easy-mmode.el (define-minor-mode), lisp/emacs-lisp/eieio-core.el (eieio-oref, eieio-oref-default) (eieio-oset-default), lisp/emacs-lisp/eieio.el (defclass), lisp/emacs-lisp/gv.el (gv-ref), lisp/emacs-lisp/macroexp.el (macroexp-macroexpand, macroexp--unfold-lambda, macroexp--expand-all), lisp/emacs-lisp/pcase.el (pcase-compile-patterns, pcase--u1): Add an extra position argument to each call of macroexp-warn-and-return. diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 76c2e80fda..17a55c7dba 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -804,6 +804,7 @@ is the name of a variable that will hold the value we need to pack.") (if (or (eq label '_) (not (assq label labels))) code (macroexp-warn-and-return + code (format "Duplicate label: %S" label) code)))) (`(,_ ,val) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index d82d9454e8..813ff53ea7 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -253,7 +253,8 @@ The return value is undefined. #'(lambda (x) (let ((f (cdr (assq (car x) macro-declarations-alist)))) (if f (apply (car f) name arglist (cdr x)) - (macroexp-warn-and-return + (macroexp-warn-and-return + (car x) (format-message "Unknown macro property %S in %S" (car x) name) @@ -327,6 +328,7 @@ The return value is undefined. nil) (t (macroexp-warn-and-return + (car x) (format-message "Unknown defun property `%S' in %S" (car x) name) nil))))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 869b6c01b8..2f23fe743e 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1326,7 +1326,7 @@ Return nil if such is not found." (goto-char byte-compile-last-position) (setq old-l (1+ (count-lines (point-min) (point-at-bol))) old-c (1+ (current-column))) - (goto-char (+ byte-compile-read-position offset)) + (goto-char offset) (setq new-l (1+ (count-lines (point-min) (point-at-bol))) new-c (1+ (current-column))) (format "%d:%d:%d:%d:" old-l old-c new-l new-c))) @@ -1435,12 +1435,7 @@ function directly; use `byte-compile-warn' or (defun byte-compile-warn (format &rest args) "Issue a byte compiler warning; use (format-message FORMAT ARGS...) for message." - (setq args - (mapcar (lambda (arg) - (if (symbolp arg) - (bare-symbol arg) - arg)) - args)) + (setq args (mapcar #'byte-compile-strip-symbol-positions args)) (setq format (apply #'format-message format args)) (if byte-compile-error-on-warn (error "%s" format) ; byte-compile-file catches and logs it diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 9c9ebe15d5..e12f0a1753 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -258,11 +258,11 @@ Returns a form where all lambdas don't have any free variables." ;; unused vars. (not (intern-soft var)) (eq ?_ (aref (symbol-name var) 0)) - ;; As a special exception, ignore "ignore". + ;; As a special exception, ignore "ignored". (eq var 'ignored)) (let ((suggestions (help-uni-confusable-suggestions (symbol-name var)))) (format "Unused lexical %s `%S'%s" - varkind var + varkind (bare-symbol var) (if suggestions (concat "\n " suggestions) ""))))) (define-inline cconv--var-classification (binder form) @@ -286,7 +286,7 @@ of converted forms." (let (and (pred stringp) msg) (cconv--warn-unused-msg arg "argument"))) (if (assq arg env) (push `(,arg . nil) env)) ;FIXME: Is it needed? - (push (lambda (body) (macroexp--warn-wrap msg body 'lexical)) wrappers)) + (push (lambda (body) (macroexp--warn-wrap body msg body 'lexical)) wrappers)) (_ (if (assq arg env) (push `(,arg . nil) env))))) (setq funcbody (mapcar (lambda (form) @@ -414,11 +414,14 @@ places where they originally did not directly appear." ;; Declared variable is unused. (if (assq var new-env) (push `(,var) new-env)) ;FIXME:Needed? - (let ((newval - `(ignore ,(cconv-convert value env extend))) - (msg (cconv--warn-unused-msg var "variable"))) + (let* ((Ignore (if (symbol-with-pos-p var) + (position-symbol 'ignore var) + 'ignore)) + (newval `(,Ignore + ,(cconv-convert value env extend))) + (msg (cconv--warn-unused-msg var "variable"))) (if (null msg) newval - (macroexp--warn-wrap msg newval 'lexical)))) + (macroexp--warn-wrap var msg newval 'lexical)))) ;; Normal default case. (_ @@ -517,7 +520,7 @@ places where they originally did not directly appear." (newprotform (cconv-convert protected-form env extend))) `(condition-case ,var ,(if msg - (macroexp--warn-wrap msg newprotform 'lexical) + (macroexp--warn-wrap var msg newprotform 'lexical) newprotform) ,@(mapcar (lambda (handler) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index b94737e0fe..43214aab30 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -512,7 +512,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (byte-compile-warning-enabled-p 'obsolete name)) (let* ((obsolete (get name 'byte-obsolete-info))) (macroexp-warn-and-return - ;; org-name + org-name (macroexp--obsolete-warning name obsolete "generic function") nil))) ;; You could argue that `defmethod' modifies rather than defines the diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index dbe0eb1b0e..3659a0c95a 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2449,7 +2449,7 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). (if malformed-bindings (let ((rev-malformed-bindings (nreverse malformed-bindings))) (macroexp-warn-and-return - ;; rev-malformed-bindings + rev-malformed-bindings (format-message "Malformed `cl-symbol-macrolet' binding(s): %S" rev-malformed-bindings) expansion)) @@ -3136,7 +3136,7 @@ To see the documentation for a defined struct type, use (when (cl-oddp (length desc)) (push (macroexp-warn-and-return - ;; (car (last desc)) + (car (last desc)) (format "Missing value for option `%S' of slot `%s' in struct %s!" (car (last desc)) slot name) 'nil) @@ -3146,7 +3146,7 @@ To see the documentation for a defined struct type, use (let ((kw (car defaults))) (push (macroexp-warn-and-return - ;; kw + kw (format " I'll take `%s' to be an option rather than a default value." kw) 'nil) diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index db86e0e029..59038f6e9b 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -230,6 +230,7 @@ INIT-VALUE LIGHTER KEYMAP. (warnwrap (if (or (null body) (keywordp (car body))) #'identity (lambda (exp) (macroexp-warn-and-return + exp "Use keywords rather than deprecated positional arguments to `define-minor-mode'" exp)))) keyw keymap-sym tmp) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 4e9357c2ad..b17ecd34d4 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -744,7 +744,7 @@ Argument FN is the function calling this verifier." ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-slot-names)))) (macroexp-warn-and-return - ;; name + name (format-message "Unknown slot `%S'" name) exp nil 'compile-only)) (_ exp)))) @@ -781,11 +781,13 @@ Fills in CLASS's SLOT with its default value." ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-slot-names)))) (macroexp-warn-and-return + name (format-message "Unknown slot `%S'" name) exp nil 'compile-only)) ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-class-slot-names)))) (macroexp-warn-and-return + name (format-message "Slot `%S' is not class-allocated" name) exp nil 'compile-only)) (_ exp))))) @@ -843,11 +845,13 @@ Fills in the default value in CLASS' in SLOT with VALUE." ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-slot-names)))) (macroexp-warn-and-return + name (format-message "Unknown slot `%S'" name) exp nil 'compile-only)) ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-class-slot-names)))) (macroexp-warn-and-return + name (format-message "Slot `%S' is not class-allocated" name) exp nil 'compile-only)) (_ exp))))) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 76f7b661a6..0d0dff6d68 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -242,7 +242,8 @@ This method is obsolete." `(progn ,@(mapcar (lambda (w) - (macroexp-warn-and-return w `(progn ',w) nil 'compile-only)) + (macroexp-warn-and-return w ; W is probably a poor choice for a position. + w `(progn ',w) nil 'compile-only)) warnings) ;; This test must be created right away so we can have self- ;; referencing classes. ei, a class whose slot can contain only @@ -292,7 +293,7 @@ This method is obsolete." (if (not (stringp (car slots))) whole (macroexp-warn-and-return - ;; (car slots) + (car slots) (format "Obsolete name arg %S to constructor %S" (car slots) (car whole)) ;; Keep the name arg, for backward compatibility, diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index ed33524f2d..eb65e5f104 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -595,7 +595,7 @@ binding mode." (eq (car-safe code) 'cons)) code (macroexp-warn-and-return - ;; org-place + org-place "Use of gv-ref probably requires lexical-binding" code)))) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 6d114a8a54..60fac98130 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -135,18 +135,17 @@ Other uses risk returning non-nil value that point to the wrong file." (defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key)) -(defun macroexp--warn-wrap (msg form category) +(defun macroexp--warn-wrap (arg msg form category) (let ((when-compiled (lambda () (when (byte-compile-warning-enabled-p category) - (byte-compile-warn-x form "%s" msg))))) + (byte-compile-warn-x arg "%s" msg))))) `(progn (macroexp--funcall-if-compiled ',when-compiled) ,form))) (define-obsolete-function-alias 'macroexp--warn-and-return #'macroexp-warn-and-return "28.1") -(defun macroexp-warn-and-return (;; _arg - msg form &optional category compile-only) +(defun macroexp-warn-and-return (arg msg form &optional category compile-only) "Return code equivalent to FORM labeled with warning MSG. CATEGORY is the category of the warning, like the categories that can appear in `byte-compile-warnings'. @@ -161,7 +160,7 @@ is executed without being compiled first." ;; macroexpand-all gets right back to macroexpanding `form'. form (puthash form form macroexp--warned) - (macroexp--warn-wrap msg form category))) + (macroexp--warn-wrap arg msg form category))) (t (unless compile-only (message "%sWarning: %s" @@ -217,7 +216,7 @@ is executed without being compiled first." (let* ((fun (car form)) (obsolete (get fun 'byte-obsolete-info))) (macroexp-warn-and-return - ;; fun + fun (macroexp--obsolete-warning fun obsolete (if (symbolp (symbol-function fun)) @@ -273,6 +272,7 @@ is executed without being compiled first." (setq arglist (cdr arglist))) (if values (macroexp-warn-and-return + name (format (if (eq values 'too-few) "attempt to open-code `%s' with too few arguments" "attempt to open-code `%s' with too many arguments") @@ -332,7 +332,7 @@ Assumes the caller has bound `macroexpand-all-environment'." (if (null body) (macroexp-unprogn (macroexp-warn-and-return - ;; fun + fun (format "Empty %s body" fun) nil nil 'compile-only)) (macroexp--all-forms body)) @@ -370,7 +370,7 @@ Assumes the caller has bound `macroexpand-all-environment'." (eq 'lambda (car-safe (cadr arg)))) (setcar (nthcdr funarg form) (macroexp-warn-and-return - ;; (nth 1 f) + (cadr arg) (format "%S quoted with ' rather than with #'" (let ((f (cadr arg))) (if (symbolp f) f `(lambda ,(nth 1 f) ...)))) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 430ae97078..81280d4e04 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -433,6 +433,7 @@ how many time this CODEGEN is called." (memq (car case) pcase--dontwarn-upats)) (setq main (macroexp-warn-and-return + (car case) (format "pcase pattern %S shadowed by previous pcase pattern" (car case)) main)))) @@ -940,7 +941,7 @@ Otherwise, it defers to REST which is a list of branches of the form (let ((code (pcase--u1 matches code vars rest))) (if (eq upat '_) code (macroexp-warn-and-return - ;; upat + upat "Pattern t is deprecated. Use `_' instead" code)))) ((eq upat 'pcase--dontcare) :pcase--dontcare) diff --git a/src/data.c b/src/data.c index b3b157a7f3..1f2af6f474 100644 --- a/src/data.c +++ b/src/data.c @@ -776,7 +776,7 @@ DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0, DEFUN ("bare-symbol", Fbare_symbol, Sbare_symbol, 1, 1, 0, doc: /* Extract, if need be, the bare symbol from SYM, a symbol. */) - (register Lisp_Object sym) + (register Lisp_Object sym) { if (BARE_SYMBOL_P (sym)) return sym; @@ -786,12 +786,23 @@ DEFUN ("bare-symbol", Fbare_symbol, Sbare_symbol, 1, 1, 0, DEFUN ("symbol-with-pos-pos", Fsymbol_with_pos_pos, Ssymbol_with_pos_pos, 1, 1, 0, doc: /* Extract the position from a symbol with position. */) - (register Lisp_Object ls) + (register Lisp_Object ls) { /* Type checking is done in the following macro. */ return SYMBOL_WITH_POS_POS (ls); } +DEFUN ("remove-pos-from-symbol", Fremove_pos_from_symbol, + Sremove_pos_from_symbol, 1, 1, 0, + doc: /* If ARG is a symbol with position, return it without the position. +Otherwise, return ARG unchanged. Compare with `bare-symbol'. */) + (register Lisp_Object arg) +{ + if (SYMBOL_WITH_POS_P (arg)) + return (SYMBOL_WITH_POS_SYM (arg)); + return arg; +} + DEFUN ("position-symbol", Fposition_symbol, Sposition_symbol, 2, 2, 0, doc: /* Create a new symbol with position. SYM is a symbol, with or without position, the symbol to position. @@ -4193,6 +4204,7 @@ syms_of_data (void) defsubr (&Ssymbol_name); defsubr (&Sbare_symbol); defsubr (&Ssymbol_with_pos_pos); + defsubr (&Sremove_pos_from_symbol); defsubr (&Sposition_symbol); defsubr (&Smakunbound); defsubr (&Sfmakunbound); diff --git a/src/lisp.h b/src/lisp.h index 08013e94d1..00d9843d6a 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -366,7 +366,7 @@ typedef EMACS_INT Lisp_Word; #define lisp_h_PSEUDOVECTORP(a,code) \ (lisp_h_VECTORLIKEP((a)) && \ - ((XUNTAG ((a), Lisp_Vectorlike, union vectorlike_header)->size \ + ((XUNTAG ((a), Lisp_Vectorlike, union vectorlike_header)->size \ & (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK)) \ == (PSEUDOVECTOR_FLAG | ((code) << PSEUDOVECTOR_AREA_BITS)))) @@ -382,13 +382,13 @@ typedef EMACS_INT Lisp_Word; || (symbols_with_pos_enabled \ && (SYMBOL_WITH_POS_P ((x)) \ ? BARE_SYMBOL_P ((y)) \ - ? (XSYMBOL_WITH_POS((x)))->sym == (y) \ + ? XLI (XSYMBOL_WITH_POS((x))->sym) == XLI (y) \ : SYMBOL_WITH_POS_P((y)) \ - && ((XSYMBOL_WITH_POS((x)))->sym \ - == (XSYMBOL_WITH_POS((y)))->sym) \ + && (XLI (XSYMBOL_WITH_POS((x))->sym) \ + == XLI (XSYMBOL_WITH_POS((y))->sym)) \ : (SYMBOL_WITH_POS_P ((y)) \ && BARE_SYMBOL_P ((x)) \ - && ((x) == ((XSYMBOL_WITH_POS ((y)))->sym)))))) + && (XLI (x) == XLI ((XSYMBOL_WITH_POS ((y)))->sym)))))) #define lisp_h_FIXNUMP(x) \ (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) \ diff --git a/src/lread.c b/src/lread.c index 7775911c1d..1cc5acc6d3 100644 --- a/src/lread.c +++ b/src/lread.c @@ -128,9 +128,8 @@ static ptrdiff_t read_from_string_index; static ptrdiff_t read_from_string_index_byte; static ptrdiff_t read_from_string_limit; -/* Number of characters read in the current call to Fread or - Fread_from_string. */ -static EMACS_INT readchar_count; +/* Position in object from which characters are being read by `readchar'. */ +static EMACS_INT readchar_offset; /* This contains the last string skipped with #@. */ static char *saved_doc_string; @@ -213,7 +212,7 @@ readchar (Lisp_Object readcharfun, bool *multibyte) if (multibyte) *multibyte = 0; - readchar_count++; + readchar_offset++; if (BUFFERP (readcharfun)) { @@ -424,7 +423,7 @@ skip_dyn_eof (Lisp_Object readcharfun) static void unreadchar (Lisp_Object readcharfun, int c) { - readchar_count--; + readchar_offset--; if (c == -1) /* Don't back up the pointer if we're unreading the end-of-input mark, since readchar didn't advance it when we read it. */ @@ -2518,7 +2517,7 @@ read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end, { Lisp_Object retval; - readchar_count = 0; + readchar_offset = BUFFERP (stream) ? XBUFFER (stream)->pt : 0; /* We can get called from readevalloop which may have set these already. */ if (! HASH_TABLE_P (read_objects_map) @@ -3773,7 +3772,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list, bool locate_syms) char *p = read_buffer; char *end = read_buffer + read_buffer_size; bool quoted = false; - EMACS_INT start_position = readchar_count - 1; + EMACS_INT start_position = readchar_offset - 1; do { commit 368570b3fd09d03ac5b9276d1ca85ae813c3f385 Author: Alan Mackenzie Date: Mon Nov 29 11:19:31 2021 +0000 First commit of scratch/correct-warning-pos. This branch is intended to generate correct position information in warning and error messages from the byte compiler, and is intended thereby to fix bugs It introduces a new mechanism, the symbol with position. This is taken over from the previous git branch scratch/accurate-warning-pos which was abandoned for being too slow. The main difference in the current branch is that the symbol `nil' is never given a position, thus speeding up NILP markedly. * lisp/emacs-lisp/byte-opt.el (byte-compile-inline-expand) (byte-optimize-form-code-walker, byte-optimize-let-form, byte-optimize-while) (byte-optimize-apply): Use byte-compile-warn-x in place of byte-compile-warn. * lisp/emacs-lisp/bytecomp.el (byte-compile--form-stack): New variable. (byte-compile-strip-s-p-1, byte-compile-strip-symbol-positions): New functions. (byte-compile-recurse-toplevel, byte-compile-initial-macro-environment) (byte-compile-preprocess, byte-compile-macroexpand-declare-function): Bind print-symbols-bare to non-nil. (byte-compile--first-symbol, byte-compile--warning-source-offset): New functions. (byte-compile-warning-prefix): Modify to output two sets of position information, the old (incorrect) set and the new set. (byte-compile-warn): Strip positions from symbols before outputting. (byte-compile-warn-x): New function which outputs a correct position supplied in an argument. (byte-compile-warn-obsolete, byte-compile-emit-callargs-warn) (byte-compile-format-warn, byte-compile-nogroup-warn) (byte-compile-arglist-warn, byte-compile-docstring-length-warn) (byte-compile-warn-about-unresolved-functions, byte-compile-file) (byte-compile--check-prefixed-var, byte-compile--declare-var) (byte-compile-file-form-defvar-function, byte-compile-file-form-defmumble) (byte-compile-check-lambda-list, byte-compile--warn-lexical-dynamic) (byte-compile-lambda, byte-compile-form, byte-compile-normal-call) (byte-compile-check-variable, byte-compile-free-vars-warn) (byte-compile-subr-wrong-args, byte-compile-fset, byte-compile-set-default) (byte-compile-condition-case, byte-compile-save-excursion) (byte-compile-defvar, byte-compile-autoload) (byte-compile-make-variable-buffer-local, byte-compile-define-symbol-prop) (byte-compile-define-keymap): Replace byte-compile-warn with byte-compile-warn-x. (byte-compile-file, compile-defun): Bind symbols-with-pos-enabled to non-nil. (compile-defun, byte-compile-from-buffer): Use `read-positioning-symbols' rather than plain `read'. (byte-compile-toplevel-file-form, byte-compile-form): Dynamically bind byte-compile--form-stack. (byte-compile-file-form-autoload, byte-compile-file-form-defvar) (byte-compile-file-form-make-obsolete, byte-compile-lambda) (byte-compile-push-constant, byte-compile-cond-jump-table) (byte-compile-define-keymap, byte-compile-annotate-call-tree): Strip positions from symbols where they are unwanted. (byte-compile-file-form-defvar): Strip positions from symbols using `bare-symbol'. (byte-compile-file-form-defmumble): New variable bare-name, a version of name without its position. (byte-compile-lambda): Similarly, new variable bare-arglist. (byte-compile-free-vars-warn): New argument arg supplying position information to byte-compile-warn-x. (byte-compile-push-constant): Manipulation of symbol positions. (display-call-tree): Strip positions from symbols. * lisp/emacs-lisp/cconv.el (cconv-convert, cconv--analyze-use) (cconv--analyze-function, cconv-analyze-form): Replace use of byte-compile-warn with byte-compile-warn-x. * lisp/emacs-lisp/cl-generic.el (cl-defmethod): New variable org-name which will supply position information to a new macroexp-warn-and-return. * lisp/emacs-lisp/cl-macs.el (cl-macs--strip-s-p-1) (cl-macs--strip-symbol-positions): New functions to strip positions from symbols in an expression. These duplicaate similarly named functions in bytecomp.el. * lisp/emacs-lisp/macroexpand.el (macroexp--warn-wrap): Calls byte-compile-warn-x in place of byte-compile-warn. (macroexp-warn-and-return): Commented out new position parameter _arg. * src/.gdbinit: Add in code to handle symbols with position. * src/alloc.c (XPNTR, set_symbol_name, valid_lisp_object_p, purecopy) (mark_char_table, mark_object, survives_gc_p, symbol_uses_obj): Use BARE_SYMBOL_P and XBARE_SYMBOL in place of the former SYMBOLP and XSYMBOL. (build_symbol_with_pos): New function. (Fgarbage_collect): Bind Qsymbols_with_pos_enabled to nil around the call to garbage_collect. * src/data.c (Ftype_of): Add case for PVEC_SYMBOL_WITH_POS. (Fbare_symbol_p, Fsymbol_with_pos_p, Fbare_symbol, Fsymbol_with_pos_pos) (Fposition_symbol): New functions. (symbols_with_pos_enabled): New boolean variable. * src/fns.c (internal_equal, hash_lookup): Handle symbols with position. * src/keyboard.c (recursive_edit_1): Bind Qsymbols_with_pos_enabled and Qprint_symbols_bare to nil. * src/lisp.h (lisp_h_PSEUDOVECTORP): New macro. (lisp_h_BASE_EQ): New name for the former lisp_h_EQ. (lisp_h_EQ): Extended to handle symbols with position. (lisp_h_NILP): Now uses BASE_EQ rather than EQ. (lisp_h_SYMBOL_WITH_POS_P, lisp_h_BARE_SYMBOL_P): New macros. (lisp_h_SYMBOLP): Redefined to handle symbols with position. (BARE_SYMBOL_P, BASE_EQ): New macros. (SYMBOLP (macro)): Removed. (SYMBOLP (function), XSYMBOL, make_lisp_symbol, builtin_lisp_symbol) (c_symbol_p): Moved to later in file. (struct Lisp_Symbol_With_Pos): New data type. (pvec_type): PVEC_SYMBOL_WITH_POS: New type code. (PSEUDOVECTORP): Redefined to use the lisp_h_PSEUDOVECTORP. (BARE_SYMBOL_P, SYMBOL_WITH_POS_P, SYMBOLP, XSYMBOL_WITH_POS, XBARE_SYMBOL) (XSYMBOL, make_lisp_symbol, builtin_lisp_symbol, c_symbol_p, CHECK_SYMBOL) (BASE_EQ): New functions, or functions moved from earlier in the file. (SYMBOL_WITH_POS_SYM, SYMBOL_WITH_POS_POS): New INLINE functions. * src/lread.c (read0, read1, read_list, read_vector, read_internal_start) (list2): Add a new bool parameter locate_syms. (Fread_positioning_symbols): New function. (Fread_from_string, read_internal_start, read0, read1, read_list): Pass around suitable values for locate_syms. (read1): Build symbols with position when locate_syms is true. * src/print.c (print_vectorlike): Add handling for PVEC_SYMBOL_WITH_POS. (print_object): Replace EQ with BASE_EQ. (print_symbols_bare): New boolean variable. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index f6db803b78..7750f723ba 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -264,8 +264,9 @@ Earlier variables shadow later ones with the same name.") (cdr (assq name byte-compile-function-environment))))) (pcase fn ('nil - (byte-compile-warn "attempt to inline `%s' before it was defined" - name) + (byte-compile-warn-x name + "attempt to inline `%s' before it was defined" + name) form) (`(autoload . ,_) (error "File `%s' didn't define `%s'" (nth 1 fn) name)) @@ -417,8 +418,8 @@ for speeding up processing.") (t form))) (`(quote . ,v) (if (or (not v) (cdr v)) - (byte-compile-warn "malformed quote form: `%s'" - (prin1-to-string form))) + (byte-compile-warn-x form "malformed quote form: `%s'" + form)) ;; Map (quote nil) to nil to simplify optimizer logic. ;; Map quoted constants to nil if for-effect (just because). (and (car v) @@ -436,8 +437,9 @@ for speeding up processing.") (cons (byte-optimize-form (car clause) nil) (byte-optimize-body (cdr clause) for-effect)) - (byte-compile-warn "malformed cond form: `%s'" - (prin1-to-string clause)) + (byte-compile-warn-x + clause "malformed cond form: `%s'" + clause) clause)) clauses))) (`(progn . ,exps) @@ -513,8 +515,7 @@ for speeding up processing.") `(while ,condition . ,body))) (`(interactive . ,_) - (byte-compile-warn "misplaced interactive spec: `%s'" - (prin1-to-string form)) + (byte-compile-warn-x form "misplaced interactive spec: `%s'" form) nil) (`(function . ,_) @@ -582,7 +583,7 @@ for speeding up processing.") (while args (unless (and (consp args) (symbolp (car args)) (consp (cdr args))) - (byte-compile-warn "malformed setq form: %S" form)) + (byte-compile-warn-x form "malformed setq form: %S" form)) (let* ((var (car args)) (expr (cadr args)) (lexvar (assq var byte-optimize--lexvars)) @@ -615,8 +616,7 @@ for speeding up processing.") (cons fn (mapcar #'byte-optimize-form exps))) (`(,(pred (not symbolp)) . ,_) - (byte-compile-warn "`%s' is a malformed function" - (prin1-to-string fn)) + (byte-compile-warn-x fn "`%s' is a malformed function" fn) form) ((guard (when for-effect @@ -624,8 +624,10 @@ for speeding up processing.") (or byte-compile-delete-errors (eq tmp 'error-free) (progn - (byte-compile-warn "value returned from %s is unused" - (prin1-to-string form)) + (byte-compile-warn-x + form + "value returned from %s is unused" + form) nil))))) (byte-compile-log " %s called for effect; deleted" fn) ;; appending a nil here might not be necessary, but it can't hurt. @@ -821,7 +823,8 @@ for speeding up processing.") (if (symbolp binding) binding (when (or (atom binding) (cddr binding)) - (byte-compile-warn "malformed let binding: `%S'" binding)) + (byte-compile-warn-x + binding "malformed let binding: `%S'" binding)) (list (car binding) (byte-optimize-form (nth 1 binding) nil)))) (car form)) @@ -1304,7 +1307,7 @@ See Info node `(elisp) Integer Basics'." (defun byte-optimize-while (form) (when (< (length form) 2) - (byte-compile-warn "too few arguments for `while'")) + (byte-compile-warn-x form "too few arguments for `while'")) (if (nth 1 form) form)) @@ -1342,9 +1345,10 @@ See Info node `(elisp) Integer Basics'." (let ((butlast (nreverse (cdr (reverse (cdr (cdr form))))))) (nconc (list 'funcall fn) butlast (mapcar (lambda (x) (list 'quote x)) (nth 1 last)))) - (byte-compile-warn + (byte-compile-warn-x + last "last arg to apply can't be a literal atom: `%s'" - (prin1-to-string last)) + last) nil)) form)))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 566a3fdf99..869b6c01b8 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -459,6 +459,42 @@ Filled in `cconv-analyze-form' but initialized and consulted here.") (defvar byte-compiler-error-flag) +(defvar byte-compile--form-stack nil + "Dynamic list of successive enclosing forms. +This is used by the warning message routines to determine a +source code position. The most accessible element is the current +most deeply nested form.") + +(defun byte-compile-strip-s-p-1 (arg) + "Strip all positions from symbols in ARG, destructively modifying ARG. +Return the modified ARG." + (cond + ((symbolp arg) + (bare-symbol arg)) + ((consp arg) + (let ((a arg)) + (while (consp (cdr a)) + (setcar a (byte-compile-strip-s-p-1 (car a))) + (setq a (cdr a))) + (setcar a (byte-compile-strip-s-p-1 (car a))) + ;; (if (cdr a) + (unless (bare-symbol-p (cdr a)) ; includes (unpositioned) nil. + (setcdr a (byte-compile-strip-s-p-1 (cdr a))))) + arg) + ((vectorp arg) + (let ((i 0) + (len (length arg))) + (while (< i len) + (aset arg i (byte-compile-strip-s-p-1 (aref arg i))) + (setq i (1+ i)))) + arg) + (t arg))) + +(defun byte-compile-strip-symbol-positions (arg) + "Strip all positions from symbols (recursively) in ARG. Don't modify ARG." + (let ((arg1 (copy-tree arg t))) + (byte-compile-strip-s-p-1 arg1))) + (defun byte-compile-recurse-toplevel (form non-toplevel-case) "Implement `eval-when-compile' and `eval-and-compile'. Return the compile-time value of FORM." @@ -467,7 +503,8 @@ Return the compile-time value of FORM." ;; 3.2.3.1, "Processing of Top Level Forms". The semantics are very ;; subtle: see test/lisp/emacs-lisp/bytecomp-tests.el for interesting ;; cases. - (setf form (macroexp-macroexpand form byte-compile-macro-environment)) + (let ((print-symbols-bare t)) + (setf form (macroexp-macroexpand form byte-compile-macro-environment))) (if (eq (car-safe form) 'progn) (cons 'progn (mapcar (lambda (subform) @@ -508,7 +545,8 @@ Return the compile-time value of FORM." ;; Don't compile here, since we don't know ;; whether to compile as byte-compile-form ;; or byte-compile-file-form. - (let ((expanded + (let* ((print-symbols-bare t) + (expanded (macroexpand-all form macroexpand-all-environment))) @@ -1212,6 +1250,41 @@ message buffer `default-directory'." (f2 (file-relative-name file dir))) (if (< (length f2) (length f1)) f2 f1))) +(defun byte-compile--first-symbol (form) + "Return the \"first\" symbol found in form, or 0 if there is none. +Here, \"first\" is by a depth first search." + (let (sym) + (cond + ((symbolp form) form) + ((consp form) + (or (and (symbolp (setq sym (byte-compile--first-symbol (car form)))) + sym) + (and (symbolp (setq sym (byte-compile--first-symbol (cdr form)))) + sym) + 0)) + ((and (vectorp form) + (> (length form) 0)) + (let ((i 0) + (len (length form)) + elt) + (catch 'sym + (while (< i len) + (when (symbolp + (setq elt (byte-compile--first-symbol (aref form i)))) + (throw 'sym elt)) + (setq i (1+ i))) + 0))) + (t 0)))) + +(defun byte-compile--warning-source-offset () + "Return a source offset from `byte-compile--form-stack'. +Return nil if such is not found." + (catch 'offset + (dolist (form byte-compile--form-stack) + (let ((s (byte-compile--first-symbol form))) + (if (symbol-with-pos-p s) + (throw 'offset (symbol-with-pos-pos s))))))) + ;; This is used as warning-prefix for the compiler. ;; It is always called with the warnings buffer current. (defun byte-compile-warning-prefix (level entry) @@ -1229,16 +1302,36 @@ message buffer `default-directory'." (format "%s:" (byte-compile-abbreviate-file load-file-name dir))) (t ""))) + (offset (byte-compile--warning-source-offset)) (pos (if (and byte-compile-current-file - (integerp byte-compile-read-position)) + (integerp byte-compile-read-position) + (or offset (not symbols-with-pos-enabled))) (with-current-buffer byte-compile-current-buffer - (format "%d:%d:" - (save-excursion - (goto-char byte-compile-last-position) - (1+ (count-lines (point-min) (point-at-bol)))) - (save-excursion - (goto-char byte-compile-last-position) - (1+ (current-column))))) + ;; (format "%d:%d:" + ;; (save-excursion + ;; (goto-char (if symbols-with-pos-enabled + ;; (+ byte-compile-read-position offset) + ;; byte-compile-last-position) + ;; ) + ;; (1+ (count-lines (point-min) (point-at-bol)))) + ;; (save-excursion + ;; (goto-char (if symbols-with-pos-enabled + ;; (+ byte-compile-read-position offset) + ;; byte-compile-last-position) + ;; ) + ;; (1+ (current-column)))) +;;;; EXPERIMENTAL STOUGH, 2018-11-22 + (let (old-l old-c new-l new-c) + (save-excursion + (goto-char byte-compile-last-position) + (setq old-l (1+ (count-lines (point-min) (point-at-bol))) + old-c (1+ (current-column))) + (goto-char (+ byte-compile-read-position offset)) + (setq new-l (1+ (count-lines (point-min) (point-at-bol))) + new-c (1+ (current-column))) + (format "%d:%d:%d:%d:" old-l old-c new-l new-c))) +;;;; END OF EXPERIMENTAL STOUGH + ) "")) (form (if (eq byte-compile-current-form :end) "end of data" (or byte-compile-current-form "toplevel form")))) @@ -1342,11 +1435,25 @@ function directly; use `byte-compile-warn' or (defun byte-compile-warn (format &rest args) "Issue a byte compiler warning; use (format-message FORMAT ARGS...) for message." + (setq args + (mapcar (lambda (arg) + (if (symbolp arg) + (bare-symbol arg) + arg)) + args)) (setq format (apply #'format-message format args)) (if byte-compile-error-on-warn (error "%s" format) ; byte-compile-file catches and logs it (byte-compile-log-warning format t :warning))) +(defun byte-compile-warn-x (arg format &rest args) + "Issue a byte compiler warning. +ARG is the source element (likely a symbol with position) central to + the warning, intended to supply source position information. +FORMAT and ARGS are as in `byte-compile-warn'." + (let ((byte-compile--form-stack (cons arg byte-compile--form-stack))) + (apply #'byte-compile-warn format args))) + (defun byte-compile-warn-obsolete (symbol) "Warn that SYMBOL (a variable or function) is obsolete." (when (byte-compile-warning-enabled-p 'obsolete symbol) @@ -1356,7 +1463,7 @@ function directly; use `byte-compile-warn' or (or funcp (get symbol 'byte-obsolete-variable)) (if funcp "function" "variable")))) (unless (and funcp (memq symbol byte-compile-not-obsolete-funcs)) - (byte-compile-warn "%s" msg))))) + (byte-compile-warn-x symbol "%s" msg))))) (defun byte-compile-report-error (error-info &optional fill) "Report Lisp error in compilation. @@ -1481,7 +1588,8 @@ when printing the error message." (defun byte-compile-emit-callargs-warn (name actual-args min-args max-args) (byte-compile-set-symbol-position name) - (byte-compile-warn + (byte-compile-warn-x + name "%s called with %d argument%s, but %s %s" name actual-args (if (= 1 actual-args) "" "s") @@ -1547,7 +1655,7 @@ extra args." n))) (nargs (- (length form) 2))) (unless (= nargs nfields) - (byte-compile-warn + (byte-compile-warn-x (car form) "`%s' called with %d args to fill %d format field(s)" (car form) nargs nfields))))) @@ -1561,7 +1669,7 @@ extra args." (when (eq (car-safe name) 'quote) (or (not (eq (car form) 'custom-declare-variable)) (plist-get keyword-args :type) - (byte-compile-warn + (byte-compile-warn-x (cadr name) "defcustom for `%s' fails to specify type" (cadr name))) (if (and (memq (car form) '(custom-declare-face custom-declare-variable)) byte-compile-current-group) @@ -1570,7 +1678,7 @@ extra args." (or (and (eq (car form) 'custom-declare-group) (equal name ''emacs)) (plist-get keyword-args :group) - (byte-compile-warn + (byte-compile-warn-x (cadr name) "%s for `%s' fails to specify containing group" (cdr (assq (car form) '((custom-declare-group . defgroup) @@ -1589,7 +1697,7 @@ extra args." (let ((calls (assq name byte-compile-unresolved-functions)) nums sig min max) (when (and calls macrop) - (byte-compile-warn "macro `%s' defined too late" name)) + (byte-compile-warn-x name "macro `%s' defined too late" name)) (setq byte-compile-unresolved-functions (delq calls byte-compile-unresolved-functions)) (setq calls (delq t calls)) ;Ignore higher-order uses of the function. @@ -1597,8 +1705,8 @@ extra args." (when (and (symbolp name) (eq (function-get name 'byte-optimizer) 'byte-compile-inline-expand)) - (byte-compile-warn "defsubst `%s' was used before it was defined" - name)) + (byte-compile-warn-x name "defsubst `%s' was used before it was defined" + name)) (setq sig (byte-compile-arglist-signature arglist) nums (sort (copy-sequence (cddr calls)) (function <)) min (car nums) @@ -1606,7 +1714,8 @@ extra args." (when (or (< min (car sig)) (and (cdr sig) (> max (cdr sig)))) (byte-compile-set-symbol-position name) - (byte-compile-warn + (byte-compile-warn-x + name "%s being defined to take %s%s, but was previously called with %s" name (byte-compile-arglist-signature-string sig) @@ -1625,7 +1734,8 @@ extra args." (sig2 (byte-compile-arglist-signature arglist))) (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2) (byte-compile-set-symbol-position name) - (byte-compile-warn + (byte-compile-warn-x + name "%s %s used to take %s %s, now takes %s" (if macrop "macro" "function") name @@ -1714,8 +1824,10 @@ It is too wide if it has any lines longer than the largest of (setq name (if name (format " `%s'" name) "")) (when (and kind docs (stringp docs) (byte-compile--wide-docstring-p docs col)) - (byte-compile-warn "%s%s docstring wider than %s characters" - kind name col)))) + (byte-compile-warn-x + name + "%s%s docstring wider than %s characters" + kind name col)))) form) ;; If we have compiled any calls to functions which are not known to be @@ -1730,7 +1842,8 @@ It is too wide if it has any lines longer than the largest of (let ((f (car urf))) (when (not (memq f byte-compile-new-defuns)) (let ((byte-compile-last-position (cadr urf))) - (byte-compile-warn + (byte-compile-warn-x + f (if (fboundp f) "the function `%s' might not be defined at runtime." "the function `%s' is not known to be defined.") (car urf)))))))) nil) @@ -2083,7 +2196,8 @@ See also `emacs-lisp-byte-compile-and-load'." ;; within byte-compile-from-buffer lingers in that buffer. (setq output-buffer (save-current-buffer - (let ((byte-compile-level (1+ byte-compile-level))) + (let ((symbols-with-pos-enabled t) + (byte-compile-level (1+ byte-compile-level))) (byte-compile-from-buffer input-buffer)))) (if byte-compiler-error-flag nil @@ -2195,11 +2309,12 @@ With argument ARG, insert value in current buffer after the form." (byte-compile-last-warned-form 'nothing) (value (eval (let ((read-with-symbol-positions (current-buffer)) - (read-symbol-positions-list nil)) + (read-symbol-positions-list nil) + (symbols-with-pos-enabled t)) (displaying-byte-compile-warnings (byte-compile-sexp (eval-sexp-add-defvars - (read (current-buffer)) + (read-positioning-symbols (current-buffer)) byte-compile-read-position)))) lexical-binding))) (cond (arg @@ -2284,9 +2399,9 @@ With argument ARG, insert value in current buffer after the form." (setq byte-compile-read-position (point) byte-compile-last-position byte-compile-read-position) (let* ((lread--unescaped-character-literals nil) - (form (read inbuffer)) + (form (read-positioning-symbols inbuffer)) (warning (byte-run--unescaped-character-literals-warning))) - (when warning (byte-compile-warn "%s" warning)) + (when warning (byte-compile-warn-x form "%s" warning)) (byte-compile-toplevel-file-form form))) ;; Compile pending forms at end of file. (byte-compile-flush-pending) @@ -2496,7 +2611,8 @@ list that represents a doc string reference. byte-compile-jump-tables nil)))) (defun byte-compile-preprocess (form &optional _for-effect) - (setq form (macroexpand-all form byte-compile-macro-environment)) + (let ((print-symbols-bare t)) + (setq form (macroexpand-all form byte-compile-macro-environment))) ;; FIXME: We should run byte-optimize-form here, but it currently does not ;; recurse through all the code, so we'd have to fix this first. ;; Maybe a good fix would be to merge byte-optimize-form into @@ -2509,11 +2625,13 @@ list that represents a doc string reference. ;; byte-hunk-handlers cannot call this! (defun byte-compile-toplevel-file-form (top-level-form) - (byte-compile-recurse-toplevel - top-level-form - (lambda (form) - (let ((byte-compile-current-form nil)) ; close over this for warnings. - (byte-compile-file-form (byte-compile-preprocess form t)))))) + (let ((byte-compile--form-stack + (cons top-level-form byte-compile--form-stack))) + (byte-compile-recurse-toplevel + top-level-form + (lambda (form) + (let ((byte-compile-current-form nil)) ; close over this for warnings. + (byte-compile-file-form (byte-compile-preprocess form t))))))) ;; byte-hunk-handlers can call this. (defun byte-compile-file-form (form) @@ -2546,7 +2664,8 @@ list that represents a doc string reference. ;; byte-compile-noruntime-functions, in case we have an autoload ;; of foo-func following an (eval-when-compile (require 'foo)). (unless (fboundp funsym) - (push (cons funsym (cons 'autoload (cdr (cdr form)))) + (push (byte-compile-strip-symbol-positions + (cons funsym (cons 'autoload (cdr (cdr form))))) byte-compile-function-environment)) ;; If an autoload occurs _before_ the first call to a function, ;; byte-compile-callargs-warn does not add an entry to @@ -2562,7 +2681,7 @@ list that represents a doc string reference. (delq (assq funsym byte-compile-unresolved-functions) byte-compile-unresolved-functions))))) (if (stringp (nth 3 form)) - (prog1 form + (prog1 (byte-compile-strip-symbol-positions form) (byte-compile-docstring-length-warn form)) ;; No doc string, so we can compile this as a normal form. (byte-compile-keep-pending form 'byte-compile-normal-call))) @@ -2574,7 +2693,8 @@ list that represents a doc string reference. (when (and (symbolp sym) (not (string-match "[-*/:$]" (symbol-name sym))) (byte-compile-warning-enabled-p 'lexical sym)) - (byte-compile-warn "global/dynamic var `%s' lacks a prefix" sym))) + (byte-compile-warn-x + sym "global/dynamic var `%s' lacks a prefix" sym))) (defun byte-compile--declare-var (sym) (byte-compile--check-prefixed-var sym) @@ -2582,7 +2702,7 @@ list that represents a doc string reference. (setq byte-compile-lexical-variables (delq sym byte-compile-lexical-variables)) (when (byte-compile-warning-enabled-p 'lexical sym) - (byte-compile-warn "Variable `%S' declared after its first use" sym))) + (byte-compile-warn-x sym "Variable `%S' declared after its first use" sym))) (push sym byte-compile-bound-variables) (push sym byte-compile--seen-defvars)) @@ -2595,10 +2715,17 @@ list that represents a doc string reference. (eq (car form) 'defvar)) ;Just a declaration. nil (byte-compile-docstring-length-warn form) + (setq form (copy-sequence form)) (cond ((consp (nth 2 form)) - (setq form (copy-sequence form)) (setcar (cdr (cdr form)) - (byte-compile-top-level (nth 2 form) nil 'file)))) + (byte-compile-top-level (nth 2 form) nil 'file))) + ((symbolp (nth 2 form)) + (setcar (cddr form) (bare-symbol (nth 2 form)))) + (t (setcar (cddr form) + (byte-compile-strip-symbol-positions (nth 2 form))))) + (setcar form (bare-symbol (car form))) + (if (symbolp (nth 1 form)) + (setcar (cdr form) (bare-symbol (nth 1 form)))) form)) (put 'define-abbrev-table 'byte-hunk-handler @@ -2616,7 +2743,8 @@ list that represents a doc string reference. (`(defvaralias ,_ ',newname . ,_) (when (memq newname byte-compile-bound-variables) (if (byte-compile-warning-enabled-p 'suspicious) - (byte-compile-warn + (byte-compile-warn-x + newname "Alias for `%S' should be declared before its referent" newname))))) (byte-compile-docstring-length-warn form) (byte-compile-keep-pending form)) @@ -2675,7 +2803,9 @@ list that represents a doc string reference. (put 'make-obsolete 'byte-hunk-handler 'byte-compile-file-form-make-obsolete) (defun byte-compile-file-form-make-obsolete (form) (prog1 (byte-compile-keep-pending form) - (apply 'make-obsolete (mapcar 'eval (cdr form))))) + (apply 'make-obsolete + (mapcar 'eval + (byte-compile-strip-symbol-positions (cdr form)))))) ;; This handler is not necessary, but it makes the output from dont-compile ;; and similar macros cleaner. @@ -2699,23 +2829,24 @@ not to take responsibility for the actual compilation of the code." 'byte-compile-macro-environment)) (this-one (assq name (symbol-value this-kind))) (that-one (assq name (symbol-value that-kind))) + (bare-name (bare-symbol name)) (byte-compile-current-form name)) ; For warnings. (byte-compile-set-symbol-position name) - (push name byte-compile-new-defuns) + (push bare-name byte-compile-new-defuns) ;; When a function or macro is defined, add it to the call tree so that ;; we can tell when functions are not used. (if byte-compile-generate-call-tree - (or (assq name byte-compile-call-tree) + (or (assq bare-name byte-compile-call-tree) (setq byte-compile-call-tree - (cons (list name nil nil) byte-compile-call-tree)))) + (cons (list bare-name nil nil) byte-compile-call-tree)))) (if (byte-compile-warning-enabled-p 'redefine name) (byte-compile-arglist-warn name arglist macro)) (if byte-compile-verbose (message "Compiling %s... (%s)" - (or byte-compile-current-file "") name)) + (or byte-compile-current-file "") bare-name)) (cond ((not (or macro (listp body))) ;; We do not know positively if the definition is a macro ;; or a function, so we shouldn't emit warnings. @@ -2724,29 +2855,34 @@ not to take responsibility for the actual compilation of the code." (that-one (if (and (byte-compile-warning-enabled-p 'redefine name) ;; Don't warn when compiling the stubs in byte-run... - (not (assq name byte-compile-initial-macro-environment))) - (byte-compile-warn + (not (assq bare-name byte-compile-initial-macro-environment))) + (byte-compile-warn-x + name "`%s' defined multiple times, as both function and macro" - name)) + bare-name)) (setcdr that-one nil)) (this-one (when (and (byte-compile-warning-enabled-p 'redefine name) ;; Hack: Don't warn when compiling the magic internal ;; byte-compiler macros in byte-run.el... - (not (assq name byte-compile-initial-macro-environment))) - (byte-compile-warn "%s `%s' defined multiple times in this file" - (if macro "macro" "function") - name))) - ((eq (car-safe (symbol-function name)) + (not (assq bare-name byte-compile-initial-macro-environment))) + (byte-compile-warn-x + name + "%s `%s' defined multiple times in this file" + (if macro "macro" "function") + bare-name))) + ((eq (car-safe (symbol-function bare-name)) (if macro 'lambda 'macro)) - (when (byte-compile-warning-enabled-p 'redefine name) - (byte-compile-warn "%s `%s' being redefined as a %s" - (if macro "function" "macro") - name - (if macro "macro" "function"))) + (when (byte-compile-warning-enabled-p 'redefine bare-name) + (byte-compile-warn-x + name + "%s `%s' being redefined as a %s" + (if macro "function" "macro") + bare-name + (if macro "macro" "function"))) ;; Shadow existing definition. (set this-kind - (cons (cons name nil) + (cons (cons bare-name nil) (symbol-value this-kind)))) ) @@ -2757,8 +2893,8 @@ not to take responsibility for the actual compilation of the code." (stringp (car-safe (cdr-safe (cdr-safe body))))) ;; FIXME: We've done that already just above, so this looks wrong! ;;(byte-compile-set-symbol-position name) - (byte-compile-warn "probable `\"' without `\\' in doc string of %s" - name)) + (byte-compile-warn-x + name "probable `\"' without `\\' in doc string of %s" bare-name)) (if (not (listp body)) ;; The precise definition requires evaluation to find out, so it @@ -2766,7 +2902,7 @@ not to take responsibility for the actual compilation of the code." ;; For a macro, that means we can't use that macro in the same file. (progn (unless macro - (push (cons name (if (listp arglist) `(declared ,arglist) t)) + (push (cons bare-name (if (listp arglist) `(declared ,arglist) t)) byte-compile-function-environment)) ;; Tell the caller that we didn't compile it yet. nil) @@ -2776,10 +2912,10 @@ not to take responsibility for the actual compilation of the code." ;; A definition in b-c-initial-m-e should always take precedence ;; during compilation, so don't let it be redefined. (Bug#8647) (or (and macro - (assq name byte-compile-initial-macro-environment)) + (assq bare-name byte-compile-initial-macro-environment)) (setcdr this-one code)) (set this-kind - (cons (cons name code) + (cons (cons bare-name code) (symbol-value this-kind)))) (if rest @@ -2806,7 +2942,7 @@ not to take responsibility for the actual compilation of the code." ;; b-c-output-file-form analyze the defalias. (byte-compile-output-docform "\n(defalias '" - name + bare-name (if macro `(" '(macro . #[" ,index "])") `(" #[" ,index "]")) (append code nil) ; Turn byte-code-function-p into list. (and (atom code) byte-compile-dynamic @@ -2950,7 +3086,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." ((and (memq arg vars) ;; Allow repetitions for unused args. (not (string-match "\\`_" (symbol-name arg)))) - (byte-compile-warn "repeated variable %s in lambda-list" arg)) + (byte-compile-warn-x + arg "repeated variable %s in lambda-list" arg)) (t (push arg vars)))) (setq list (cdr list))))) @@ -2993,7 +3130,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." (defun byte-compile--warn-lexical-dynamic (var context) (when (byte-compile-warning-enabled-p 'lexical-dynamic var) - (byte-compile-warn + (byte-compile-warn-x + var "`%s' lexically bound in %s here but declared dynamic in: %s" var context (mapconcat #'identity @@ -3045,8 +3183,8 @@ for symbols generated by the byte compiler itself." ;; Check that the bit after the `interactive' spec is ;; just a list of symbols (i.e., modes). (unless (seq-every-p #'symbolp (cdr (cdr int))) - (byte-compile-warn "malformed interactive specc: %s" - (prin1-to-string int))) + (byte-compile-warn-x int "malformed interactive specc: %s" + int)) (setq command-modes (cdr (cdr int))) ;; If the interactive spec is a call to `list', don't ;; compile it, because `call-interactively' looks at the @@ -3058,16 +3196,17 @@ for symbols generated by the byte compiler itself." (while (consp (cdr form)) (setq form (cdr form))) (setq form (car form))) - (when (or (not (eq (car-safe form) 'list)) - ;; For code using lexical-binding, form is not - ;; valid lisp, but rather an intermediate form - ;; which may include "calls" to - ;; internal-make-closure (Bug#29988). - lexical-binding) - (setq int `(interactive ,newform))))) + (if (or (not (eq (car-safe form) 'list)) + ;; For code using lexical-binding, form is not + ;; valid lisp, but rather an intermediate form + ;; which may include "calls" to + ;; internal-make-closure (Bug#29988). + lexical-binding) + (setq int (byte-compile-strip-symbol-positions `(interactive ,newform))) + (setq int (byte-compile-strip-symbol-positions int))))) ((cdr int) ; Invalid (interactive . something). - (byte-compile-warn "malformed interactive spec: %s" - (prin1-to-string int))))) + (byte-compile-warn-x int "malformed interactive spec: %s" + int)))) ;; Process the body. (let ((compiled (byte-compile-top-level (cons 'progn body) nil 'lambda @@ -3078,14 +3217,15 @@ for symbols generated by the byte compiler itself." (and lexical-binding (byte-compile-make-lambda-lexenv arglistvars)) - reserved-csts))) + reserved-csts)) + (bare-arglist (byte-compile-strip-symbol-positions arglist))) ;; Build the actual byte-coded function. (cl-assert (eq 'byte-code (car-safe compiled))) (let ((out (apply #'make-byte-code (if lexical-binding (byte-compile-make-args-desc arglist) - arglist) + bare-arglist) (append ;; byte-string, constants-vector, stack depth (cdr compiled) @@ -3093,7 +3233,7 @@ for symbols generated by the byte compiler itself." (cond ((and lexical-binding arglist) ;; byte-compile-make-args-desc lost the args's names, ;; so preserve them in the docstring. - (list (help-add-fundoc-usage doc arglist))) + (list (help-add-fundoc-usage doc bare-arglist))) ((or doc int) (list doc))) ;; optionally, the interactive spec (and the modes the @@ -3101,7 +3241,9 @@ for symbols generated by the byte compiler itself." (cond ;; We have some command modes, so use the vector form. (command-modes - (list (vector (nth 1 int) command-modes))) + (list (vector (nth 1 int) + (byte-compile-strip-symbol-positions + command-modes)))) ;; No command modes, use the simple form with just the ;; interactive spec. (int @@ -3298,7 +3440,8 @@ for symbols generated by the byte compiler itself." (setq byte-compile-noruntime-functions (delq fn byte-compile-noruntime-functions)) ;; Delegate the rest to the normal macro definition. - (macroexpand `(declare-function ,fn ,file ,@args))) + (let ((print-symbols-bare t)) + (macroexpand `(declare-function ,fn ,file ,@args)))) ;; This is the recursive entry point for compiling each subform of an @@ -3315,19 +3458,21 @@ for symbols generated by the byte compiler itself." ;; byte-compile--for-effect flag too.) ;; (defun byte-compile-form (form &optional for-effect) - (let ((byte-compile--for-effect for-effect)) + (let ((byte-compile--for-effect for-effect) + (byte-compile--form-stack (cons form byte-compile--form-stack))) (cond ((not (consp form)) (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form)) (when (symbolp form) (byte-compile-set-symbol-position form)) - (byte-compile-constant form)) + (byte-compile-constant + (if (symbolp form) (bare-symbol form) form))) ((and byte-compile--for-effect byte-compile-delete-errors) (when (symbolp form) (byte-compile-set-symbol-position form)) (setq byte-compile--for-effect nil)) (t - (byte-compile-variable-ref form)))) + (byte-compile-variable-ref (bare-symbol form))))) ((symbolp (car form)) (let* ((fn (car form)) (handler (get fn 'byte-compile)) @@ -3350,20 +3495,20 @@ for symbols generated by the byte compiler itself." (byte-compile-check-variable (cadr hook) nil)))) (when (and (byte-compile-warning-enabled-p 'suspicious) (macroexp--const-symbol-p fn)) - (byte-compile-warn "`%s' called as a function" fn)) + (byte-compile-warn-x fn "`%s' called as a function" fn)) (when (and (byte-compile-warning-enabled-p 'interactive-only fn) interactive-only) - (byte-compile-warn "`%s' is for interactive use only%s" - fn - (cond ((stringp interactive-only) - (format "; %s" - (substitute-command-keys - interactive-only))) - ((and (symbolp 'interactive-only) - (not (eq interactive-only t))) - (format-message "; use `%s' instead." - interactive-only)) - (t ".")))) + (byte-compile-warn-x fn "`%s' is for interactive use only%s" + fn + (cond ((stringp interactive-only) + (format "; %s" + (substitute-command-keys + interactive-only))) + ((and (symbolp 'interactive-only) + (not (eq interactive-only t))) + (format-message "; use `%s' instead." + interactive-only)) + (t ".")))) (if (eq (car-safe (symbol-function (car form))) 'macro) (byte-compile-report-error (format "`%s' defined after use in %S (missing `require' of a library file?)" @@ -3403,7 +3548,8 @@ for symbols generated by the byte compiler itself." (when (and byte-compile--for-effect (eq (car form) 'mapcar) (byte-compile-warning-enabled-p 'mapcar 'mapcar)) (byte-compile-set-symbol-position 'mapcar) - (byte-compile-warn + (byte-compile-warn-x + (car form) "`mapcar' called for effect; use `mapc' or `dolist' instead")) (byte-compile-push-constant (car form)) (mapc 'byte-compile-form (cdr form)) ; wasteful, but faster. @@ -3539,11 +3685,13 @@ for symbols generated by the byte compiler itself." (cond ((or (not (symbolp var)) (macroexp--const-symbol-p var)) (when (byte-compile-warning-enabled-p 'constants (and (symbolp var) var)) - (byte-compile-warn (if (eq access-type 'let-bind) - "attempt to let-bind %s `%s'" - "variable reference to %s `%s'") - (if (symbolp var) "constant" "nonvariable") - (prin1-to-string var)))) + (byte-compile-warn-x + var + (if (eq access-type 'let-bind) + "attempt to let-bind %s `%s'" + "variable reference to %s `%s'") + (if (symbolp var) "constant" "nonvariable") + var))) ((let ((od (get var 'byte-obsolete-variable))) (and od (not (memq var byte-compile-not-obsolete-vars)) @@ -3556,6 +3704,7 @@ for symbols generated by the byte compiler itself." (byte-compile-warn-obsolete var)))) (defsubst byte-compile-dynamic-variable-op (base-op var) + (if (symbolp var) (setq var (bare-symbol var))) (let ((tmp (assq var byte-compile-variables))) (unless tmp (setq tmp (list var)) @@ -3568,9 +3717,10 @@ for symbols generated by the byte compiler itself." (push var byte-compile-bound-variables) (byte-compile-dynamic-variable-op 'byte-varbind var)) -(defun byte-compile-free-vars-warn (var &optional assignment) +(defun byte-compile-free-vars-warn (arg var &optional assignment) "Warn if symbol VAR refers to a free variable. VAR must not be lexically bound. +ARG is a position argument, used by byte-compile-warn-x. If optional argument ASSIGNMENT is non-nil, this is treated as an assignment (i.e. `setq')." (unless (or (not (byte-compile-warning-enabled-p 'free-vars var)) @@ -3582,9 +3732,9 @@ assignment (i.e. `setq')." (let* ((varname (prin1-to-string var)) (desc (if assignment "assignment" "reference")) (suggestions (help-uni-confusable-suggestions varname))) - (byte-compile-warn "%s to free variable `%s'%s" - desc varname - (if suggestions (concat "\n " suggestions) ""))) + (byte-compile-warn-x arg "%s to free variable `%s'%s" + desc var + (if suggestions (concat "\n " suggestions) ""))) (push var (if assignment byte-compile-free-assignments byte-compile-free-references)))) @@ -3597,7 +3747,7 @@ assignment (i.e. `setq')." ;; VAR is lexically bound (byte-compile-stack-ref (cdr lex-binding)) ;; VAR is dynamically bound - (byte-compile-free-vars-warn var) + (byte-compile-free-vars-warn var var) (byte-compile-dynamic-variable-op 'byte-varref var)))) (defun byte-compile-variable-set (var) @@ -3608,7 +3758,7 @@ assignment (i.e. `setq')." ;; VAR is lexically bound. (byte-compile-stack-set (cdr lex-binding)) ;; VAR is dynamically bound. - (byte-compile-free-vars-warn var t) + (byte-compile-free-vars-warn var var t) (byte-compile-dynamic-variable-op 'byte-varset var)))) (defmacro byte-compile-get-constant (const) @@ -3628,14 +3778,19 @@ assignment (i.e. `setq')." (defun byte-compile-constant (const) (if byte-compile--for-effect (setq byte-compile--for-effect nil) - (inline (byte-compile-push-constant const)))) + (inline (byte-compile-push-constant + (if (symbolp const) (bare-symbol const) const))))) ;; Use this for a constant that is not the value of its containing form. ;; This ignores byte-compile--for-effect. (defun byte-compile-push-constant (const) (when (symbolp const) - (byte-compile-set-symbol-position const)) - (byte-compile-out 'byte-constant (byte-compile-get-constant const))) + (byte-compile-set-symbol-position const) + (setq const (bare-symbol const))) + (byte-compile-out + 'byte-constant + (byte-compile-get-constant + (byte-compile-strip-symbol-positions const)))) ;; Compile those primitive ordinary functions ;; which have special byte codes just for speed. @@ -3788,9 +3943,10 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (defun byte-compile-subr-wrong-args (form n) (byte-compile-set-symbol-position (car form)) - (byte-compile-warn "`%s' called with %d arg%s, but requires %s" - (car form) (length (cdr form)) - (if (= 1 (length (cdr form))) "" "s") n) + (byte-compile-warn-x (car form) + "`%s' called with %d arg%s, but requires %s" + (car form) (length (cdr form)) + (if (= 1 (length (cdr form))) "" "s") n) ;; Get run-time wrong-number-of-args error. (byte-compile-normal-call form)) @@ -4099,7 +4255,8 @@ discarding." (if (eq 'interactive (car-safe (car body))) (setq body (cdr body))) (if (and (consp (car body)) (not (eq 'byte-code (car (car body))))) - (byte-compile-warn + (byte-compile-warn-x + (nth 2 form) "A quoted lambda form is the second argument of `fset'. This is probably not what you want, as that lambda cannot be compiled. Consider using the syntax #'(lambda (...) ...) instead."))))) @@ -4184,10 +4341,11 @@ discarding." (macroexp--const-symbol-p var t)) (byte-compile-warning-enabled-p 'constants (and (symbolp var) var)) - (byte-compile-warn + (byte-compile-warn-x + var "variable assignment to %s `%s'" (if (symbolp var) "constant" "nonvariable") - (prin1-to-string var))))) + var)))) (byte-compile-normal-call form))) (defun byte-compile-quote (form) @@ -4466,7 +4624,7 @@ Return (TAIL VAR TEST CASES), where: (dolist (case cases) (setq tag (byte-compile-make-tag) - test-objects (car case) + test-objects (byte-compile-strip-symbol-positions (car case)) body (cdr case)) (byte-compile-out-tag tag) (dolist (value test-objects) @@ -4772,16 +4930,16 @@ binding slots have been popped." (endtag (byte-compile-make-tag))) (byte-compile-set-symbol-position 'condition-case) (unless (symbolp var) - (byte-compile-warn - "`%s' is not a variable-name or nil (in condition-case)" var)) + (byte-compile-warn-x + var "`%s' is not a variable-name or nil (in condition-case)" var)) (dolist (clause (reverse clauses)) (let ((condition (nth 1 clause))) (unless (consp condition) (setq condition (list condition))) (dolist (c condition) (unless (and c (symbolp c)) - (byte-compile-warn - "`%S' is not a condition name (in condition-case)" c)) + (byte-compile-warn-x + c "`%S' is not a condition name (in condition-case)" c)) ;; In reality, the `error-conditions' property is only required ;; for the argument to `signal', not to `condition-case'. ;;(unless (consp (get c 'error-conditions)) @@ -4832,7 +4990,8 @@ binding slots have been popped." (defun byte-compile-save-excursion (form) (if (and (eq 'set-buffer (car-safe (car-safe (cdr form)))) (byte-compile-warning-enabled-p 'suspicious 'set-buffer)) - (byte-compile-warn + (byte-compile-warn-x + form "Use `with-current-buffer' rather than save-excursion+set-buffer")) (byte-compile-out 'byte-save-excursion 0) (byte-compile-body-do-effect (cdr form)) @@ -4873,8 +5032,10 @@ binding slots have been popped." (when (and (symbolp (nth 1 form)) (not (string-match "[-*/:$]" (symbol-name (nth 1 form)))) (byte-compile-warning-enabled-p 'lexical (nth 1 form))) - (byte-compile-warn "global/dynamic var `%s' lacks a prefix" - (nth 1 form))) + (byte-compile-warn-x + (nth 1 form) + "global/dynamic var `%s' lacks a prefix" + (nth 1 form))) (byte-compile-docstring-length-warn form) (let ((fun (nth 0 form)) (var (nth 1 form)) @@ -4884,7 +5045,8 @@ binding slots have been popped." (when (or (> (length form) 4) (and (eq fun 'defconst) (null (cddr form)))) (let ((ncall (length (cdr form)))) - (byte-compile-warn + (byte-compile-warn-x + fun "`%s' called with %d argument%s, but %s %s" fun ncall (if (= 1 ncall) "" "s") @@ -4894,8 +5056,10 @@ binding slots have been popped." (if (eq fun 'defconst) (push var byte-compile-const-variables)) (when (and string (not (stringp string))) - (byte-compile-warn "third arg to `%s %s' is not a string: %s" - fun var string)) + (byte-compile-warn-x + string + "third arg to `%s %s' is not a string: %s" + fun var string)) (byte-compile-form-do-effect (if (cddr form) ; `value' provided ;; Quote with `quote' to prevent byte-compiling the body, @@ -4915,7 +5079,8 @@ binding slots have been popped." (macroexp-const-p (nth 5 form)) (memq (eval (nth 5 form)) '(t macro)) ; macro-p (not (fboundp (eval (nth 1 form)))) - (byte-compile-warn + (byte-compile-warn-x + form "The compiler ignores `autoload' except at top level. You should probably put the autoload of the macro `%s' at top-level." (eval (nth 1 form)))) @@ -5004,7 +5169,8 @@ binding slots have been popped." (defun byte-compile-make-variable-buffer-local (form) (if (and (eq (car-safe (car-safe (cdr-safe form))) 'quote) (byte-compile-warning-enabled-p 'make-local)) - (byte-compile-warn + (byte-compile-warn-x + form "`make-variable-buffer-local' not called at toplevel")) (byte-compile-normal-call form)) (put 'make-variable-buffer-local @@ -5062,7 +5228,7 @@ binding slots have been popped." (when (or (vectorp key) (and (stringp key) (not (key-valid-p key)))) - (byte-compile-warn "Invalid `kbd' syntax: %S" key)))) + (byte-compile-warn-x form "Invalid `kbd' syntax: %S" key)))) form))) ;; Functions and the place(s) for the key definition(s). '((keymap-set 2) @@ -5088,23 +5254,23 @@ binding slots have been popped." (not (eq (car form) :menu))) (unless (memq (car form) '(:full :keymap :parent :suppress :name :prefix)) - (byte-compile-warn "Invalid keyword: %s" (car form))) + (byte-compile-warn-x (car form) "Invalid keyword: %s" (car form))) (push (pop form) result) (when (null form) - (byte-compile-warn "Uneven number of keywords in %S" form)) + (byte-compile-warn-x orig-form "Uneven number of keywords in %S" form)) (push (pop form) result)) ;; Bindings. (while form (let ((key (pop form))) (when (stringp key) (unless (key-valid-p key) - (byte-compile-warn "Invalid `kbd' syntax: %S" key))) + (byte-compile-warn-x form "Invalid `kbd' syntax: %S" key))) ;; No improvement. (push key result)) (when (null form) - (byte-compile-warn "Uneven number of key bindings in %S" form)) + (byte-compile-warn-x form "Uneven number of key bindings in %S" form)) (push (pop form) result)) - orig-form)) + (byte-compile-strip-symbol-positions orig-form))) (put 'define-keymap--define 'byte-hunk-handler #'byte-compile-define-keymap--define) @@ -5171,24 +5337,26 @@ OP and OPERAND are as passed to `byte-compile-out'." ;;; call tree stuff (defun byte-compile-annotate-call-tree (form) - (let (entry) + (let ((current-form (byte-compile-strip-symbol-positions + byte-compile-current-form)) + (bare-car-form (byte-compile-strip-symbol-positions (car form))) + entry) ;; annotate the current call - (if (setq entry (assq (car form) byte-compile-call-tree)) - (or (memq byte-compile-current-form (nth 1 entry)) ;callers + (if (setq entry (assq bare-car-form byte-compile-call-tree)) + (or (memq current-form (nth 1 entry)) ;callers (setcar (cdr entry) - (cons byte-compile-current-form (nth 1 entry)))) + (cons current-form (nth 1 entry)))) (setq byte-compile-call-tree - (cons (list (car form) (list byte-compile-current-form) nil) + (cons (list bare-car-form (list current-form) nil) byte-compile-call-tree))) ;; annotate the current function - (if (setq entry (assq byte-compile-current-form byte-compile-call-tree)) - (or (memq (car form) (nth 2 entry)) ;called + (if (setq entry (assq current-form byte-compile-call-tree)) + (or (memq bare-car-form (nth 2 entry)) ;called (setcar (cdr (cdr entry)) - (cons (car form) (nth 2 entry)))) + (cons bare-car-form (nth 2 entry)))) (setq byte-compile-call-tree - (cons (list byte-compile-current-form nil (list (car form))) - byte-compile-call-tree))) - )) + (cons (list current-form nil (list bare-car-form)) + byte-compile-call-tree))))) ;; Renamed from byte-compile-report-call-tree ;; to avoid interfering with completion of byte-compile-file. @@ -5213,14 +5381,15 @@ invoked interactively." (set-buffer "*Call-Tree*") (erase-buffer) (message "Generating call tree... (sorting on %s)" - byte-compile-call-tree-sort) + (remove-pos-from-symbol byte-compile-call-tree-sort)) (insert "Call tree for " (cond ((null byte-compile-current-file) (or filename "???")) ((stringp byte-compile-current-file) byte-compile-current-file) (t (buffer-name byte-compile-current-file))) " sorted on " - (prin1-to-string byte-compile-call-tree-sort) + (prin1-to-string (remove-pos-from-symbol + byte-compile-call-tree-sort)) ":\n\n") (if byte-compile-call-tree-sort (setq byte-compile-call-tree @@ -5240,7 +5409,8 @@ invoked interactively." ('name (lambda (x y) (string< (car x) (car y)))) (_ (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode" - byte-compile-call-tree-sort)))))) + (remove-pos-from-symbol + byte-compile-call-tree-sort))))))) (message "Generating call tree...") (let ((rest byte-compile-call-tree) (b (current-buffer)) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 03e109f250..9c9ebe15d5 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -353,7 +353,8 @@ places where they originally did not directly appear." (var (if (not (consp binder)) (prog1 binder (setq binder (list binder))) (when (cddr binder) - (byte-compile-warn + (byte-compile-warn-x + binder "Malformed `%S' binding: %S" letsym binder)) (setq value (cadr binder)) @@ -361,9 +362,9 @@ places where they originally did not directly appear." (cond ;; Ignore bindings without a valid name. ((not (symbolp var)) - (byte-compile-warn "attempt to let-bind nonvariable `%S'" var)) + (byte-compile-warn-x var "attempt to let-bind nonvariable `%S'" var)) ((or (booleanp var) (keywordp var)) - (byte-compile-warn "attempt to let-bind constant `%S'" var)) + (byte-compile-warn-x var "attempt to let-bind constant `%S'" var)) (t (let ((new-val (pcase (cconv--var-classification binder form) @@ -610,7 +611,8 @@ FORM is the parent form that binds this var." ;; FIXME: Convert this warning to use `macroexp--warn-wrap' ;; so as to give better position information. (when (byte-compile-warning-enabled-p 'not-unused var) - (byte-compile-warn "%s `%S' not left unused" varkind var))) + (byte-compile-warn-x + var "%s `%S' not left unused" varkind var))) ((and (let (or 'let* 'let) (car form)) `((,var) ;; (or `(,var nil) : Too many false positives: bug#47080 t nil ,_ ,_)) @@ -618,7 +620,7 @@ FORM is the parent form that binds this var." ;; so as to give better position information and obey ;; `byte-compile-warnings'. (unless (not (intern-soft var)) - (byte-compile-warn "Variable `%S' left uninitialized" var)))) + (byte-compile-warn-x var "Variable `%S' left uninitialized" var)))) (pcase vardata (`(,binder nil ,_ ,_ nil) (push (cons (cons binder form) :unused) cconv-var-classification)) @@ -647,7 +649,8 @@ FORM is the parent form that binds this var." (dolist (arg args) (cond ((byte-compile-not-lexical-var-p arg) - (byte-compile-warn + (byte-compile-warn-x + arg "Lexical argument shadows the dynamic variable %S" arg)) ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ... @@ -730,7 +733,8 @@ This function does not return anything but instead fills the (setq forms (cddr forms)))) (`((lambda . ,_) . ,_) ; First element is lambda expression. - (byte-compile-warn + (byte-compile-warn-x + (nth 1 (car form)) "Use of deprecated ((lambda %s ...) ...) form" (nth 1 (car form))) (dolist (exp `((function ,(car form)) . ,(cdr form))) (cconv-analyze-form exp env))) @@ -749,8 +753,8 @@ This function does not return anything but instead fills the (`(condition-case ,var ,protected-form . ,handlers) (cconv-analyze-form protected-form env) (when (and var (symbolp var) (byte-compile-not-lexical-var-p var)) - (byte-compile-warn - "Lexical variable shadows the dynamic variable %S" var)) + (byte-compile-warn-x + var "Lexical variable shadows the dynamic variable %S" var)) (let* ((varstruct (list var nil nil nil nil))) (if var (push varstruct env)) (dolist (handler handlers) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 9de47e4987..b94737e0fe 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -496,7 +496,8 @@ The set of acceptable TYPEs (also called \"specializers\") is defined cl--generic-edebug-make-name nil] lambda-doc ; documentation string def-body))) ; part to be debugged - (let ((qualifiers nil)) + (let ((qualifiers nil) + (org-name name)) (while (cl-generic--method-qualifier-p args) (push args qualifiers) (setq args (pop body))) @@ -511,6 +512,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (byte-compile-warning-enabled-p 'obsolete name)) (let* ((obsolete (get name 'byte-obsolete-info))) (macroexp-warn-and-return + ;; org-name (macroexp--obsolete-warning name obsolete "generic function") nil))) ;; You could argue that `defmethod' modifies rather than defines the diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 1852471bcb..dbe0eb1b0e 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -53,6 +53,36 @@ `(prog1 (car (cdr ,place)) (setq ,place (cdr (cdr ,place))))) +(defun cl-macs--strip-s-p-1 (arg) + "Strip all positions from symbols with position in ARG, destructively modifying ARG +Return the modified ARG." + (cond + ((symbolp arg) + (bare-symbol arg)) + ((consp arg) + (let ((a arg)) + (while (consp (cdr a)) + (setcar a (cl-macs--strip-s-p-1 (car a))) + (setq a (cdr a))) + (setcar a (cl-macs--strip-s-p-1 (car a))) + ;; (if (cdr a) + (unless (bare-symbol-p (cdr a)) ; includes (unpositioned) nil. + (setcdr a (cl-macs--strip-s-p-1 (cdr a))))) + arg) + ((vectorp arg) + (let ((i 0) + (len (length arg))) + (while (< i len) + (aset arg i (cl-macs--strip-s-p-1 (aref arg i))) + (setq i (1+ i)))) + arg) + (t arg))) + +(defun cl-macs--strip-symbol-positions (arg) + "Strip all positions from symbols (recursively) in ARG. Don't modify ARG." + (let ((arg1 (copy-tree arg t))) + (cl-macs--strip-s-p-1 arg1))) + (defvar cl--optimize-safety) (defvar cl--optimize-speed) @@ -2417,10 +2447,12 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). (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) + (let ((rev-malformed-bindings (nreverse malformed-bindings))) + (macroexp-warn-and-return + ;; rev-malformed-bindings + (format-message "Malformed `cl-symbol-macrolet' binding(s): %S" + rev-malformed-bindings) + expansion)) expansion))) (unless advised (advice-remove 'macroexpand #'cl--sm-macroexpand))))) @@ -3104,6 +3136,7 @@ To see the documentation for a defined struct type, use (when (cl-oddp (length desc)) (push (macroexp-warn-and-return + ;; (car (last desc)) (format "Missing value for option `%S' of slot `%s' in struct %s!" (car (last desc)) slot name) 'nil) @@ -3113,6 +3146,7 @@ To see the documentation for a defined struct type, use (let ((kw (car defaults))) (push (macroexp-warn-and-return + ;; kw (format " I'll take `%s' to be an option rather than a default value." kw) 'nil) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 7c5babcf54..4e9357c2ad 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -744,6 +744,7 @@ Argument FN is the function calling this verifier." ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-slot-names)))) (macroexp-warn-and-return + ;; name (format-message "Unknown slot `%S'" name) exp nil 'compile-only)) (_ exp)))) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 3fbfe011e2..76f7b661a6 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -292,6 +292,7 @@ This method is obsolete." (if (not (stringp (car slots))) whole (macroexp-warn-and-return + ;; (car slots) (format "Obsolete name arg %S to constructor %S" (car slots) (car whole)) ;; Keep the name arg, for backward compatibility, diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index ebcc63cc2a..ed33524f2d 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -581,7 +581,9 @@ This is like the `&' operator of the C language. Note: this only works reliably with lexical binding mode, except for very simple PLACEs such as (symbol-function \\='foo) which will also work in dynamic binding mode." - (let ((code + (let ((org-place place) ; It's too difficult to determine by inspection whether + ; the functions modify place. + (code (gv-letplace (getter setter) place `(cons (lambda () ,getter) (lambda (gv--val) ,(funcall setter 'gv--val)))))) @@ -593,6 +595,7 @@ binding mode." (eq (car-safe code) 'cons)) code (macroexp-warn-and-return + ;; org-place "Use of gv-ref probably requires lexical-binding" code)))) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 1e4fdd126c..6d114a8a54 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -138,14 +138,15 @@ Other uses risk returning non-nil value that point to the wrong file." (defun macroexp--warn-wrap (msg form category) (let ((when-compiled (lambda () (when (byte-compile-warning-enabled-p category) - (byte-compile-warn "%s" msg))))) + (byte-compile-warn-x form "%s" msg))))) `(progn (macroexp--funcall-if-compiled ',when-compiled) ,form))) (define-obsolete-function-alias 'macroexp--warn-and-return #'macroexp-warn-and-return "28.1") -(defun macroexp-warn-and-return (msg form &optional category compile-only) +(defun macroexp-warn-and-return (;; _arg + msg form &optional category compile-only) "Return code equivalent to FORM labeled with warning MSG. CATEGORY is the category of the warning, like the categories that can appear in `byte-compile-warnings'. @@ -216,6 +217,7 @@ is executed without being compiled first." (let* ((fun (car form)) (obsolete (get fun 'byte-obsolete-info))) (macroexp-warn-and-return + ;; fun (macroexp--obsolete-warning fun obsolete (if (symbolp (symbol-function fun)) @@ -330,6 +332,7 @@ Assumes the caller has bound `macroexpand-all-environment'." (if (null body) (macroexp-unprogn (macroexp-warn-and-return + ;; fun (format "Empty %s body" fun) nil nil 'compile-only)) (macroexp--all-forms body)) @@ -367,6 +370,7 @@ Assumes the caller has bound `macroexpand-all-environment'." (eq 'lambda (car-safe (cadr arg)))) (setcar (nthcdr funarg form) (macroexp-warn-and-return + ;; (nth 1 f) (format "%S quoted with ' rather than with #'" (let ((f (cadr arg))) (if (symbolp f) f `(lambda ,(nth 1 f) ...)))) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index a3498d2da8..430ae97078 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -940,6 +940,7 @@ Otherwise, it defers to REST which is a list of branches of the form (let ((code (pcase--u1 matches code vars rest))) (if (eq upat '_) code (macroexp-warn-and-return + ;; upat "Pattern t is deprecated. Use `_' instead" code)))) ((eq upat 'pcase--dontcare) :pcase--dontcare) diff --git a/src/.gdbinit b/src/.gdbinit index f74e295f7e..9f2a86b779 100644 --- a/src/.gdbinit +++ b/src/.gdbinit @@ -746,6 +746,15 @@ Print $ as a overlay pointer. This command assumes that $ is an Emacs Lisp overlay value. end +define xsymwithpos + xgetptr $ + print (struct Lisp_Symbol_With_Pos *) $ptr +end +document xsymwithpos +Print $ as a symbol with position. +This command assumes that $ is an Emacs Lisp symbol with position value. +end + define xsymbol set $sym = $ xgetsym $sym @@ -1011,6 +1020,9 @@ define xpr if $vec == PVEC_OVERLAY xoverlay end + if $vec == PVEC_SYMBOL_WITH_POS + xsymwithpos + end if $vec == PVEC_PROCESS xprocess end diff --git a/src/alloc.c b/src/alloc.c index f8908c91db..0d69f23048 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -591,7 +591,7 @@ pointer_align (void *ptr, int alignment) static ATTRIBUTE_NO_SANITIZE_UNDEFINED void * XPNTR (Lisp_Object a) { - return (SYMBOLP (a) + return (BARE_SYMBOL_P (a) ? (char *) lispsym + (XLI (a) - LISP_WORD_TAG (Lisp_Symbol)) : (char *) XLP (a) - (XLI (a) & ~VALMASK)); } @@ -3598,13 +3598,13 @@ static struct Lisp_Symbol *symbol_free_list; static void set_symbol_name (Lisp_Object sym, Lisp_Object name) { - XSYMBOL (sym)->u.s.name = name; + XBARE_SYMBOL (sym)->u.s.name = name; } void init_symbol (Lisp_Object val, Lisp_Object name) { - struct Lisp_Symbol *p = XSYMBOL (val); + struct Lisp_Symbol *p = XBARE_SYMBOL (val); set_symbol_name (val, name); set_symbol_plist (val, Qnil); p->u.s.redirect = SYMBOL_PLAINVAL; @@ -3667,6 +3667,21 @@ make_misc_ptr (void *a) return make_lisp_ptr (p, Lisp_Vectorlike); } +/* Return a new symbol with position with the specified SYMBOL and POSITION. */ +Lisp_Object +build_symbol_with_pos (Lisp_Object symbol, Lisp_Object position) +{ + Lisp_Object val; + struct Lisp_Symbol_With_Pos *p + = (struct Lisp_Symbol_With_Pos *) allocate_vector (2); + XSETVECTOR (val, p); + XSETPVECTYPESIZE (XVECTOR (val), PVEC_SYMBOL_WITH_POS, 2, 0); + p->sym = symbol; + p->pos = position; + + return val; +} + /* Return a new overlay with specified START, END and PLIST. */ Lisp_Object @@ -5210,7 +5225,7 @@ valid_lisp_object_p (Lisp_Object obj) if (PURE_P (p)) return 1; - if (SYMBOLP (obj) && c_symbol_p (p)) + if (BARE_SYMBOL_P (obj) && c_symbol_p (p)) return ((char *) p - (char *) lispsym) % sizeof lispsym[0] == 0; if (p == &buffer_defaults || p == &buffer_local_symbols) @@ -5638,12 +5653,12 @@ purecopy (Lisp_Object obj) vec->contents[i] = purecopy (vec->contents[i]); XSETVECTOR (obj, vec); } - else if (SYMBOLP (obj)) + else if (BARE_SYMBOL_P (obj)) { - if (!XSYMBOL (obj)->u.s.pinned && !c_symbol_p (XSYMBOL (obj))) + if (!XBARE_SYMBOL (obj)->u.s.pinned && !c_symbol_p (XBARE_SYMBOL (obj))) { /* We can't purify them, but they appear in many pure objects. Mark them as `pinned' so we know to mark them at every GC cycle. */ - XSYMBOL (obj)->u.s.pinned = true; + XBARE_SYMBOL (obj)->u.s.pinned = true; symbol_block_pinned = symbol_block; } /* Don't hash-cons it. */ @@ -6268,7 +6283,10 @@ For further details, see Info node `(elisp)Garbage Collection'. */) if (garbage_collection_inhibited) return Qnil; + ptrdiff_t count = SPECPDL_INDEX (); + specbind (Qsymbols_with_pos_enabled, Qnil); garbage_collect (); + unbind_to (count, Qnil); struct gcstat gcst = gcstat; Lisp_Object total[] = { @@ -6407,7 +6425,7 @@ mark_char_table (struct Lisp_Vector *ptr, enum pvec_type pvectype) Lisp_Object val = ptr->contents[i]; if (FIXNUMP (val) || - (SYMBOLP (val) && symbol_marked_p (XSYMBOL (val)))) + (BARE_SYMBOL_P (val) && symbol_marked_p (XBARE_SYMBOL (val)))) continue; if (SUB_CHAR_TABLE_P (val)) { @@ -6809,7 +6827,7 @@ mark_object (Lisp_Object arg) case Lisp_Symbol: { - struct Lisp_Symbol *ptr = XSYMBOL (obj); + struct Lisp_Symbol *ptr = XBARE_SYMBOL (obj); nextsym: if (symbol_marked_p (ptr)) break; @@ -6930,7 +6948,7 @@ survives_gc_p (Lisp_Object obj) break; case Lisp_Symbol: - survives_p = symbol_marked_p (XSYMBOL (obj)); + survives_p = symbol_marked_p (XBARE_SYMBOL (obj)); break; case Lisp_String: @@ -7347,7 +7365,7 @@ arenas. */) static bool symbol_uses_obj (Lisp_Object symbol, Lisp_Object obj) { - struct Lisp_Symbol *sym = XSYMBOL (symbol); + struct Lisp_Symbol *sym = XBARE_SYMBOL (symbol); Lisp_Object val = find_symbol_value (symbol); return (EQ (val, obj) || EQ (sym->u.s.function, obj) diff --git a/src/data.c b/src/data.c index 0d3376f090..b3b157a7f3 100644 --- a/src/data.c +++ b/src/data.c @@ -216,6 +216,7 @@ for example, (type-of 1) returns `integer'. */) case PVEC_NORMAL_VECTOR: return Qvector; case PVEC_BIGNUM: return Qinteger; case PVEC_MARKER: return Qmarker; + case PVEC_SYMBOL_WITH_POS: return Qsymbol_with_pos; case PVEC_OVERLAY: return Qoverlay; case PVEC_FINALIZER: return Qfinalizer; case PVEC_USER_PTR: return Quser_ptr; @@ -316,6 +317,26 @@ DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0, return Qt; } +DEFUN ("bare-symbol-p", Fbare_symbol_p, Sbare_symbol_p, 1, 1, 0, + doc: /* Return t if OBJECT is a symbol, but not a symbol together with position. */ + attributes: const) + (Lisp_Object object) +{ + if (BARE_SYMBOL_P (object)) + return Qt; + return Qnil; +} + +DEFUN ("symbol-with-pos-p", Fsymbol_with_pos_p, Ssymbol_with_pos_p, 1, 1, 0, + doc: /* Return t if OBJECT is a symbol together with position. */ + attributes: const) + (Lisp_Object object) +{ + if (SYMBOL_WITH_POS_P (object)) + return Qt; + return Qnil; +} + DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0, doc: /* Return t if OBJECT is a symbol. */ attributes: const) @@ -753,6 +774,51 @@ DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0, return name; } +DEFUN ("bare-symbol", Fbare_symbol, Sbare_symbol, 1, 1, 0, + doc: /* Extract, if need be, the bare symbol from SYM, a symbol. */) + (register Lisp_Object sym) +{ + if (BARE_SYMBOL_P (sym)) + return sym; + /* Type checking is done in the following macro. */ + return SYMBOL_WITH_POS_SYM (sym); +} + +DEFUN ("symbol-with-pos-pos", Fsymbol_with_pos_pos, Ssymbol_with_pos_pos, 1, 1, 0, + doc: /* Extract the position from a symbol with position. */) + (register Lisp_Object ls) +{ + /* Type checking is done in the following macro. */ + return SYMBOL_WITH_POS_POS (ls); +} + +DEFUN ("position-symbol", Fposition_symbol, Sposition_symbol, 2, 2, 0, + doc: /* Create a new symbol with position. +SYM is a symbol, with or without position, the symbol to position. +POS, the position, is either a fixnum or a symbol with position from which +the position will be taken. */) + (register Lisp_Object sym, register Lisp_Object pos) +{ + Lisp_Object bare; + Lisp_Object position; + + if (BARE_SYMBOL_P (sym)) + bare = sym; + else if (SYMBOL_WITH_POS_P (sym)) + bare = XSYMBOL_WITH_POS (sym)->sym; + else + wrong_type_argument (Qsymbolp, sym); + + if (FIXNUMP (pos)) + position = pos; + else if (SYMBOL_WITH_POS_P (pos)) + position = XSYMBOL_WITH_POS (pos)->pos; + else + wrong_type_argument (Qfixnum_or_symbol_with_pos_p, pos); + + return build_symbol_with_pos (bare, position); +} + DEFUN ("fset", Ffset, Sfset, 2, 2, 0, doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */) (register Lisp_Object symbol, Lisp_Object definition) @@ -3929,6 +3995,8 @@ syms_of_data (void) DEFSYM (Qlistp, "listp"); DEFSYM (Qconsp, "consp"); + DEFSYM (Qbare_symbol_p, "bare-symbol-p"); + DEFSYM (Qsymbol_with_pos_p, "symbol-with-pos-p"); DEFSYM (Qsymbolp, "symbolp"); DEFSYM (Qfixnump, "fixnump"); DEFSYM (Qintegerp, "integerp"); @@ -3954,6 +4022,7 @@ syms_of_data (void) DEFSYM (Qchar_table_p, "char-table-p"); DEFSYM (Qvector_or_char_table_p, "vector-or-char-table-p"); + DEFSYM (Qfixnum_or_symbol_with_pos_p, "fixnum-or-symbol-with-pos-p"); DEFSYM (Qsubrp, "subrp"); DEFSYM (Qunevalled, "unevalled"); @@ -4038,6 +4107,7 @@ syms_of_data (void) DEFSYM (Qstring, "string"); DEFSYM (Qcons, "cons"); DEFSYM (Qmarker, "marker"); + DEFSYM (Qsymbol_with_pos, "symbol-with-pos"); DEFSYM (Qoverlay, "overlay"); DEFSYM (Qfinalizer, "finalizer"); DEFSYM (Qmodule_function, "module-function"); @@ -4089,6 +4159,8 @@ syms_of_data (void) defsubr (&Snumber_or_marker_p); defsubr (&Sfloatp); defsubr (&Snatnump); + defsubr (&Sbare_symbol_p); + defsubr (&Ssymbol_with_pos_p); defsubr (&Ssymbolp); defsubr (&Skeywordp); defsubr (&Sstringp); @@ -4119,6 +4191,9 @@ syms_of_data (void) defsubr (&Sindirect_function); defsubr (&Ssymbol_plist); defsubr (&Ssymbol_name); + defsubr (&Sbare_symbol); + defsubr (&Ssymbol_with_pos_pos); + defsubr (&Sposition_symbol); defsubr (&Smakunbound); defsubr (&Sfmakunbound); defsubr (&Sboundp); @@ -4201,6 +4276,12 @@ This variable cannot be set; trying to do so will signal an error. */); Vmost_negative_fixnum = make_fixnum (MOST_NEGATIVE_FIXNUM); make_symbol_constant (intern_c_string ("most-negative-fixnum")); + DEFSYM (Qsymbols_with_pos_enabled, "symbols-with-pos-enabled"); + DEFVAR_BOOL ("symbols-with-pos-enabled", symbols_with_pos_enabled, + doc: /* Non-nil when "symbols with position" can be used as symbols. +Bind this to non-nil in applications such as the byte compiler. */); + symbols_with_pos_enabled = false; + DEFSYM (Qwatchers, "watchers"); DEFSYM (Qmakunbound, "makunbound"); DEFSYM (Qunlet, "unlet"); diff --git a/src/fns.c b/src/fns.c index 76c76c92ba..43df40aa9e 100644 --- a/src/fns.c +++ b/src/fns.c @@ -2569,6 +2569,13 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, } } + /* A symbol with position compares the contained symbol, and is + `equal' to the corresponding ordinary symbol. */ + if (SYMBOL_WITH_POS_P (o1)) + o1 = SYMBOL_WITH_POS_SYM (o1); + if (SYMBOL_WITH_POS_P (o2)) + o2 = SYMBOL_WITH_POS_SYM (o2); + if (EQ (o1, o2)) return true; if (XTYPE (o1) != XTYPE (o2)) @@ -4479,7 +4486,10 @@ hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object *hash) { ptrdiff_t start_of_bucket, i; - Lisp_Object hash_code = h->test.hashfn (key, h); + Lisp_Object hash_code; + if (SYMBOL_WITH_POS_P (key)) + key = SYMBOL_WITH_POS_SYM (key); + hash_code = h->test.hashfn (key, h); if (hash) *hash = hash_code; diff --git a/src/keyboard.c b/src/keyboard.c index c98175aea0..050537b95c 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -688,6 +688,8 @@ recursive_edit_1 (void) { specbind (Qstandard_output, Qt); specbind (Qstandard_input, Qt); + specbind (Qsymbols_with_pos_enabled, Qnil); + specbind (Qprint_symbols_bare, Qnil); } #ifdef HAVE_WINDOW_SYSTEM diff --git a/src/lisp.h b/src/lisp.h index 19caba4001..08013e94d1 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -364,18 +364,38 @@ typedef EMACS_INT Lisp_Word; # endif #endif +#define lisp_h_PSEUDOVECTORP(a,code) \ + (lisp_h_VECTORLIKEP((a)) && \ + ((XUNTAG ((a), Lisp_Vectorlike, union vectorlike_header)->size \ + & (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK)) \ + == (PSEUDOVECTOR_FLAG | ((code) << PSEUDOVECTOR_AREA_BITS)))) + #define lisp_h_CHECK_FIXNUM(x) CHECK_TYPE (FIXNUMP (x), Qfixnump, x) #define lisp_h_CHECK_SYMBOL(x) CHECK_TYPE (SYMBOLP (x), Qsymbolp, x) #define lisp_h_CHECK_TYPE(ok, predicate, x) \ ((ok) ? (void) 0 : wrong_type_argument (predicate, x)) #define lisp_h_CONSP(x) TAGGEDP (x, Lisp_Cons) -#define lisp_h_EQ(x, y) (XLI (x) == XLI (y)) +#define lisp_h_BASE_EQ(x, y) (XLI (x) == XLI (y)) +/* #define lisp_h_EQ(x, y) (XLI (x) == XLI (y)) */ + +#define lisp_h_EQ(x, y) ((XLI ((x)) == XLI ((y))) \ + || (symbols_with_pos_enabled \ + && (SYMBOL_WITH_POS_P ((x)) \ + ? BARE_SYMBOL_P ((y)) \ + ? (XSYMBOL_WITH_POS((x)))->sym == (y) \ + : SYMBOL_WITH_POS_P((y)) \ + && ((XSYMBOL_WITH_POS((x)))->sym \ + == (XSYMBOL_WITH_POS((y)))->sym) \ + : (SYMBOL_WITH_POS_P ((y)) \ + && BARE_SYMBOL_P ((x)) \ + && ((x) == ((XSYMBOL_WITH_POS ((y)))->sym)))))) + #define lisp_h_FIXNUMP(x) \ (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) \ - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) \ & ((1 << INTTYPEBITS) - 1))) #define lisp_h_FLOATP(x) TAGGEDP (x, Lisp_Float) -#define lisp_h_NILP(x) EQ (x, Qnil) +#define lisp_h_NILP(x) /* x == Qnil */ /* ((XLI (x) == XLI (Qnil))) */ /* EQ (x, Qnil) */ BASE_EQ (x, Qnil) #define lisp_h_SET_SYMBOL_VAL(sym, v) \ (eassert ((sym)->u.s.redirect == SYMBOL_PLAINVAL), \ (sym)->u.s.val.value = (v)) @@ -384,7 +404,10 @@ typedef EMACS_INT Lisp_Word; #define lisp_h_SYMBOL_TRAPPED_WRITE_P(sym) (XSYMBOL (sym)->u.s.trapped_write) #define lisp_h_SYMBOL_VAL(sym) \ (eassert ((sym)->u.s.redirect == SYMBOL_PLAINVAL), (sym)->u.s.val.value) -#define lisp_h_SYMBOLP(x) TAGGEDP (x, Lisp_Symbol) +#define lisp_h_SYMBOL_WITH_POS_P(x) PSEUDOVECTORP ((x), PVEC_SYMBOL_WITH_POS) +#define lisp_h_BARE_SYMBOL_P(x) TAGGEDP ((x), Lisp_Symbol) +#define lisp_h_SYMBOLP(x) ((BARE_SYMBOL_P ((x)) || \ + (symbols_with_pos_enabled && (SYMBOL_WITH_POS_P ((x)))))) #define lisp_h_TAGGEDP(a, tag) \ (! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \ - (unsigned) (tag)) \ @@ -429,11 +452,12 @@ typedef EMACS_INT Lisp_Word; # define XLI(o) lisp_h_XLI (o) # define XIL(i) lisp_h_XIL (i) # define XLP(o) lisp_h_XLP (o) +# define BARE_SYMBOL_P(x) lisp_h_BARE_SYMBOL_P (x) # define CHECK_FIXNUM(x) lisp_h_CHECK_FIXNUM (x) # define CHECK_SYMBOL(x) lisp_h_CHECK_SYMBOL (x) # define CHECK_TYPE(ok, predicate, x) lisp_h_CHECK_TYPE (ok, predicate, x) # define CONSP(x) lisp_h_CONSP (x) -# define EQ(x, y) lisp_h_EQ (x, y) +# define BASE_EQ(x, y) lisp_h_BASE_EQ (x, y) # define FLOATP(x) lisp_h_FLOATP (x) # define FIXNUMP(x) lisp_h_FIXNUMP (x) # define NILP(x) lisp_h_NILP (x) @@ -441,7 +465,7 @@ typedef EMACS_INT Lisp_Word; # define SYMBOL_CONSTANT_P(sym) lisp_h_SYMBOL_CONSTANT_P (sym) # define SYMBOL_TRAPPED_WRITE_P(sym) lisp_h_SYMBOL_TRAPPED_WRITE_P (sym) # define SYMBOL_VAL(sym) lisp_h_SYMBOL_VAL (sym) -# define SYMBOLP(x) lisp_h_SYMBOLP (x) +/* # define SYMBOLP(x) lisp_h_SYMBOLP (x) */ /* X is accessed more than once. */ # define TAGGEDP(a, tag) lisp_h_TAGGEDP (a, tag) # define VECTORLIKEP(x) lisp_h_VECTORLIKEP (x) # define XCAR(c) lisp_h_XCAR (c) @@ -600,6 +624,7 @@ extern Lisp_Object char_table_ref (Lisp_Object, int) ATTRIBUTE_PURE; extern void char_table_set (Lisp_Object, int, Lisp_Object); /* Defined in data.c. */ +extern bool symbols_with_pos_enabled; extern AVOID args_out_of_range_3 (Lisp_Object, Lisp_Object, Lisp_Object); extern AVOID wrong_type_argument (Lisp_Object, Lisp_Object); extern Lisp_Object default_value (Lisp_Object symbol); @@ -984,57 +1009,12 @@ union vectorlike_header ptrdiff_t size; }; -INLINE bool -(SYMBOLP) (Lisp_Object x) -{ - return lisp_h_SYMBOLP (x); -} - -INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED -XSYMBOL (Lisp_Object a) -{ - eassert (SYMBOLP (a)); - intptr_t i = (intptr_t) XUNTAG (a, Lisp_Symbol, struct Lisp_Symbol); - void *p = (char *) lispsym + i; - return p; -} - -INLINE Lisp_Object -make_lisp_symbol (struct Lisp_Symbol *sym) -{ - /* GCC 7 x86-64 generates faster code if lispsym is - cast to char * rather than to intptr_t. */ - char *symoffset = (char *) ((char *) sym - (char *) lispsym); - Lisp_Object a = TAG_PTR (Lisp_Symbol, symoffset); - eassert (XSYMBOL (a) == sym); - return a; -} - -INLINE Lisp_Object -builtin_lisp_symbol (int index) -{ - return make_lisp_symbol (&lispsym[index]); -} - -INLINE bool -c_symbol_p (struct Lisp_Symbol *sym) +struct Lisp_Symbol_With_Pos { - char *bp = (char *) lispsym; - char *sp = (char *) sym; - if (PTRDIFF_MAX < INTPTR_MAX) - return bp <= sp && sp < bp + sizeof lispsym; - else - { - ptrdiff_t offset = sp - bp; - return 0 <= offset && offset < sizeof lispsym; - } -} - -INLINE void -(CHECK_SYMBOL) (Lisp_Object x) -{ - lisp_h_CHECK_SYMBOL (x); -} + union vectorlike_header header; + Lisp_Object sym; /* A symbol */ + Lisp_Object pos; /* A fixnum */ +} GCALIGNED_STRUCT; /* In the size word of a vector, this bit means the vector has been marked. */ @@ -1059,6 +1039,7 @@ enum pvec_type PVEC_MARKER, PVEC_OVERLAY, PVEC_FINALIZER, + PVEC_SYMBOL_WITH_POS, PVEC_MISC_PTR, PVEC_USER_PTR, PVEC_PROCESS, @@ -1117,6 +1098,92 @@ enum More_Lisp_Bits values. They are macros for use in #if and static initializers. */ #define MOST_POSITIVE_FIXNUM (EMACS_INT_MAX >> INTTYPEBITS) #define MOST_NEGATIVE_FIXNUM (-1 - MOST_POSITIVE_FIXNUM) + +INLINE bool +PSEUDOVECTORP (Lisp_Object a, int code) +{ + return lisp_h_PSEUDOVECTORP (a, code); +} + +INLINE bool +(BARE_SYMBOL_P) (Lisp_Object x) +{ + return lisp_h_BARE_SYMBOL_P (x); +} + +INLINE bool +(SYMBOL_WITH_POS_P) (Lisp_Object x) +{ + return lisp_h_SYMBOL_WITH_POS_P (x); +} + +INLINE bool +(SYMBOLP) (Lisp_Object x) +{ + return lisp_h_SYMBOLP (x); +} + +INLINE struct Lisp_Symbol_With_Pos * +XSYMBOL_WITH_POS (Lisp_Object a) +{ + eassert (SYMBOL_WITH_POS_P (a)); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Symbol_With_Pos); +} + +INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED +(XBARE_SYMBOL) (Lisp_Object a) +{ + eassert (BARE_SYMBOL_P (a)); + intptr_t i = (intptr_t) XUNTAG (a, Lisp_Symbol, struct Lisp_Symbol); + void *p = (char *) lispsym + i; + return p; +} + +INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED +(XSYMBOL) (Lisp_Object a) +{ + eassert (SYMBOLP ((a))); + if (!symbols_with_pos_enabled || BARE_SYMBOL_P (a)) + return XBARE_SYMBOL (a); + return XBARE_SYMBOL (XSYMBOL_WITH_POS (a)->sym); +} + +INLINE Lisp_Object +make_lisp_symbol (struct Lisp_Symbol *sym) +{ + /* GCC 7 x86-64 generates faster code if lispsym is + cast to char * rather than to intptr_t. */ + char *symoffset = (char *) ((char *) sym - (char *) lispsym); + Lisp_Object a = TAG_PTR (Lisp_Symbol, symoffset); + eassert (XSYMBOL (a) == sym); + return a; +} + +INLINE Lisp_Object +builtin_lisp_symbol (int index) +{ + return make_lisp_symbol (&lispsym[index]); +} + +INLINE bool +c_symbol_p (struct Lisp_Symbol *sym) +{ + char *bp = (char *) lispsym; + char *sp = (char *) sym; + if (PTRDIFF_MAX < INTPTR_MAX) + return bp <= sp && sp < bp + sizeof lispsym; + else + { + ptrdiff_t offset = sp - bp; + return 0 <= offset && offset < sizeof lispsym; + } +} + +INLINE void +(CHECK_SYMBOL) (Lisp_Object x) +{ + lisp_h_CHECK_SYMBOL (x); +} /* True if the possibly-unsigned integer I doesn't fit in a fixnum. */ @@ -1248,7 +1315,14 @@ make_fixed_natnum (EMACS_INT n) } /* Return true if X and Y are the same object. */ +INLINE bool +(BASE_EQ) (Lisp_Object x, Lisp_Object y) +{ + return lisp_h_BASE_EQ (x, y); +} +/* Return true if X and Y are the same object, reckoning a symbol with + position as being the same as the bare symbol. */ INLINE bool (EQ) (Lisp_Object x, Lisp_Object y) { @@ -1714,21 +1788,6 @@ PSEUDOVECTOR_TYPEP (const union vectorlike_header *a, enum pvec_type code) == (PSEUDOVECTOR_FLAG | (code << PSEUDOVECTOR_AREA_BITS))); } -/* True if A is a pseudovector whose code is CODE. */ -INLINE bool -PSEUDOVECTORP (Lisp_Object a, int code) -{ - if (! VECTORLIKEP (a)) - return false; - else - { - /* Converting to union vectorlike_header * avoids aliasing issues. */ - return PSEUDOVECTOR_TYPEP (XUNTAG (a, Lisp_Vectorlike, - union vectorlike_header), - code); - } -} - /* A boolvector is a kind of vectorlike, with contents like a string. */ struct Lisp_Bool_Vector @@ -2627,6 +2686,22 @@ XOVERLAY (Lisp_Object a) return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Overlay); } +INLINE Lisp_Object +SYMBOL_WITH_POS_SYM (Lisp_Object a) +{ + if (!SYMBOL_WITH_POS_P (a)) + wrong_type_argument (Qsymbol_with_pos_p, a); + return XSYMBOL_WITH_POS (a)->sym; +} + +INLINE Lisp_Object +SYMBOL_WITH_POS_POS (Lisp_Object a) +{ + if (!SYMBOL_WITH_POS_P (a)) + wrong_type_argument (Qsymbol_with_pos_p, a); + return XSYMBOL_WITH_POS (a)->pos; +} + INLINE bool USER_PTRP (Lisp_Object x) { @@ -4030,6 +4105,7 @@ extern bool gc_in_progress; extern Lisp_Object make_float (double); extern void display_malloc_warning (void); extern ptrdiff_t inhibit_garbage_collection (void); +extern Lisp_Object build_symbol_with_pos (Lisp_Object, Lisp_Object); extern Lisp_Object build_overlay (Lisp_Object, Lisp_Object, Lisp_Object); extern void free_cons (struct Lisp_Cons *); extern void init_alloc_once (void); diff --git a/src/lread.c b/src/lread.c index 2e63ec4891..7775911c1d 100644 --- a/src/lread.c +++ b/src/lread.c @@ -647,12 +647,12 @@ struct subst }; static Lisp_Object read_internal_start (Lisp_Object, Lisp_Object, - Lisp_Object); -static Lisp_Object read0 (Lisp_Object); -static Lisp_Object read1 (Lisp_Object, int *, bool); + Lisp_Object, bool); +static Lisp_Object read0 (Lisp_Object, bool); +static Lisp_Object read1 (Lisp_Object, int *, bool, bool); -static Lisp_Object read_list (bool, Lisp_Object); -static Lisp_Object read_vector (Lisp_Object, bool); +static Lisp_Object read_list (bool, Lisp_Object, bool); +static Lisp_Object read_vector (Lisp_Object, bool, bool); static Lisp_Object substitute_object_recurse (struct subst *, Lisp_Object); static void substitute_in_interval (INTERVAL, void *); @@ -2280,7 +2280,7 @@ readevalloop (Lisp_Object readcharfun, Qnil, false); if (!NILP (Vpurify_flag) && c == '(') { - val = read_list (0, readcharfun); + val = read_list (0, readcharfun, false); } else { @@ -2302,7 +2302,7 @@ readevalloop (Lisp_Object readcharfun, else if (! NILP (Vload_read_function)) val = call1 (Vload_read_function, readcharfun); else - val = read_internal_start (readcharfun, Qnil, Qnil); + val = read_internal_start (readcharfun, Qnil, Qnil, false); } /* Empty hashes can be reused; otherwise, reset on next call. */ if (HASH_TABLE_P (read_objects_map) @@ -2460,7 +2460,35 @@ STREAM or the value of `standard-input' may be: return call1 (intern ("read-minibuffer"), build_string ("Lisp expression: ")); - return read_internal_start (stream, Qnil, Qnil); + return read_internal_start (stream, Qnil, Qnil, false); +} + +DEFUN ("read-positioning-symbols", Fread_positioning_symbols, + Sread_positioning_symbols, 0, 1, 0, + doc: /* Read one Lisp expression as text from STREAM, return as Lisp object. +Convert each occurrence of a symbol into a "symbol with pos" object. + +If STREAM is nil, use the value of `standard-input' (which see). +STREAM or the value of `standard-input' may be: + a buffer (read from point and advance it) + a marker (read from where it points and advance it) + a function (call it with no arguments for each character, + call it with a char as argument to push a char back) + a string (takes text from string, starting at the beginning) + t (read text line using minibuffer and use it, or read from + standard input in batch mode). */) + (Lisp_Object stream) +{ + if (NILP (stream)) + stream = Vstandard_input; + if (EQ (stream, Qt)) + stream = Qread_char; + if (EQ (stream, Qread_char)) + /* FIXME: ?! When is this used !? */ + return call1 (intern ("read-minibuffer"), + build_string ("Lisp expression: ")); + + return read_internal_start (stream, Qnil, Qnil, true); } DEFUN ("read-from-string", Fread_from_string, Sread_from_string, 1, 3, 0, @@ -2476,14 +2504,17 @@ the end of STRING. */) Lisp_Object ret; CHECK_STRING (string); /* `read_internal_start' sets `read_from_string_index'. */ - ret = read_internal_start (string, start, end); + ret = read_internal_start (string, start, end, false); return Fcons (ret, make_fixnum (read_from_string_index)); } /* Function to set up the global context we need in toplevel read - calls. START and END only used when STREAM is a string. */ + calls. START and END only used when STREAM is a string. + LOCATE_SYMS true means read symbol occurrences as symbols with + position. */ static Lisp_Object -read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end) +read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end, + bool locate_syms) { Lisp_Object retval; @@ -2523,7 +2554,7 @@ read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end) read_from_string_limit = endval; } - retval = read0 (stream); + retval = read0 (stream, locate_syms); if (EQ (Vread_with_symbol_positions, Qt) || EQ (Vread_with_symbol_positions, stream)) Vread_symbol_positions_list = Fnreverse (Vread_symbol_positions_list); @@ -2542,12 +2573,12 @@ read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end) are not allowed. */ static Lisp_Object -read0 (Lisp_Object readcharfun) +read0 (Lisp_Object readcharfun, bool locate_syms) { register Lisp_Object val; int c; - val = read1 (readcharfun, &c, 0); + val = read1 (readcharfun, &c, 0, locate_syms); if (!c) return val; @@ -2971,10 +3002,12 @@ read_integer (Lisp_Object readcharfun, int radix, in *PCH and the return value is not interesting. Else, we store zero in *PCH and we read and return one lisp object. - FIRST_IN_LIST is true if this is the first element of a list. */ + FIRST_IN_LIST is true if this is the first element of a list. + LOCATE_SYMS true means read symbol occurrences as symbols with + position. */ static Lisp_Object -read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) +read1 (Lisp_Object readcharfun, int *pch, bool first_in_list, bool locate_syms) { int c; bool uninterned_symbol = false; @@ -2994,10 +3027,10 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) switch (c) { case '(': - return read_list (0, readcharfun); + return read_list (0, readcharfun, locate_syms); case '[': - return read_vector (readcharfun, 0); + return read_vector (readcharfun, 0, locate_syms); case ')': case ']': @@ -3016,7 +3049,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) /* Accept extended format for hash tables (extensible to other types), e.g. #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */ - Lisp_Object tmp = read_list (0, readcharfun); + Lisp_Object tmp = read_list (0, readcharfun, false); Lisp_Object head = CAR_SAFE (tmp); Lisp_Object data = Qnil; Lisp_Object val = Qnil; @@ -3105,7 +3138,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (c == '[') { Lisp_Object tmp; - tmp = read_vector (readcharfun, 0); + tmp = read_vector (readcharfun, 0, false); if (ASIZE (tmp) < CHAR_TABLE_STANDARD_SLOTS) error ("Invalid size char-table"); XSETPVECTYPE (XVECTOR (tmp), PVEC_CHAR_TABLE); @@ -3118,7 +3151,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) { /* Sub char-table can't be read as a regular vector because of a two C integer fields. */ - Lisp_Object tbl, tmp = read_list (1, readcharfun); + Lisp_Object tbl, tmp = read_list (1, readcharfun, false); ptrdiff_t size = list_length (tmp); int i, depth, min_char; struct Lisp_Cons *cell; @@ -3156,7 +3189,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (c == '&') { Lisp_Object length; - length = read1 (readcharfun, pch, first_in_list); + length = read1 (readcharfun, pch, first_in_list, false); c = READCHAR; if (c == '"') { @@ -3165,7 +3198,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) unsigned char *data; UNREAD (c); - tmp = read1 (readcharfun, pch, first_in_list); + tmp = read1 (readcharfun, pch, first_in_list, false); if (STRING_MULTIBYTE (tmp) || (size_in_chars != SCHARS (tmp) /* We used to print 1 char too many @@ -3193,7 +3226,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) build them using function calls. */ Lisp_Object tmp; struct Lisp_Vector *vec; - tmp = read_vector (readcharfun, 1); + tmp = read_vector (readcharfun, 1, locate_syms); vec = XVECTOR (tmp); if (! (COMPILED_STACK_DEPTH < ASIZE (tmp) && (FIXNUMP (AREF (tmp, COMPILED_ARGLIST)) @@ -3243,7 +3276,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) int ch; /* Read the string itself. */ - tmp = read1 (readcharfun, &ch, 0); + tmp = read1 (readcharfun, &ch, 0, false); if (ch != 0 || !STRINGP (tmp)) invalid_syntax ("#", readcharfun); /* Read the intervals and their properties. */ @@ -3251,14 +3284,14 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) { Lisp_Object beg, end, plist; - beg = read1 (readcharfun, &ch, 0); + beg = read1 (readcharfun, &ch, 0, false); end = plist = Qnil; if (ch == ')') break; if (ch == 0) - end = read1 (readcharfun, &ch, 0); + end = read1 (readcharfun, &ch, 0, false); if (ch == 0) - plist = read1 (readcharfun, &ch, 0); + plist = read1 (readcharfun, &ch, 0, false); if (ch) invalid_syntax ("Invalid string property list", readcharfun); Fset_text_properties (beg, end, plist, tmp); @@ -3369,7 +3402,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (c == '$') return Vload_file_name; if (c == '\'') - return list2 (Qfunction, read0 (readcharfun)); + return list2 (Qfunction, read0 (readcharfun, locate_syms)); /* #:foo is the uninterned symbol named foo. */ if (c == ':') { @@ -3452,7 +3485,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) hash_put (h, number, placeholder, hash); /* Read the object itself. */ - Lisp_Object tem = read0 (readcharfun); + Lisp_Object tem = read0 (readcharfun, locate_syms); /* If it can be recursive, remember it for future substitutions. */ @@ -3508,6 +3541,9 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) else if (c == 'b' || c == 'B') return read_integer (readcharfun, 2, stackbuf); + char acm_buf[15]; /* FIXME!!! 2021-11-27. */ + sprintf (acm_buf, "#%c", c); + invalid_syntax (acm_buf, readcharfun); UNREAD (c); invalid_syntax ("#", readcharfun); @@ -3516,10 +3552,10 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) goto retry; case '\'': - return list2 (Qquote, read0 (readcharfun)); + return list2 (Qquote, read0 (readcharfun, locate_syms)); case '`': - return list2 (Qbackquote, read0 (readcharfun)); + return list2 (Qbackquote, read0 (readcharfun, locate_syms)); case ',': { @@ -3535,7 +3571,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) comma_type = Qcomma; } - value = read0 (readcharfun); + value = read0 (readcharfun, locate_syms); return list2 (comma_type, value); } case '?': @@ -3842,6 +3878,11 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) result = intern_driver (name, obarray, tem); } } + if (locate_syms + && !NILP (result) + ) + result = build_symbol_with_pos (result, + make_fixnum (start_position)); if (EQ (Vread_with_symbol_positions, Qt) || EQ (Vread_with_symbol_positions, readcharfun)) @@ -4100,9 +4141,9 @@ string_to_number (char const *string, int base, ptrdiff_t *plen) static Lisp_Object -read_vector (Lisp_Object readcharfun, bool bytecodeflag) +read_vector (Lisp_Object readcharfun, bool bytecodeflag, bool locate_syms) { - Lisp_Object tem = read_list (1, readcharfun); + Lisp_Object tem = read_list (1, readcharfun, locate_syms); ptrdiff_t size = list_length (tem); Lisp_Object vector = make_nil_vector (size); @@ -4174,10 +4215,12 @@ read_vector (Lisp_Object readcharfun, bool bytecodeflag) return vector; } -/* FLAG means check for ']' to terminate rather than ')' and '.'. */ +/* FLAG means check for ']' to terminate rather than ')' and '.'. + LOCATE_SYMS true means read symbol occurrencess as symbols with + position. */ static Lisp_Object -read_list (bool flag, Lisp_Object readcharfun) +read_list (bool flag, Lisp_Object readcharfun, bool locate_syms) { Lisp_Object val, tail; Lisp_Object elt, tem; @@ -4195,7 +4238,7 @@ read_list (bool flag, Lisp_Object readcharfun) while (1) { int ch; - elt = read1 (readcharfun, &ch, first_in_list); + elt = read1 (readcharfun, &ch, first_in_list, locate_syms); first_in_list = 0; @@ -4239,10 +4282,10 @@ read_list (bool flag, Lisp_Object readcharfun) if (ch == '.') { if (!NILP (tail)) - XSETCDR (tail, read0 (readcharfun)); + XSETCDR (tail, read0 (readcharfun, locate_syms)); else - val = read0 (readcharfun); - read1 (readcharfun, &ch, 0); + val = read0 (readcharfun, locate_syms); + read1 (readcharfun, &ch, 0, locate_syms); if (ch == ')') { @@ -5120,6 +5163,7 @@ void syms_of_lread (void) { defsubr (&Sread); + defsubr (&Sread_positioning_symbols); defsubr (&Sread_from_string); defsubr (&Slread__substitute_object_in_subtree); defsubr (&Sintern); diff --git a/src/print.c b/src/print.c index adadb289de..eb0fe591b8 100644 --- a/src/print.c +++ b/src/print.c @@ -1416,6 +1416,30 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, printchar ('>', printcharfun); break; + case PVEC_SYMBOL_WITH_POS: + { + struct Lisp_Symbol_With_Pos *sp = XSYMBOL_WITH_POS (obj); + if (print_symbols_bare) + print_object (sp->sym, printcharfun, escapeflag); + else + { + print_c_string ("#sym)) + print_object (sp->sym, printcharfun, escapeflag); + else + print_c_string ("NOT A SYMBOL!!", printcharfun); + if (FIXNUMP (sp->pos)) + { + print_c_string (" at ", printcharfun); + print_object (sp->pos, printcharfun, escapeflag); + } + else + print_c_string (" NOT A POSITION!!", printcharfun); + printchar ('>', printcharfun); + } + } + break; + case PVEC_OVERLAY: print_c_string ("#buffer) @@ -1921,7 +1945,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) error ("Apparently circular structure being printed"); for (i = 0; i < print_depth; i++) - if (EQ (obj, being_printed[i])) + if (BASE_EQ (obj, being_printed[i])) { int len = sprintf (buf, "#%d", i); strout (buf, len, len, printcharfun); @@ -2425,6 +2449,13 @@ priorities. Values other than nil or t are also treated as `default'. */); Vprint_charset_text_property = Qdefault; + DEFVAR_BOOL ("print-symbols-bare", print_symbols_bare, + doc: /* A flag to control printing of symbols with position. +If the value is nil, print these objects complete with position. +Otherwise print just the bare symbol. */); + print_symbols_bare = false; + DEFSYM (Qprint_symbols_bare, "print-symbols-bare"); + /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */ staticpro (&Vprin1_to_string_buffer);