From ba29d13f41b777969a324894ba82646d36e1ff5c Mon Sep 17 00:00:00 2001 From: Jared Finder Date: Wed, 2 Dec 2020 00:05:59 -0800 Subject: [PATCH 001/133] Make mouse-related calls be more consistent on all frame types * src/frame.c (Fset_mouse_position, Fset_mouse_pixel_position): Call Fselect_frame and appropriate mouse_moveto function on all non-GUI frame types, independent of #ifdef's. * src/term.c (init_tty): Initialize mouse_face_window for all non-GUI frame types. (term_mouse_moveto) [HAVE_GPM]: Make available even if HAVE_WINDOW_SYSTEM is defined. * src/xdisp.c (try_window_id): Call gui_clear_window_mouse_face in all cases. --- src/frame.c | 59 +++++++++++++++++++++++++++++++------------------ src/term.c | 4 +--- src/termhooks.h | 2 -- src/xdisp.c | 3 +-- 4 files changed, 39 insertions(+), 29 deletions(-) diff --git a/src/frame.c b/src/frame.c index 45ee96e9620..4d3d05ebbd3 100644 --- a/src/frame.c +++ b/src/frame.c @@ -2572,23 +2572,30 @@ before calling this function on it, like this. int yval = check_integer_range (y, INT_MIN, INT_MAX); /* I think this should be done with a hook. */ -#ifdef HAVE_WINDOW_SYSTEM if (FRAME_WINDOW_P (XFRAME (frame))) - /* Warping the mouse will cause enternotify and focus events. */ - frame_set_mouse_position (XFRAME (frame), xval, yval); -#elif defined MSDOS - if (FRAME_MSDOS_P (XFRAME (frame))) + { +#ifdef HAVE_WINDOW_SYSTEM + /* Warping the mouse will cause enternotify and focus events. */ + frame_set_mouse_position (XFRAME (frame), xval, yval); +#endif /* HAVE_WINDOW_SYSTEM */ + } + else if (FRAME_MSDOS_P (XFRAME (frame))) { Fselect_frame (frame, Qnil); +#ifdef MSDOS mouse_moveto (xval, yval); +#endif /* MSDOS */ } -#elif defined HAVE_GPM - Fselect_frame (frame, Qnil); - term_mouse_moveto (xval, yval); + else + { + Fselect_frame (frame, Qnil); +#ifdef HAVE_GPM + term_mouse_moveto (xval, yval); #else - (void) xval; - (void) yval; -#endif + (void) xval; + (void) yval; +#endif /* HAVE_GPM */ + } return Qnil; } @@ -2610,23 +2617,31 @@ before calling this function on it, like this. int yval = check_integer_range (y, INT_MIN, INT_MAX); /* I think this should be done with a hook. */ -#ifdef HAVE_WINDOW_SYSTEM if (FRAME_WINDOW_P (XFRAME (frame))) - /* Warping the mouse will cause enternotify and focus events. */ - frame_set_mouse_pixel_position (XFRAME (frame), xval, yval); -#elif defined MSDOS - if (FRAME_MSDOS_P (XFRAME (frame))) + { + /* Warping the mouse will cause enternotify and focus events. */ +#ifdef HAVE_WINDOW_SYSTEM + frame_set_mouse_pixel_position (XFRAME (frame), xval, yval); +#endif /* HAVE_WINDOW_SYSTEM */ + } + else if (FRAME_MSDOS_P (XFRAME (frame))) { Fselect_frame (frame, Qnil); +#ifdef MSDOS mouse_moveto (xval, yval); +#endif /* MSDOS */ } -#elif defined HAVE_GPM - Fselect_frame (frame, Qnil); - term_mouse_moveto (xval, yval); + else + { + Fselect_frame (frame, Qnil); +#ifdef HAVE_GPM + term_mouse_moveto (xval, yval); #else - (void) xval; - (void) yval; -#endif + (void) xval; + (void) yval; +#endif /* HAVE_GPM */ + + } return Qnil; } diff --git a/src/term.c b/src/term.c index a87f9c745ce..2e2ab2bf438 100644 --- a/src/term.c +++ b/src/term.c @@ -2382,7 +2382,6 @@ frame's terminal). */) #ifdef HAVE_GPM -#ifndef HAVE_WINDOW_SYSTEM void term_mouse_moveto (int x, int y) { @@ -2396,7 +2395,6 @@ term_mouse_moveto (int x, int y) last_mouse_x = x; last_mouse_y = y; */ } -#endif /* HAVE_WINDOW_SYSTEM */ /* Implementation of draw_row_with_mouse_face for TTY/GPM. */ void @@ -4246,8 +4244,8 @@ use the Bourne shell command 'TERM=...; export TERM' (C-shell:\n\ #ifdef HAVE_GPM terminal->mouse_position_hook = term_mouse_position; - tty->mouse_highlight.mouse_face_window = Qnil; #endif + tty->mouse_highlight.mouse_face_window = Qnil; terminal->kboard = allocate_kboard (Qnil); terminal->kboard->reference_count++; diff --git a/src/termhooks.h b/src/termhooks.h index 85a47c071b6..3800679e803 100644 --- a/src/termhooks.h +++ b/src/termhooks.h @@ -366,9 +366,7 @@ enum { #ifdef HAVE_GPM #include extern int handle_one_term_event (struct tty_display_info *, Gpm_Event *); -#ifndef HAVE_WINDOW_SYSTEM extern void term_mouse_moveto (int, int); -#endif /* The device for which we have enabled gpm support. */ extern struct tty_display_info *gpm_tty; diff --git a/src/xdisp.c b/src/xdisp.c index ea67329cff1..32e9773b54e 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -20822,9 +20822,8 @@ try_window_id (struct window *w) + window_wants_header_line (w) + window_internal_height (w)); -#if defined (HAVE_GPM) || defined (MSDOS) gui_clear_window_mouse_face (w); -#endif + /* Perform the operation on the screen. */ if (dvpos > 0) { From c55b7b8e1f46612849a25f035578a46fa3fe343b Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 16 Jan 2021 15:02:48 +0200 Subject: [PATCH 002/133] Fix last change * src/frame.c (Fset_mouse_position, Fset_mouse_pixel_position): Don't compile the FRAME_MSDOS_P case on platforms other than MSDOS, as that will never happen there. --- src/frame.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/frame.c b/src/frame.c index 4d3d05ebbd3..599c4075f88 100644 --- a/src/frame.c +++ b/src/frame.c @@ -2579,13 +2579,13 @@ before calling this function on it, like this. frame_set_mouse_position (XFRAME (frame), xval, yval); #endif /* HAVE_WINDOW_SYSTEM */ } +#ifdef MSDOS else if (FRAME_MSDOS_P (XFRAME (frame))) { Fselect_frame (frame, Qnil); -#ifdef MSDOS mouse_moveto (xval, yval); -#endif /* MSDOS */ } +#endif /* MSDOS */ else { Fselect_frame (frame, Qnil); @@ -2624,13 +2624,13 @@ before calling this function on it, like this. frame_set_mouse_pixel_position (XFRAME (frame), xval, yval); #endif /* HAVE_WINDOW_SYSTEM */ } +#ifdef MSDOS else if (FRAME_MSDOS_P (XFRAME (frame))) { Fselect_frame (frame, Qnil); -#ifdef MSDOS mouse_moveto (xval, yval); -#endif /* MSDOS */ } +#endif /* MSDOS */ else { Fselect_frame (frame, Qnil); From 84e0749b8b180bb94a5c32ebda11b5f22942dc22 Mon Sep 17 00:00:00 2001 From: Ted Zlatanov Date: Sat, 16 Jan 2021 13:03:58 +0000 Subject: [PATCH 003/133] EMBA container build improvements for Emacs build testing. * test/infra/gitlab-ci.yml: Moved from .gitlab-ci.yml. Use the EMBA container registry with a different login token storage file for each commit. Split test stages into prep, build, fast tests, normal tests, platform tests, and slow (everything) and use templates where possible. * .gitlab-ci.yml: Include test/infra/gitlab-ci.yml and move all content there. --- .gitlab-ci.yml | 142 +------------------------ test/infra/Dockerfile.emba | 2 +- test/infra/gitlab-ci.yml | 208 +++++++++++++++++++++++++++++++++++++ 3 files changed, 212 insertions(+), 140 deletions(-) create mode 100644 test/infra/gitlab-ci.yml diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index eb884767c95..3138f4184e6 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1,4 +1,4 @@ -# Copyright (C) 2017-2021 Free Software Foundation, Inc. +# Copyright (C) 2021 Free Software Foundation, Inc. # # This file is part of GNU Emacs. # @@ -24,141 +24,5 @@ # Maintainer: Ted Zlatanov # URL: https://emba.gnu.org/emacs/emacs -# Never run merge request pipelines, they usually duplicate push pipelines -# see https://docs.gitlab.com/ee/ci/yaml/README.html#common-if-clauses-for-rules -workflow: - rules: - - if: '$CI_PIPELINE_SOURCE == "merge_request_event"' - when: never - - when: always - -variables: - GIT_STRATEGY: fetch - EMACS_EMBA_CI: 1 - -default: - image: docker:19.03.12 - timeout: 3 hours - before_script: - - docker info - -.job-template: - # these will be cached across builds - cache: - key: ${CI_COMMIT_REF_SLUG} - paths: [] - policy: pull-push - # these will be saved for followup builds - artifacts: - expire_in: 24 hrs - paths: [] - # - "test/**/*.log" - # - "**/*.log" - -.test-template: - rules: - - changes: - - "**/Makefile.in" - - .gitlab-ci.yml - - aclocal.m4 - - autogen.sh - - configure.ac - - lib/*.{h,c} - - lisp/**/*.el - - src/*.{h,c} - - test/infra/* - - test/lisp/**/*.el - - test/src/*.el - - changes: - # gfilemonitor, kqueue - - src/gfilenotify.c - - src/kqueue.c - # MS Windows - - "**/w32*" - # GNUstep - - lisp/term/ns-win.el - - src/ns*.{h,m} - - src/macfont.{h,m} - when: never - - # using the variables for each job - script: - - docker build --target ${target} -t ${target}:${CI_COMMIT_REF_SLUG} -t ${target}:${CI_COMMIT_SHA} -f test/infra/Dockerfile.emba . - # TODO: with make -j4 several of the tests were failing, for example shadowfile-tests, but passed without it - - docker run -i --rm -e EMACS_EMBA_CI=${EMACS_EMBA_CI} ${target}:${CI_COMMIT_SHA} make ${make_params} - -stages: - - fast - - normal - - slow - -test-fast: - stage: fast - extends: [.job-template, .test-template] - variables: - target: emacs-inotify - make_params: "-C test check" - -test-lisp: - stage: normal - extends: [.job-template, .test-template] - variables: - target: emacs-inotify - make_params: "-C test check-lisp" - -test-net: - stage: normal - extends: [.job-template, .test-template] - variables: - target: emacs-inotify - make_params: "-C test check-net" - -test-filenotify-gio: - # This tests file monitor libraries gfilemonitor and gio. - stage: normal - extends: [.job-template, .test-template] - rules: - - if: '$CI_PIPELINE_SOURCE == "schedule"' - changes: - - "**/Makefile.in" - - .gitlab-ci.yml - - lisp/autorevert.el - - lisp/filenotify.el - - lisp/net/tramp-sh.el - - src/gfilenotify.c - - test/infra/* - - test/lisp/autorevert-tests.el - - test/lisp/filenotify-tests.el - variables: - target: emacs-filenotify-gio - make_params: "-k -C test autorevert-tests filenotify-tests" - -test-gnustep: - # This tests the GNUstep build process - stage: normal - extends: [.job-template, .test-template] - rules: - - if: '$CI_PIPELINE_SOURCE == "schedule"' - changes: - - "**/Makefile.in" - - .gitlab-ci.yml - - configure.ac - - src/ns*.{h,m} - - src/macfont.{h,m} - - lisp/term/ns-win.el - - nextstep/**/* - - test/infra/* - variables: - target: emacs-gnustep - make_params: install - -test-all: - # This tests also file monitor libraries inotify and inotifywatch. - stage: slow - extends: [.job-template, .test-template] - rules: - # note there's no "changes" section, so this always runs on a schedule - - if: '$CI_PIPELINE_SOURCE == "schedule"' - variables: - target: emacs-inotify - make_params: check-expensive +# Just load from test/infra, to keep build automation files there. +include: '/test/infra/gitlab-ci.yml' diff --git a/test/infra/Dockerfile.emba b/test/infra/Dockerfile.emba index dd41982ad59..421264db9c9 100644 --- a/test/infra/Dockerfile.emba +++ b/test/infra/Dockerfile.emba @@ -41,7 +41,7 @@ COPY . /checkout WORKDIR /checkout RUN ./autogen.sh autoconf RUN ./configure --without-makeinfo -RUN make bootstrap +RUN make -j4 bootstrap RUN make -j4 FROM emacs-base as emacs-filenotify-gio diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml new file mode 100644 index 00000000000..d8934551b00 --- /dev/null +++ b/test/infra/gitlab-ci.yml @@ -0,0 +1,208 @@ +# Copyright (C) 2017-2021 Free Software Foundation, Inc. +# +# This file is part of GNU Emacs. +# +# GNU Emacs is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# GNU Emacs is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GNU Emacs. If not, see . + +# GNU Emacs support for the GitLab protocol for CI + +# The presence of this file does not imply any FSF/GNU endorsement of +# any particular service that uses that protocol. Also, it is intended for +# evaluation purposes, thus possibly temporary. + +# Maintainer: Ted Zlatanov +# URL: https://emba.gnu.org/emacs/emacs + +# Never run merge request pipelines, they usually duplicate push pipelines +# see https://docs.gitlab.com/ee/ci/yaml/README.html#common-if-clauses-for-rules +workflow: + rules: + - if: '$CI_PIPELINE_SOURCE == "merge_request_event"' + when: never + - when: always + +variables: + GIT_STRATEGY: fetch + EMACS_EMBA_CI: 1 + # # Use TLS https://docs.gitlab.com/ee/ci/docker/using_docker_build.html#tls-enabled + # DOCKER_HOST: tcp://docker:2376 + # DOCKER_TLS_CERTDIR: "/certs" + # Put the configuration for each run in a separate directory to avoid conflicts + DOCKER_CONFIG: "/.docker-config-${CI_COMMIT_SHA}" + +default: + image: docker:19.03.12 + timeout: 3 hours + before_script: + - docker info + - echo "docker registry is ${CI_REGISTRY}" + - docker login -u ${CI_REGISTRY_USER} -p ${CI_REGISTRY_PASSWORD} ${CI_REGISTRY} + +.job-template: + # these will be cached across builds + cache: + key: ${CI_COMMIT_SHA} + paths: [] + policy: pull-push + # these will be saved for followup builds + artifacts: + expire_in: 24 hrs + paths: [] + # - "test/**/*.log" + # - "**/*.log" + +.build-template: + script: + - docker build --pull --target ${target} -t ${CI_REGISTRY_IMAGE}:${target}-${CI_COMMIT_SHA} -f test/infra/Dockerfile.emba . + - docker push ${CI_REGISTRY_IMAGE}:${target}-${CI_COMMIT_SHA} + +.gnustep-template: + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + changes: + - "**/Makefile.in" + - .gitlab-ci.yml + - configure.ac + - src/ns*.{h,m} + - src/macfont.{h,m} + - lisp/term/ns-win.el + - nextstep/**/* + - test/infra/* + +.filenotify-gio-template: + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + changes: + - "**/Makefile.in" + - .gitlab-ci.yml + - lisp/autorevert.el + - lisp/filenotify.el + - lisp/net/tramp-sh.el + - src/gfilenotify.c + - test/infra/* + - test/lisp/autorevert-tests.el + - test/lisp/filenotify-tests.el + +.test-template: + rules: + - changes: + - "**/Makefile.in" + - .gitlab-ci.yml + - aclocal.m4 + - autogen.sh + - configure.ac + - lib/*.{h,c} + - lisp/**/*.el + - src/*.{h,c} + - test/infra/* + - test/lisp/**/*.el + - test/src/*.el + - changes: + # gfilemonitor, kqueue + - src/gfilenotify.c + - src/kqueue.c + # MS Windows + - "**/w32*" + # GNUstep + - lisp/term/ns-win.el + - src/ns*.{h,m} + - src/macfont.{h,m} + when: never + + # using the variables for each job + script: + - docker pull ${CI_REGISTRY_IMAGE}:${target}-${CI_COMMIT_SHA} + # TODO: with make -j4 several of the tests were failing, for example shadowfile-tests, but passed without it + - docker run -i --rm -e EMACS_EMBA_CI=${EMACS_EMBA_CI} ${CI_REGISTRY_IMAGE}:${target}-${CI_COMMIT_SHA} make ${make_params} + +stages: + - prep-images + - build-images + - fast + - normal + - platform-images + - platforms + - slow + +prep-image-base: + stage: prep-images + extends: [.job-template, .build-template] + variables: + target: emacs-base + +build-image-inotify: + stage: build-images + extends: [.job-template, .build-template] + variables: + target: emacs-inotify + +test-fast-inotify: + stage: fast + extends: [.job-template, .test-template] + variables: + target: emacs-inotify + make_params: "-C test check" + +build-image-filenotify-gio: + stage: platform-images + extends: [.job-template, .build-template, .filenotify-gio-template] + variables: + target: emacs-filenotify-gio + +build-image-gnustep: + stage: platform-images + extends: [.job-template, .build-template, .gnustep-template] + variables: + target: emacs-gnustep + +test-lisp-inotify: + stage: normal + extends: [.job-template, .test-template] + variables: + target: emacs-inotify + make_params: "-C test check-lisp" + +test-net-inotify: + stage: normal + extends: [.job-template, .test-template] + variables: + target: emacs-inotify + make_params: "-C test check-net" + +test-filenotify-gio: + # This tests file monitor libraries gfilemonitor and gio. + stage: platforms + extends: [.job-template, .test-template, .filenotify-gio-template] + variables: + target: emacs-filenotify-gio + make_params: "-k -C test autorevert-tests filenotify-tests" + +test-gnustep: + # This tests the GNUstep build process + stage: platforms + extends: [.job-template, .test-template, .gnustep-template] + variables: + target: emacs-gnustep + make_params: install + +test-all-inotify: + # This tests also file monitor libraries inotify and inotifywatch. + stage: slow + extends: [.job-template, .test-template] + rules: + # note there's no "changes" section, so this always runs on a schedule + - if: '$CI_PIPELINE_SOURCE == "schedule"' + variables: + target: emacs-inotify + make_params: check-expensive From 378ce65a0d26347cb6f25237650f2c8ba9b37bcf Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 16 Jan 2021 16:54:01 +0200 Subject: [PATCH 004/133] Improve support for Cham script * lisp/language/cham.el ("Cham"): Expand the entry. * etc/HELLO: Add entry for Cham. --- etc/HELLO | 2 ++ lisp/language/cham.el | 7 ++++++- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/etc/HELLO b/etc/HELLO index dec3a775afb..9a1f5d30edd 100644 --- a/etc/HELLO +++ b/etc/HELLO @@ -30,6 +30,8 @@ Bengali (বাংলা) নমস্কার Braille ⠓⠑⠇⠇⠕ Burmese (မြန်မာ) မင်္ဂလာပါ C printf ("Hello, world!\n"); +Cham (ꨌꩌ) ꨦꨤꩌ ꨦꨰꨁ + Cherokee (ᏣᎳᎩ ᎦᏬᏂᎯᏍᏗ) ᎣᏏᏲ / ᏏᏲ Comanche /kəˈmæntʃiː/ Haa marʉ́awe diff --git a/lisp/language/cham.el b/lisp/language/cham.el index eef6d6f8f9f..194574f6a8e 100644 --- a/lisp/language/cham.el +++ b/lisp/language/cham.el @@ -34,6 +34,11 @@ (set-language-info-alist "Cham" '((charset unicode) (coding-system utf-8) - (coding-priority utf-8))) + (coding-priority utf-8) + (sample-text . "Cham (ꨌꩌ)\tꨦꨤꩌ ꨦꨰꨁ") + (documentation . "\ +The Cham script is a Brahmic script used to write Cham, +an Austronesian language spoken by some 245,000 Chams +in Vietnam and Cambodia."))) (provide 'cham) From 57ae3f29af160d08a3a3568a7d969adecd25bcb7 Mon Sep 17 00:00:00 2001 From: Ted Zlatanov Date: Sat, 16 Jan 2021 15:45:05 +0000 Subject: [PATCH 005/133] test/infra/gitlab-ci.yml: run only for tags and some branches --- test/infra/gitlab-ci.yml | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index d8934551b00..f9c0e0c11ab 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -26,10 +26,19 @@ # Never run merge request pipelines, they usually duplicate push pipelines # see https://docs.gitlab.com/ee/ci/yaml/README.html#common-if-clauses-for-rules + +# Rules: always run tags and branches named master*, emacs*, feature*, fix* +# Test that it triggers by pushing a tag: `git tag mytag; git push origin mytag` +# Test that it triggers by pushing to: feature/emba, feature1, master, master-2, fix/emba, emacs-299, fix-2 +# Test that it doesn't trigger by pushing to: scratch-2, scratch/emba, oldbranch, dev workflow: rules: - if: '$CI_PIPELINE_SOURCE == "merge_request_event"' when: never + - if: '$CI_COMMIT_TAG' + when: always + - if: '$CI_COMMIT_BRANCH !~ /^(master|emacs|feature|fix)/' + when: never - when: always variables: From 0057294b2ad6cdd2802e1b290a190fa42e723fb8 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 16 Jan 2021 20:15:17 +0200 Subject: [PATCH 006/133] Fix two tests * test/lisp/progmodes/elisp-mode-tests.el (xref-elisp-test-run): Make sure file names can be compared as strings, by running them through 'file-truename'. Reported by Vin Shelton . * test/lisp/emacs-lisp/bytecomp-tests.el ("warn-obsolete-hook.el") ("warn-obsolete-variable.el"): Use [^z-a] to match a newline as well. Reported by Vin Shelton . --- test/lisp/emacs-lisp/bytecomp-tests.el | 4 ++-- test/lisp/progmodes/elisp-mode-tests.el | 14 +++++++++++++- 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index a07af188fac..263736af4ed 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -617,13 +617,13 @@ Subtests signal errors if something goes wrong." (make-obsolete-variable 'bytecomp--tests-obsolete-var nil "99.99") (bytecomp--define-warning-file-test "warn-obsolete-hook.el" - "bytecomp--tests-obs.*obsolete.*99.99") + "bytecomp--tests-obs.*obsolete[^z-a]*99.99") (bytecomp--define-warning-file-test "warn-obsolete-variable-same-file.el" "foo-obs.*obsolete.*99.99" t) (bytecomp--define-warning-file-test "warn-obsolete-variable.el" - "bytecomp--tests-obs.*obsolete.*99.99") + "bytecomp--tests-obs.*obsolete[^z-a]*99.99") (bytecomp--define-warning-file-test "warn-obsolete-variable-bound.el" "bytecomp--tests-obs.*obsolete.*99.99" t) diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el index a10d5dab906..fd43707f277 100644 --- a/test/lisp/progmodes/elisp-mode-tests.el +++ b/test/lisp/progmodes/elisp-mode-tests.el @@ -314,7 +314,19 @@ (let* ((xref (pop xrefs)) (expected (pop expected-xrefs)) (expected-xref (or (when (consp expected) (car expected)) expected)) - (expected-source (when (consp expected) (cdr expected)))) + (expected-source (when (consp expected) (cdr expected))) + (xref-file (xref-elisp-location-file (oref xref location))) + (expected-file (xref-elisp-location-file + (oref expected-xref location)))) + + ;; Make sure file names compare as strings. + (when (file-name-absolute-p xref-file) + (setf (xref-elisp-location-file (oref xref location)) + (file-truename (xref-elisp-location-file (oref xref location))))) + (when (file-name-absolute-p expected-file) + (setf (xref-elisp-location-file (oref expected-xref location)) + (file-truename (xref-elisp-location-file + (oref expected-xref location))))) ;; Downcase the filenames for case-insensitive file systems. (when xref--case-insensitive From 66756df286bea6efd3f9a8290e38e8d77bdf0264 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 16 Jan 2021 20:18:32 +0200 Subject: [PATCH 007/133] Fix Rmail summary for more than 99,999 messages * lisp/mail/rmailsum.el (rmail-summary-font-lock-keywords): Don't assume there will be less than 100,000 messages in an mbox file. (Bug#45912) --- lisp/mail/rmailsum.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el index 60b67edf85a..d29115a9570 100644 --- a/lisp/mail/rmailsum.el +++ b/lisp/mail/rmailsum.el @@ -51,10 +51,10 @@ Setting this option to nil might speed up the generation of summaries." :group 'rmail-summary) (defvar rmail-summary-font-lock-keywords - '(("^.....D.*" . font-lock-string-face) ; Deleted. - ("^.....-.*" . font-lock-type-face) ; Unread. + '(("^ *[0-9]+D.*" . font-lock-string-face) ; Deleted. + ("^ *[0-9]+-.*" . font-lock-type-face) ; Unread. ;; Neither of the below will be highlighted if either of the above are: - ("^.....[^D-] \\(......\\)" 1 font-lock-keyword-face) ; Date. + ("^ *[0-9]+[^D-] \\(......\\)" 1 font-lock-keyword-face) ; Date. ("{ \\([^\n}]+\\) }" 1 font-lock-comment-face)) ; Labels. "Additional expressions to highlight in Rmail Summary mode.") From 8f0ce42d3eb9b212424a4a25a376287ffc94a73e Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Sun, 10 Jan 2021 16:31:12 +0100 Subject: [PATCH 008/133] Fix deadlock when receiving SIGCHLD during 'pselect'. If we receive and handle a SIGCHLD signal for a process while waiting for that process, 'pselect' might never return. Instead, we have to explicitly 'pselect' that the process status has changed. We do this by writing to a pipe in the SIGCHLD handler and having 'wait_reading_process_output' select on it. * src/process.c (child_signal_init): New helper function to create a pipe for SIGCHLD notifications. (child_signal_read, child_signal_notify): New helper functions to read from/write to the child signal pipe. (create_process): Initialize the child signal pipe on first use. (handle_child_signal): Notify waiters that a process status has changed. (wait_reading_process_output): Make sure that we also catch SIGCHLD/process status changes. * test/src/process-tests.el (process-tests/fd-setsize-no-crash/make-process): Remove workaround, which is no longer needed. --- src/process.c | 94 ++++++++++++++++++++++++++++++++++++++- test/src/process-tests.el | 5 --- 2 files changed, 93 insertions(+), 6 deletions(-) diff --git a/src/process.c b/src/process.c index dac7d0440fa..474c87089e0 100644 --- a/src/process.c +++ b/src/process.c @@ -283,6 +283,16 @@ static int max_desc; the file descriptor of a socket that is already bound. */ static int external_sock_fd; +/* File descriptor that becomes readable when we receive SIGCHLD. */ +static int child_signal_read_fd = -1; +/* The write end thereof. The SIGCHLD handler writes to this file + descriptor to notify `wait_reading_process_output' of process + status changes. */ +static int child_signal_write_fd = -1; +static void child_signal_init (void); +static void child_signal_read (int, void *); +static void child_signal_notify (void); + /* Indexed by descriptor, gives the process (if any) for that descriptor. */ static Lisp_Object chan_process[FD_SETSIZE]; static void wait_for_socket_fds (Lisp_Object, char const *); @@ -2060,6 +2070,10 @@ create_process (Lisp_Object process, char **new_argv, Lisp_Object current_dir) Lisp_Object lisp_pty_name = Qnil; sigset_t oldset; + /* Ensure that the SIGCHLD handler can notify + `wait_reading_process_output'. */ + child_signal_init (); + inchannel = outchannel = -1; if (p->pty_flag) @@ -5395,6 +5409,14 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, check_write = true; } + /* We have to be informed when we receive a SIGCHLD signal for + an asynchronous process. Otherwise this might deadlock if we + receive a SIGCHLD during `pselect'. */ + int child_fd = child_signal_read_fd; + eassert (0 <= child_fd); + eassert (child_fd < FD_SETSIZE); + FD_SET (child_fd, &Available); + /* If frame size has changed or the window is newly mapped, redisplay now, before we start to wait. There is a race condition here; if a SIGIO arrives between now and the select @@ -7114,7 +7136,70 @@ process has been transmitted to the serial port. */) subprocesses which the main thread should not reap. For example, if the main thread attempted to reap an already-reaped child, it might inadvertently reap a GTK-created process that happened to - have the same process ID. */ + have the same process ID. + + To avoid a deadlock when receiving SIGCHLD while + `wait_reading_process_output' is in `pselect', the SIGCHLD handler + will notify the `pselect' using a pipe. */ + +/* Set up `child_signal_read_fd' and `child_signal_write_fd'. */ + +static void +child_signal_init (void) +{ + /* Either both are initialized, or both are uninitialized. */ + eassert ((child_signal_read_fd < 0) == (child_signal_write_fd < 0)); + + if (0 <= child_signal_read_fd) + return; /* already done */ + + int fds[2]; + if (emacs_pipe (fds) < 0) + report_file_error ("Creating pipe for child signal", Qnil); + if (FD_SETSIZE <= fds[0]) + { + /* Since we need to `pselect' on the read end, it has to fit + into an `fd_set'. */ + emacs_close (fds[0]); + emacs_close (fds[1]); + report_file_errno ("Creating pipe for child signal", Qnil, + EMFILE); + } + + /* We leave the file descriptors open until the Emacs process + exits. */ + eassert (0 <= fds[0]); + eassert (0 <= fds[1]); + add_read_fd (fds[0], child_signal_read, NULL); + fd_callback_info[fds[0]].flags &= ~KEYBOARD_FD; + child_signal_read_fd = fds[0]; + child_signal_write_fd = fds[1]; +} + +/* Consume a process status change. */ + +static void +child_signal_read (int fd, void *data) +{ + eassert (0 <= fd); + eassert (fd == child_signal_read_fd); + char dummy; + if (emacs_read (fd, &dummy, 1) < 0) + emacs_perror ("reading from child signal FD"); +} + +/* Notify `wait_reading_process_output' of a process status + change. */ + +static void +child_signal_notify (void) +{ + int fd = child_signal_write_fd; + eassert (0 <= fd); + char dummy = 0; + if (emacs_write (fd, &dummy, 1) != 1) + emacs_perror ("writing to child signal FD"); +} /* LIB_CHILD_HANDLER is a SIGCHLD handler that Emacs calls while doing its own SIGCHLD handling. On POSIXish systems, glib needs this to @@ -7152,6 +7237,7 @@ static void handle_child_signal (int sig) { Lisp_Object tail, proc; + bool changed = false; /* Find the process that signaled us, and record its status. */ @@ -7174,6 +7260,7 @@ handle_child_signal (int sig) eassert (ok); if (child_status_changed (deleted_pid, 0, 0)) { + changed = true; if (STRINGP (XCDR (head))) unlink (SSDATA (XCDR (head))); XSETCAR (tail, Qnil); @@ -7191,6 +7278,7 @@ handle_child_signal (int sig) && child_status_changed (p->pid, &status, WUNTRACED | WCONTINUED)) { /* Change the status of the process that was found. */ + changed = true; p->tick = ++process_tick; p->raw_status = status; p->raw_status_new = 1; @@ -7210,6 +7298,10 @@ handle_child_signal (int sig) } } + if (changed) + /* Wake up `wait_reading_process_output'. */ + child_signal_notify (); + lib_child_handler (sig); #ifdef NS_IMPL_GNUSTEP /* NSTask in GNUstep sets its child handler each time it is called. diff --git a/test/src/process-tests.el b/test/src/process-tests.el index 57097cfa052..dad36426a09 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el @@ -576,11 +576,6 @@ FD_SETSIZE file descriptors (Bug#24325)." (should (memq (process-status process) '(run exit))) (when (process-live-p process) (process-send-eof process)) - ;; FIXME: This `sleep-for' shouldn't be needed. It - ;; indicates a bug in Emacs; perhaps SIGCHLD is - ;; received in parallel with `accept-process-output', - ;; causing the latter to hang. - (sleep-for 0.1) (while (accept-process-output process)) (should (eq (process-status process) 'exit)) ;; If there's an error between fork and exec, Emacs From df34ed8cbfdcf4584aa0ebfe827fac3a8d932bb6 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Sun, 10 Jan 2021 17:59:29 +0100 Subject: [PATCH 009/133] Don't crash if no asynchronous process has been created yet. * src/process.c (wait_reading_process_output): Allow child_signal_read_fd < 0. --- src/process.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/process.c b/src/process.c index 474c87089e0..aca87f8ed35 100644 --- a/src/process.c +++ b/src/process.c @@ -5413,9 +5413,9 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, an asynchronous process. Otherwise this might deadlock if we receive a SIGCHLD during `pselect'. */ int child_fd = child_signal_read_fd; - eassert (0 <= child_fd); eassert (child_fd < FD_SETSIZE); - FD_SET (child_fd, &Available); + if (0 <= child_fd) + FD_SET (child_fd, &Available); /* If frame size has changed or the window is newly mapped, redisplay now, before we start to wait. There is a race From 0ab56a4e935b3aa759229923804ba33c841f425c Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 16 Jan 2021 10:15:47 -0500 Subject: [PATCH 010/133] * lisp/emacs-lisp/pcase.el: Add support for `not` to `pred` (pcase--split-pred, pcase--funcall): Adjust for `not`. (pcase--get-macroexpander): New function. (pcase--edebug-match-macro, pcase--make-docstring) (pcase--macroexpand): Use it. * lisp/emacs-lisp/radix-tree.el (radix-tree-leaf): Use it! * doc/lispref/control.texi (The @code{pcase} macro): Document it. * lisp/emacs-lisp/ert.el (ert--explain-equal-rec): Remove redundant test. --- doc/lispref/control.texi | 5 ++-- etc/NEWS | 6 ++++ lisp/emacs-lisp/ert.el | 4 +-- lisp/emacs-lisp/pcase.el | 46 +++++++++++++++++++++++------ lisp/emacs-lisp/radix-tree.el | 7 +++-- test/lisp/emacs-lisp/pcase-tests.el | 4 +++ 6 files changed, 56 insertions(+), 16 deletions(-) diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index 55bcddb31aa..80e9eb7dd8e 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi @@ -557,8 +557,9 @@ Likewise, it makes no sense to bind keyword symbols @item (pred @var{function}) Matches if the predicate @var{function} returns non-@code{nil} -when called on @var{expval}. -the predicate @var{function} can have one of the following forms: +when called on @var{expval}. The test can be negated with the syntax +@code{(pred (not @var{function}))}. +The predicate @var{function} can have one of the following forms: @table @asis @item function name (a symbol) diff --git a/etc/NEWS b/etc/NEWS index fc7dcbcf4c6..359d308bf19 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -326,6 +326,12 @@ the buffer cycles the whole buffer between "only top-level headings", * Changes in Specialized Modes and Packages in Emacs 28.1 +** pcase ++++ +*** The `pred` pattern can now take the form (pred (not FUN)). +This is like (pred (lambda (x) (not (FUN x)))) but results +in better code. + +++ ** profiler.el The results displayed by 'profiler-report' now have the usage figures diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 58517549454..fdbf95319ff 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -487,7 +487,7 @@ Errors during evaluation are caught and handled like nil." Returns nil if they are." (if (not (eq (type-of a) (type-of b))) `(different-types ,a ,b) - (pcase-exhaustive a + (pcase a ((pred consp) (let ((a-length (proper-list-p a)) (b-length (proper-list-p b))) @@ -538,7 +538,7 @@ Returns nil if they are." for xi = (ert--explain-equal-rec ai bi) do (when xi (cl-return `(array-elt ,i ,xi))) finally (cl-assert (equal a b) t)))) - ((pred atom) + (_ (if (not (equal a b)) (if (and (symbolp a) (symbolp b) (string= a b)) `(different-symbols-with-the-same-name ,a ,b) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 72ea1ba0188..bfd577c5d14 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -39,10 +39,10 @@ ;; - along these lines, provide patterns to match CL structs. ;; - provide something like (setq VAR) so a var can be set rather than ;; let-bound. -;; - provide a way to fallthrough to subsequent cases (not sure what I meant by -;; this :-() +;; - provide a way to fallthrough to subsequent cases +;; (e.g. Like Racket's (=> ID). ;; - try and be more clever to reduce the size of the decision tree, and -;; to reduce the number of leaves that need to be turned into function: +;; to reduce the number of leaves that need to be turned into functions: ;; - first, do the tests shared by all remaining branches (it will have ;; to be performed anyway, so better do it first so it's shared). ;; - then choose the test that discriminates more (?). @@ -97,11 +97,15 @@ (declare-function get-edebug-spec "edebug" (symbol)) (declare-function edebug-match "edebug" (cursor specs)) +(defun pcase--get-macroexpander (s) + "Return the macroexpander for pcase pattern head S, or nil" + (get s 'pcase-macroexpander)) + (defun pcase--edebug-match-macro (cursor) (let (specs) (mapatoms (lambda (s) - (let ((m (get s 'pcase-macroexpander))) + (let ((m (pcase--get-macroexpander s))) (when (and m (get-edebug-spec m)) (push (cons (symbol-name s) (get-edebug-spec m)) specs))))) @@ -128,6 +132,7 @@ PATTERN matches. PATTERN can take one of the forms: If a SYMBOL is used twice in the same pattern the second occurrence becomes an `eq'uality test. (pred FUN) matches if FUN called on EXPVAL returns non-nil. + (pred (not FUN)) matches if FUN called on EXPVAL returns nil. (app FUN PAT) matches if FUN called on EXPVAL matches PAT. (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. (let PAT EXPR) matches if EXPR matches PAT. @@ -193,7 +198,7 @@ Emacs Lisp manual for more information and examples." (let (more) ;; Collect all the extensions. (mapatoms (lambda (symbol) - (let ((me (get symbol 'pcase-macroexpander))) + (let ((me (pcase--get-macroexpander symbol))) (when me (push (cons symbol me) more))))) @@ -424,7 +429,7 @@ of the elements of LIST is performed as if by `pcase-let'. ((eq head 'let) `(let ,(pcase--macroexpand (cadr pat)) ,@(cddr pat))) ((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat)))) (t - (let* ((expander (get head 'pcase-macroexpander)) + (let* ((expander (pcase--get-macroexpander head)) (npat (if expander (apply expander (cdr pat))))) (if (null npat) (error (if expander @@ -658,6 +663,14 @@ MATCH is the pattern that needs to be matched, of the form: '(:pcase--succeed . nil)))) (defun pcase--split-pred (vars upat pat) + "Indicate the overlap or mutual-exclusion between UPAT and PAT. +More specifically retuns a pair (A . B) where A indicates whether PAT +can match when UPAT has matched, and B does the same for the case +where UPAT failed to match. +A and B can be one of: +- nil if we don't know +- `:pcase--fail' if UPAT match's result implies that PAT can't match +- `:pcase--succeed' if UPAT match's result implies that PAT matches" (let (test) (cond ((and (equal upat pat) @@ -670,6 +683,19 @@ MATCH is the pattern that needs to be matched, of the form: ;; and catch at least the easy cases such as (bug#14773). (not (macroexp--fgrep (mapcar #'car vars) (cadr upat))))) '(:pcase--succeed . :pcase--fail)) + ;; In case UPAT is of the form (pred (not PRED)) + ((and (eq 'pred (car upat)) (eq 'not (car-safe (cadr upat)))) + (let* ((test (cadr (cadr upat))) + (res (pcase--split-pred vars `(pred ,test) pat))) + (cons (cdr res) (car res)))) + ;; In case PAT is of the form (pred (not PRED)) + ((and (eq 'pred (car-safe pat)) (eq 'not (car-safe (cadr pat)))) + (let* ((test (cadr (cadr pat))) + (res (pcase--split-pred vars upat `(pred ,test))) + (reverse (lambda (x) (cond ((eq x :pcase--succeed) :pcase--fail) + ((eq x :pcase--fail) :pcase--succeed))))) + (cons (funcall reverse (car res)) + (funcall reverse (cdr res))))) ((and (eq 'pred (car upat)) (let ((otherpred (cond ((eq 'pred (car-safe pat)) (cadr pat)) @@ -728,8 +754,10 @@ MATCH is the pattern that needs to be matched, of the form: (defun pcase--funcall (fun arg vars) "Build a function call to FUN with arg ARG." - (if (symbolp fun) - `(,fun ,arg) + (cond + ((symbolp fun) `(,fun ,arg)) + ((eq 'not (car-safe fun)) `(not ,(pcase--funcall (cadr fun) arg vars))) + (t (let* (;; `env' is an upper bound on the bindings we need. (env (mapcar (lambda (x) (list (car x) (cdr x))) (macroexp--fgrep vars fun))) @@ -747,7 +775,7 @@ MATCH is the pattern that needs to be matched, of the form: ;; Let's not replace `vars' in `fun' since it's ;; too difficult to do it right, instead just ;; let-bind `vars' around `fun'. - `(let* ,env ,call))))) + `(let* ,env ,call)))))) (defun pcase--eval (exp vars) "Build an expression that will evaluate EXP." diff --git a/lisp/emacs-lisp/radix-tree.el b/lisp/emacs-lisp/radix-tree.el index 6a483a6d498..0905ac608bb 100644 --- a/lisp/emacs-lisp/radix-tree.el +++ b/lisp/emacs-lisp/radix-tree.el @@ -198,9 +198,10 @@ If not found, return nil." (pcase-defmacro radix-tree-leaf (vpat) "Pattern which matches a radix-tree leaf. The pattern VPAT is matched against the leaf's carried value." - ;; FIXME: We'd like to use a negative pattern (not consp), but pcase - ;; doesn't support it. Using `atom' works but generates sub-optimal code. - `(or `(t . ,,vpat) (and (pred atom) ,vpat)))) + ;; We used to use `(pred atom)', but `pcase' doesn't understand that + ;; `atom' is equivalent to the negation of `consp' and hence generates + ;; suboptimal code. + `(or `(t . ,,vpat) (and (pred (not consp)) ,vpat)))) (defun radix-tree-iter-subtrees (tree fun) "Apply FUN to every immediate subtree of radix TREE. diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index 1b06c6e7543..e6f4c097504 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -32,6 +32,10 @@ (should (equal (pcase '(2 . 3) ;bug#18554 (`(,hd . ,(and (pred atom) tl)) (list hd tl)) ((pred consp) nil)) + '(2 3))) + (should (equal (pcase '(2 . 3) + (`(,hd . ,(and (pred (not consp)) tl)) (list hd tl)) + ((pred consp) nil)) '(2 3)))) (pcase-defmacro pcase-tests-plus (pat n) From 25e1b732947bcba51e457a7168eba6608fb666c0 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 16 Jan 2021 10:51:09 -0500 Subject: [PATCH 011/133] * lisp/emacs-lisp/byte-opt.el (byte-optimize-form-code-walker): Use pcase --- lisp/emacs-lisp/byte-opt.el | 319 ++++++++++++++++++------------------ 1 file changed, 159 insertions(+), 160 deletions(-) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index cf89456541e..f29f85b9650 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -374,185 +374,184 @@ ;; the important aspect is that they are subrs that don't evaluate all of ;; their args.) ;; - (let ((fn (car-safe form)) - tmp) - (cond ((not (consp form)) - (if (not (and for-effect - (or byte-compile-delete-errors - (not (symbolp form)) - (eq form t)))) - form)) - ((eq fn 'quote) - (if (cdr (cdr form)) - (byte-compile-warn "malformed quote form: `%s'" - (prin1-to-string form))) - ;; map (quote nil) to nil to simplify optimizer logic. - ;; map quoted constants to nil if for-effect (just because). - (and (nth 1 form) - (not for-effect) - form)) - ((memq fn '(let let*)) - ;; recursively enter the optimizer for the bindings and body - ;; of a let or let*. This for depth-firstness: forms that - ;; are more deeply nested are optimized first. - (cons fn + ;; FIXME: There are a bunch of `byte-compile-warn' here which arguably + ;; have no place in an optimizer: the corresponding tests should be + ;; performed in `macroexpand-all', or in `cconv', or in `bytecomp'. + (let ((fn (car-safe form))) + (pcase form + ((pred (not consp)) + (if (not (and for-effect + (or byte-compile-delete-errors + (not (symbolp form)) + (eq form t)))) + form)) + (`(quote . ,v) + (if (cdr v) + (byte-compile-warn "malformed quote form: `%s'" + (prin1-to-string form))) + ;; Map (quote nil) to nil to simplify optimizer logic. + ;; Map quoted constants to nil if for-effect (just because). + (and (car v) + (not for-effect) + form)) + (`(,(or 'let 'let*) . ,(or `(,bindings . ,exps) pcase--dontcare)) + ;; Recursively enter the optimizer for the bindings and body + ;; of a let or let*. This for depth-firstness: forms that + ;; are more deeply nested are optimized first. + (cons fn (cons (mapcar (lambda (binding) - (if (symbolp binding) - binding - (if (cdr (cdr binding)) - (byte-compile-warn "malformed let binding: `%s'" - (prin1-to-string binding))) - (list (car binding) - (byte-optimize-form (nth 1 binding) nil)))) - (nth 1 form)) - (byte-optimize-body (cdr (cdr form)) for-effect)))) - ((eq fn 'cond) - (cons fn - (mapcar (lambda (clause) - (if (consp clause) - (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)) - clause)) - (cdr form)))) - ((eq fn 'progn) - ;; As an extra added bonus, this simplifies (progn ) --> . - (if (cdr (cdr form)) - (macroexp-progn (byte-optimize-body (cdr form) for-effect)) - (byte-optimize-form (nth 1 form) for-effect))) - ((eq fn 'prog1) - (if (cdr (cdr form)) - (cons 'prog1 - (cons (byte-optimize-form (nth 1 form) for-effect) - (byte-optimize-body (cdr (cdr form)) t))) - (byte-optimize-form (nth 1 form) for-effect))) + (if (symbolp binding) + binding + (if (cdr (cdr binding)) + (byte-compile-warn "malformed let binding: `%s'" + (prin1-to-string binding))) + (list (car binding) + (byte-optimize-form (nth 1 binding) nil)))) + bindings) + (byte-optimize-body exps for-effect)))) + (`(cond . ,clauses) + (cons fn + (mapcar (lambda (clause) + (if (consp clause) + (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)) + clause)) + clauses))) + (`(progn . ,exps) + ;; As an extra added bonus, this simplifies (progn ) --> . + (if (cdr exps) + (macroexp-progn (byte-optimize-body exps for-effect)) + (byte-optimize-form (car exps) for-effect))) + (`(prog1 . ,(or `(,exp . ,exps) pcase--dontcare)) + (if exps + `(prog1 ,(byte-optimize-form exp for-effect) + . ,(byte-optimize-body exps t)) + (byte-optimize-form exp for-effect))) - ((memq fn '(save-excursion save-restriction save-current-buffer)) - ;; those subrs which have an implicit progn; it's not quite good - ;; enough to treat these like normal function calls. - ;; This can turn (save-excursion ...) into (save-excursion) which - ;; will be optimized away in the lap-optimize pass. - (cons fn (byte-optimize-body (cdr form) for-effect))) + (`(,(or `save-excursion `save-restriction `save-current-buffer) . ,exps) + ;; Those subrs which have an implicit progn; it's not quite good + ;; enough to treat these like normal function calls. + ;; This can turn (save-excursion ...) into (save-excursion) which + ;; will be optimized away in the lap-optimize pass. + (cons fn (byte-optimize-body exps for-effect))) - ((eq fn 'if) - (when (< (length form) 3) - (byte-compile-warn "too few arguments for `if'")) - (cons fn - (cons (byte-optimize-form (nth 1 form) nil) - (cons - (byte-optimize-form (nth 2 form) for-effect) - (byte-optimize-body (nthcdr 3 form) for-effect))))) + (`(if ,test ,then . ,else) + `(if ,(byte-optimize-form test nil) + ,(byte-optimize-form then for-effect) + . ,(byte-optimize-body else for-effect))) + (`(if . ,_) + (byte-compile-warn "too few arguments for `if'")) - ((memq fn '(and or)) ; Remember, and/or are control structures. - ;; Take forms off the back until we can't any more. - ;; In the future it could conceivably be a problem that the - ;; subexpressions of these forms are optimized in the reverse - ;; order, but it's ok for now. - (if for-effect - (let ((backwards (reverse (cdr form)))) - (while (and backwards - (null (setcar backwards - (byte-optimize-form (car backwards) - for-effect)))) - (setq backwards (cdr backwards))) - (if (and (cdr form) (null backwards)) - (byte-compile-log - " all subforms of %s called for effect; deleted" form)) - (and backwards - (cons fn (nreverse (mapcar 'byte-optimize-form - backwards))))) - (cons fn (mapcar 'byte-optimize-form (cdr form))))) + (`(,(or 'and 'or) . ,exps) ; Remember, and/or are control structures. + ;; Take forms off the back until we can't any more. + ;; In the future it could conceivably be a problem that the + ;; subexpressions of these forms are optimized in the reverse + ;; order, but it's ok for now. + (if for-effect + (let ((backwards (reverse exps))) + (while (and backwards + (null (setcar backwards + (byte-optimize-form (car backwards) + for-effect)))) + (setq backwards (cdr backwards))) + (if (and exps (null backwards)) + (byte-compile-log + " all subforms of %s called for effect; deleted" form)) + (and backwards + (cons fn (nreverse (mapcar #'byte-optimize-form + backwards))))) + (cons fn (mapcar #'byte-optimize-form exps)))) - ((eq fn 'while) - (unless (consp (cdr form)) - (byte-compile-warn "too few arguments for `while'")) - (cons fn - (cons (byte-optimize-form (cadr form) nil) - (byte-optimize-body (cddr form) t)))) + (`(while ,exp . ,exps) + `(while ,(byte-optimize-form exp nil) + . ,(byte-optimize-body exps t))) + (`(while . ,_) + (byte-compile-warn "too few arguments for `while'")) - ((eq fn 'interactive) - (byte-compile-warn "misplaced interactive spec: `%s'" - (prin1-to-string form)) - nil) + (`(interactive . ,_) + (byte-compile-warn "misplaced interactive spec: `%s'" + (prin1-to-string form)) + nil) - ((eq fn 'function) - ;; This forms is compiled as constant or by breaking out - ;; all the subexpressions and compiling them separately. - form) + (`(function . ,_) + ;; This forms is compiled as constant or by breaking out + ;; all the subexpressions and compiling them separately. + form) - ((eq fn 'condition-case) - `(condition-case ,(nth 1 form) ;Not evaluated. - ,(byte-optimize-form (nth 2 form) for-effect) - ,@(mapcar (lambda (clause) - `(,(car clause) - ,@(byte-optimize-body (cdr clause) for-effect))) - (nthcdr 3 form)))) + (`(condition-case . ,(or `(,var ,exp . ,clauses) pcase--dontcare)) + `(condition-case ,var ;Not evaluated. + ,(byte-optimize-form exp for-effect) + ,@(mapcar (lambda (clause) + `(,(car clause) + ,@(byte-optimize-body (cdr clause) for-effect))) + clauses))) - ((eq fn 'unwind-protect) - ;; the "protected" part of an unwind-protect is compiled (and thus - ;; optimized) as a top-level form, so don't do it here. But the - ;; non-protected part has the same for-effect status as the - ;; unwind-protect itself. (The protected part is always for effect, - ;; but that isn't handled properly yet.) - (cons fn - (cons (byte-optimize-form (nth 1 form) for-effect) - (cdr (cdr form))))) + (`(unwind-protect . ,(or `(,exp . ,exps) pcase--dontcare)) + ;; The "protected" part of an unwind-protect is compiled (and thus + ;; optimized) as a top-level form, so don't do it here. But the + ;; non-protected part has the same for-effect status as the + ;; unwind-protect itself. (The protected part is always for effect, + ;; but that isn't handled properly yet.) + `(unwind-protect ,(byte-optimize-form exp for-effect) . ,exps)) - ((eq fn 'catch) - (cons fn - (cons (byte-optimize-form (nth 1 form) nil) - (byte-optimize-body (cdr form) for-effect)))) + (`(catch . ,(or `(,tag . ,exps) pcase--dontcare)) + `(catch ,(byte-optimize-form tag nil) + . ,(byte-optimize-body exps for-effect))) - ((eq fn 'ignore) - ;; Don't treat the args to `ignore' as being - ;; computed for effect. We want to avoid the warnings - ;; that might occur if they were treated that way. - ;; However, don't actually bother calling `ignore'. - `(prog1 nil . ,(mapcar 'byte-optimize-form (cdr form)))) + (`(ignore . ,exps) + ;; Don't treat the args to `ignore' as being + ;; computed for effect. We want to avoid the warnings + ;; that might occur if they were treated that way. + ;; However, don't actually bother calling `ignore'. + `(prog1 nil . ,(mapcar #'byte-optimize-form exps))) - ;; Needed as long as we run byte-optimize-form after cconv. - ((eq fn 'internal-make-closure) form) + ;; Needed as long as we run byte-optimize-form after cconv. + (`(internal-make-closure . ,_) form) - ((eq (car-safe fn) 'lambda) - (let ((newform (byte-compile-unfold-lambda form))) - (if (eq newform form) - ;; Some error occurred, avoid infinite recursion - form - (byte-optimize-form newform for-effect)))) + (`((lambda . ,_) . ,_) + (let ((newform (byte-compile-unfold-lambda form))) + (if (eq newform form) + ;; Some error occurred, avoid infinite recursion. + form + (byte-optimize-form newform for-effect)))) - ((eq (car-safe fn) 'closure) form) + ;; FIXME: Strictly speaking, I think this is a bug: (closure...) + ;; is a *value* and shouldn't appear in the car. + (`((closure . ,_) . ,_) form) - ((byte-code-function-p fn) - (cons fn (mapcar #'byte-optimize-form (cdr form)))) + (`(,(pred byte-code-function-p) . ,exps) + (cons fn (mapcar #'byte-optimize-form exps))) - ((not (symbolp fn)) - (byte-compile-warn "`%s' is a malformed function" - (prin1-to-string fn)) - form) + (`(,(pred (not symbolp)) . ,_) + (byte-compile-warn "`%s' is a malformed function" + (prin1-to-string fn)) + form) - ((and for-effect (setq tmp (get fn 'side-effect-free)) - (or byte-compile-delete-errors - (eq tmp 'error-free) - (progn - (byte-compile-warn "value returned from %s is unused" - (prin1-to-string form)) - nil))) - (byte-compile-log " %s called for effect; deleted" fn) - ;; appending a nil here might not be necessary, but it can't hurt. - (byte-optimize-form - (cons 'progn (append (cdr form) '(nil))) t)) + ((guard (when for-effect + (if-let ((tmp (get fn 'side-effect-free))) + (or byte-compile-delete-errors + (eq tmp 'error-free) + (progn + (byte-compile-warn "value returned from %s is unused" + (prin1-to-string form)) + nil))))) + (byte-compile-log " %s called for effect; deleted" fn) + ;; appending a nil here might not be necessary, but it can't hurt. + (byte-optimize-form + (cons 'progn (append (cdr form) '(nil))) t)) - (t - ;; Otherwise, no args can be considered to be for-effect, - ;; even if the called function is for-effect, because we - ;; don't know anything about that function. - (let ((form (cons fn (mapcar #'byte-optimize-form (cdr form))))) - (if (get fn 'pure) - (byte-optimize-constant-args form) - form)))))) + (_ + ;; Otherwise, no args can be considered to be for-effect, + ;; even if the called function is for-effect, because we + ;; don't know anything about that function. + (let ((form (cons fn (mapcar #'byte-optimize-form (cdr form))))) + (if (get fn 'pure) + (byte-optimize-constant-args form) + form)))))) (defun byte-optimize-form (form &optional for-effect) "The source-level pass of the optimizer." From 152964362f905ba4f6d60d8c082330b739b8bc8e Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Sun, 17 Jan 2021 11:52:40 +0100 Subject: [PATCH 012/133] Add a bit more clarification around standard error processes. * doc/lispref/processes.texi (Asynchronous Processes): Document how to obtain the standard error process that Emacs creates. (Accepting Output): Add an example how to wait for standard error in case Emacs has created a standard error process. --- doc/lispref/processes.texi | 27 ++++++++++++++++++++++++++- 1 file changed, 26 insertions(+), 1 deletion(-) diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index 535cebed7a8..6dedaa31f2e 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -729,7 +729,9 @@ coding systems (@pxref{Default Coding Systems}). On the other hand, it will use @var{query-flag} as its query-on-exit flag (@pxref{Query Before Exit}). It will be associated with the @var{stderr} buffer (@pxref{Process Buffers}) and send its output (which is the standard -error of the main process) there. +error of the main process) there. To get the process object for the +standard error process, pass the @var{stderr} buffer to +@code{get-buffer-process}. If @var{stderr} is a pipe process, Emacs will use it as standard error process for the new process. @@ -1942,6 +1944,29 @@ code: (while (accept-process-output stderr-process)) @end example +If you passed a buffer to the @var{stderr} argument of +@code{make-process}, you still have to wait for the standard error +process, like so: + +@example +(let* ((stdout (generate-new-buffer "stdout")) + (stderr (generate-new-buffer "stderr")) + (process (make-process :name "test" + :command '("my-program") + :buffer stdout + :stderr stderr)) + (stderr-process (get-buffer-process stderr))) + (unless (and process stderr-process) + (error "Process unexpectedly nil")) + (while (accept-process-output process)) + (while (accept-process-output stderr-process))) +@end example + +@noindent +Only when both @code{accept-process-output} forms return @code{nil}, +you can be sure that the process has exited and Emacs has read all its +output. + Reading pending standard error from a process running on a remote host is not possible this way. From 39a65844e8d67b5ca3bb2d179e899ff99cd85618 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sun, 17 Jan 2021 13:37:58 +0100 Subject: [PATCH 013/133] Add new targets to test/Makefile * test/Makefile.in (SUBDIRS): New variable. (subdir_template): New template. (top) Create new check- targets. * test/README: Document them. * test/infra/gitlab-ci.yml (test-lisp-net-inotify): Rename. --- test/Makefile.in | 20 +++++++++++++------- test/README | 9 ++++----- test/infra/gitlab-ci.yml | 4 ++-- 3 files changed, 19 insertions(+), 14 deletions(-) diff --git a/test/Makefile.in b/test/Makefile.in index 2d595d9bf16..4ca43c8c443 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -246,11 +246,17 @@ endef $(foreach test,${TESTS},$(eval $(call test_template,${test}))) -# Get the tests for only a specific directory -NET_TESTS := $(patsubst %.el,%,$(wildcard lisp/net/*.el)) -LISP_TESTS := $(patsubst %.el,%,$(wildcard lisp/*.el)) -check-net: ${NET_TESTS} -check-lisp: ${LISP_TESTS} +## Get the tests for only a specific directory. +SUBDIRS = $(sort $(shell find lisp src -type d ! -path "*resources*" -print)) + +define subdir_template + .PHONY: check-$(subst /,-,$(1)) + check-$(subst /,-,$(1)): + @${MAKE} check LOGFILES="$(patsubst %.el,%.log, \ + $(patsubst $(srcdir)/%,%,$(wildcard $(1)/*.el)))" +endef + +$(foreach subdir, $(SUBDIRS), $(eval $(call subdir_template,$(subdir)))) ifeq (@HAVE_MODULES@, yes) # -fPIC is a no-op on Windows, but causes a compiler warning @@ -318,10 +324,10 @@ check-doit: ifeq ($(TEST_INTERACTIVE), yes) HOME=$(TEST_HOME) $(emacs) \ -l ert ${ert_opts} \ - $(patsubst %,-l %,$(if $(findstring $(TEST_LOAD_EL),yes),$ELFILES,$(ELFILES:.el=))) \ + $(patsubst %,-l %,$(if $(findstring $(TEST_LOAD_EL),yes),$ELFILES,$(ELFILES:.el=))) \ $(TEST_RUN_ERT) else - -@${MAKE} -k ${LOGFILES} + -@${MAKE} -k ${LOGFILES} @$(emacs) --batch -l ert --eval \ "(ert-summarize-tests-batch-and-exit ${SUMMARIZE_TESTS})" ${LOGFILES} endif diff --git a/test/README b/test/README index 38f4a109701..58f5f38bec6 100644 --- a/test/README +++ b/test/README @@ -39,11 +39,10 @@ The Makefile in this directory supports the following targets: * make check-all Like "make check", but run all tests. -* make check-lisp - Like "make check", but run only the tests in test/lisp/*.el - -* make check-net - Like "make check", but run only the tests in test/lisp/net/*.el +* make check- + Like "make check", but run only the tests in test//*.el. + is a relative directory path, which has replaced "/" by "-", + like in "check-src" or "check-lisp-net". * make -or- make .log Run all tests declared in .el. This includes expensive diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index f9c0e0c11ab..b8d068a8474 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -182,12 +182,12 @@ test-lisp-inotify: target: emacs-inotify make_params: "-C test check-lisp" -test-net-inotify: +test-lisp-net-inotify: stage: normal extends: [.job-template, .test-template] variables: target: emacs-inotify - make_params: "-C test check-net" + make_params: "-C test check-lisp-net" test-filenotify-gio: # This tests file monitor libraries gfilemonitor and gio. From 1773679af3241919a85d6174b1554070a63cca79 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Sun, 17 Jan 2021 14:00:16 +0100 Subject: [PATCH 014/133] Ensure that sentinels are called during 'accept-process-output'. When we're trying to notify a process about a status change, we need to ignore the SIGCHLD pipe temporarily, otherwise the code would likely not run into the timeout case that's necessary for a status change to happen. * src/process.c (wait_reading_process_output): Ignore the SIGCHLD pipe when notifying a process about a status change. * test/src/process-tests.el (process-tests/sentinel-called) (process-tests/sentinel-with-multiple-processes): New unit tests. --- src/process.c | 9 +++++++ test/src/process-tests.el | 53 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 62 insertions(+) diff --git a/src/process.c b/src/process.c index aca87f8ed35..09f87908a45 100644 --- a/src/process.c +++ b/src/process.c @@ -5323,6 +5323,15 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, compute_input_wait_mask (&Atemp); compute_write_mask (&Ctemp); + /* If a process status has changed, the child signal pipe + will likely be readable. We want to ignore it for now, + because otherwise we wouldn't run into a timeout + below. */ + int fd = child_signal_read_fd; + eassert (fd < FD_SETSIZE); + if (0 <= fd) + FD_CLR (fd, &Atemp); + timeout = make_timespec (0, 0); if ((thread_select (pselect, max_desc + 1, &Atemp, diff --git a/test/src/process-tests.el b/test/src/process-tests.el index dad36426a09..d2a98dc19f2 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el @@ -734,5 +734,58 @@ Return nil if that can't be determined." (match-string-no-properties 1)))))) process-tests--EMFILE-message) +(ert-deftest process-tests/sentinel-called () + "Check that sentinels are called after processes finish" + (let ((echo (executable-find "echo"))) + (skip-unless echo) + (dolist (conn-type '(pipe pty)) + (ert-info ((format "Connection type: %s" conn-type)) + (process-tests--with-processes processes + (let* ((calls ()) + (process (make-process + :name "echo" + :command (list echo "first") + :noquery t + :connection-type conn-type + :coding 'utf-8-unix + :sentinel (lambda (process message) + (push (list process message) + calls))))) + (push process processes) + (while (accept-process-output process)) + (should (equal calls + (list (list process "finished\n")))))))))) + +(ert-deftest process-tests/sentinel-with-multiple-processes () + "Check that sentinels are called in time even when other processes +have written output." + (let ((echo (executable-find "echo")) + (bash (executable-find "bash"))) + (skip-unless echo) + (skip-unless bash) + (dolist (conn-type '(pipe pty)) + (ert-info ((format "Connection type: %s" conn-type)) + (process-tests--with-processes processes + (let* ((calls ()) + (process (make-process + :name "echo" + :command (list echo "first") + :noquery t + :connection-type conn-type + :coding 'utf-8-unix + :sentinel (lambda (process message) + (push (list process message) + calls))))) + (push process processes) + (push (make-process + :name "bash" + :command (list bash "-c" "sleep 10 && echo second") + :noquery t + :connection-type conn-type) + processes) + (while (accept-process-output process)) + (should (equal calls + (list (list process "finished\n")))))))))) + (provide 'process-tests) ;;; process-tests.el ends here From 1fe135a024dde56fe904c35f14d6b30add024f5b Mon Sep 17 00:00:00 2001 From: Ted Zlatanov Date: Sun, 17 Jan 2021 13:56:27 +0000 Subject: [PATCH 015/133] * test/infra/gitlab-ci.yml: Merge test-template into job-template. --- test/infra/gitlab-ci.yml | 62 +++++++++++++++++++--------------------- 1 file changed, 30 insertions(+), 32 deletions(-) diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index b8d068a8474..78743d1adb1 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -59,6 +59,30 @@ default: - docker login -u ${CI_REGISTRY_USER} -p ${CI_REGISTRY_PASSWORD} ${CI_REGISTRY} .job-template: + rules: + - changes: + - "**/Makefile.in" + - .gitlab-ci.yml + - aclocal.m4 + - autogen.sh + - configure.ac + - lib/*.{h,c} + - lisp/**/*.el + - src/*.{h,c} + - test/infra/* + - test/lisp/**/*.el + - test/src/*.el + - changes: + # gfilemonitor, kqueue + - src/gfilenotify.c + - src/kqueue.c + # MS Windows + - "**/w32*" + # GNUstep + - lisp/term/ns-win.el + - src/ns*.{h,m} + - src/macfont.{h,m} + when: never # these will be cached across builds cache: key: ${CI_COMMIT_SHA} @@ -103,32 +127,6 @@ default: - test/lisp/autorevert-tests.el - test/lisp/filenotify-tests.el -.test-template: - rules: - - changes: - - "**/Makefile.in" - - .gitlab-ci.yml - - aclocal.m4 - - autogen.sh - - configure.ac - - lib/*.{h,c} - - lisp/**/*.el - - src/*.{h,c} - - test/infra/* - - test/lisp/**/*.el - - test/src/*.el - - changes: - # gfilemonitor, kqueue - - src/gfilenotify.c - - src/kqueue.c - # MS Windows - - "**/w32*" - # GNUstep - - lisp/term/ns-win.el - - src/ns*.{h,m} - - src/macfont.{h,m} - when: never - # using the variables for each job script: - docker pull ${CI_REGISTRY_IMAGE}:${target}-${CI_COMMIT_SHA} @@ -158,7 +156,7 @@ build-image-inotify: test-fast-inotify: stage: fast - extends: [.job-template, .test-template] + extends: [.job-template] variables: target: emacs-inotify make_params: "-C test check" @@ -177,14 +175,14 @@ build-image-gnustep: test-lisp-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] variables: target: emacs-inotify make_params: "-C test check-lisp" test-lisp-net-inotify: stage: normal - extends: [.job-template, .test-template] + extends: [.job-template] variables: target: emacs-inotify make_params: "-C test check-lisp-net" @@ -192,7 +190,7 @@ test-lisp-net-inotify: test-filenotify-gio: # This tests file monitor libraries gfilemonitor and gio. stage: platforms - extends: [.job-template, .test-template, .filenotify-gio-template] + extends: [.job-template, .filenotify-gio-template] variables: target: emacs-filenotify-gio make_params: "-k -C test autorevert-tests filenotify-tests" @@ -200,7 +198,7 @@ test-filenotify-gio: test-gnustep: # This tests the GNUstep build process stage: platforms - extends: [.job-template, .test-template, .gnustep-template] + extends: [.job-template, .gnustep-template] variables: target: emacs-gnustep make_params: install @@ -208,7 +206,7 @@ test-gnustep: test-all-inotify: # This tests also file monitor libraries inotify and inotifywatch. stage: slow - extends: [.job-template, .test-template] + extends: [.job-template] rules: # note there's no "changes" section, so this always runs on a schedule - if: '$CI_PIPELINE_SOURCE == "schedule"' From 372694e7c6b264fb0c8e316d9f0033e0fd22ee7a Mon Sep 17 00:00:00 2001 From: Ted Zlatanov Date: Sun, 17 Jan 2021 13:59:59 +0000 Subject: [PATCH 016/133] ; * test/infra/gitlab-ci.yml: Merge test-template script into job-template. --- test/infra/gitlab-ci.yml | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index 78743d1adb1..3214f01eddb 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -94,6 +94,11 @@ default: paths: [] # - "test/**/*.log" # - "**/*.log" + # using the variables for each job + script: + - docker pull ${CI_REGISTRY_IMAGE}:${target}-${CI_COMMIT_SHA} + # TODO: with make -j4 several of the tests were failing, for example shadowfile-tests, but passed without it + - docker run -i --rm -e EMACS_EMBA_CI=${EMACS_EMBA_CI} ${CI_REGISTRY_IMAGE}:${target}-${CI_COMMIT_SHA} make ${make_params} .build-template: script: @@ -127,12 +132,6 @@ default: - test/lisp/autorevert-tests.el - test/lisp/filenotify-tests.el - # using the variables for each job - script: - - docker pull ${CI_REGISTRY_IMAGE}:${target}-${CI_COMMIT_SHA} - # TODO: with make -j4 several of the tests were failing, for example shadowfile-tests, but passed without it - - docker run -i --rm -e EMACS_EMBA_CI=${EMACS_EMBA_CI} ${CI_REGISTRY_IMAGE}:${target}-${CI_COMMIT_SHA} make ${make_params} - stages: - prep-images - build-images From b215e83a784be1118bb5d729f17597c4f1c62b52 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sun, 17 Jan 2021 16:53:54 +0200 Subject: [PATCH 017/133] Improve support for the Cham script and languages * etc/NEWS: Announce the new 'cham' input method. * etc/HELLO: Fix the order of letters in the Cham greeting. Remove redundant newlines (reported by Ulrich Mueller ). * lisp/language/cham.el ("Cham"): Add input-method entry. * lisp/leim/quail/cham.el: New file. * lisp/international/fontset.el (setup-default-fontset): Add an entry for Cham. --- etc/HELLO | 12 +----------- etc/NEWS | 4 ++++ lisp/international/fontset.el | 1 + lisp/language/cham.el | 1 + 4 files changed, 7 insertions(+), 11 deletions(-) diff --git a/etc/HELLO b/etc/HELLO index 9a1f5d30edd..0cebb2bb7c2 100644 --- a/etc/HELLO +++ b/etc/HELLO @@ -30,22 +30,16 @@ Bengali (বাংলা) নমস্কার Braille ⠓⠑⠇⠇⠕ Burmese (မြန်မာ) မင်္ဂလာပါ C printf ("Hello, world!\n"); -Cham (ꨌꩌ) ꨦꨤꩌ ꨦꨰꨁ - +Cham (ꨌꩌ) ꨦꨤꩌ ꨦꨁꨰ Cherokee (ᏣᎳᎩ ᎦᏬᏂᎯᏍᏗ) ᎣᏏᏲ / ᏏᏲ Comanche /kəˈmæntʃiː/ Haa marʉ́awe - Cree (ᓀᐦᐃᔭᐍᐏᐣ) ᑕᓂᓯ / ᐙᒋᔮ - Czech (čeština) Dobrý den Danish (dansk) Hej / Goddag / Halløj Dutch (Nederlands) Hallo / Dag Efik /ˈɛfɪk/ Mɔkɔm - Egyptian Hieroglyphs (𓂋𓐰𓏤𓈖𓆎𓅓𓏏𓐰𓊖) 𓅓𓊵𓐰𓐷𓏏𓊪𓐸, 𓇍𓇋𓂻𓍘𓇋 - Emacs emacs --no-splash -f view-hello-file - Emoji 👋 English /ˈɪŋɡlɪʃ/ Hello Esperanto Saluton (Eĥoŝanĝo ĉiuĵaŭde) @@ -61,7 +55,6 @@ Hebrew (עִבְרִית) שָׁלוֹם Hungarian (magyar) Szép jó napot! Hindi (हिंदी) नमस्ते / नमस्कार । Inuktitut (ᐃᓄᒃᑎᑐᑦ) ᐊᐃ - Italian (italiano) Ciao / Buon giorno Javanese (ꦧꦱꦗꦮꦶ) console.log("ꦲꦭꦺꦴ"); Kannada (ಕನ್ನಡ) ನಮಸ್ಕಾರ @@ -69,7 +62,6 @@ Khmer (ភាសាខ្មែរ) ជំរាបសួរ Lao (ພາສາລາວ) ສະບາຍດີ / ຂໍໃຫ້ໂຊກດີ Malayalam (മലയാളം) നമസ്കാരം Maldivian (ދިވެހި) އައްސަލާމު ޢަލައިކުމް / ކިހިނެހް؟ - Maltese (il-Malti) Bonġu / Saħħa Mathematics ∀ p ∈ world • hello p □ Mongolian (монгол хэл) Сайн байна уу? @@ -85,7 +77,6 @@ Swedish (svenska) Hej / Goddag / Hallå Tamil (தமிழ்) வணக்கம் Telugu (తెలుగు) నమస్కారం TaiViet (ꪁꪫꪱꪣ ꪼꪕ) ꪅꪰꪙꫂ ꪨꪮꫂ ꪁꪫꪱ / ꪅꪽ ꪨꪷ ꪁꪫꪱ - Thai (ภาษาไทย) สวัสดีครับ / สวัสดีค่ะ Tibetan (བོད་སྐད་) བཀྲ་ཤིས་བདེ་ལེགས༎ Tigrigna (ትግርኛ) ሰላማት @@ -99,7 +90,6 @@ Vietnamese (tiếng Việt) Chào bạn chinese-gb2312Chinese (中文,普通话,汉语) 你好 chinese-big5-1Cantonese (粵語,廣東話) 早晨, 你好 korean-ksc5601Korean (한글) 안녕하세요 / 안녕하십니까 - diff --git a/etc/NEWS b/etc/NEWS index 359d308bf19..d632283e7f3 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -827,6 +827,10 @@ so e.g. like 'C-x 8 [' inserts a left single quotation mark, Added a new Mozhi scheme. The inapplicable ITRANS scheme is now deprecated. Errors in the Inscript method were corrected. +--- +*** New input method 'cham'. +There's also a Cham greeting in 'etc/HELLO'. + ** Ispell +++ diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el index 14e7b89dd1f..8f0f263dcce 100644 --- a/lisp/international/fontset.el +++ b/lisp/international/fontset.el @@ -719,6 +719,7 @@ georgian cherokee canadian-aboriginal + cham ogham runic symbol diff --git a/lisp/language/cham.el b/lisp/language/cham.el index 194574f6a8e..59eaef67bfa 100644 --- a/lisp/language/cham.el +++ b/lisp/language/cham.el @@ -35,6 +35,7 @@ "Cham" '((charset unicode) (coding-system utf-8) (coding-priority utf-8) + (input-method . "cham") (sample-text . "Cham (ꨌꩌ)\tꨦꨤꩌ ꨦꨰꨁ") (documentation . "\ The Cham script is a Brahmic script used to write Cham, From 3b4050154e3f72c06501cd9a5ad83841b92c7bd6 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Mon, 18 Jan 2021 11:38:58 +0100 Subject: [PATCH 018/133] Replace Unix commands with Emacs in process tests. That way, the tests only depend on Emacs, and not on utilities that might not be available during test time. * test/src/process-tests.el (process-tests--eval) (process-tests--emacs-command, process-tests--emacs-binary) (process-tests--dump-file) (process-tests--usable-file-for-reinvoke): New helper functions. (process-tests/sentinel-called) (process-tests/sentinel-with-multiple-processes): Use them. --- test/src/process-tests.el | 80 ++++++++++++++++++++++++++++++++++----- 1 file changed, 71 insertions(+), 9 deletions(-) diff --git a/test/src/process-tests.el b/test/src/process-tests.el index d2a98dc19f2..949f73595b4 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el @@ -736,15 +736,16 @@ Return nil if that can't be determined." (ert-deftest process-tests/sentinel-called () "Check that sentinels are called after processes finish" - (let ((echo (executable-find "echo"))) - (skip-unless echo) + (let ((command (process-tests--emacs-command))) + (skip-unless command) (dolist (conn-type '(pipe pty)) (ert-info ((format "Connection type: %s" conn-type)) (process-tests--with-processes processes (let* ((calls ()) (process (make-process :name "echo" - :command (list echo "first") + :command (process-tests--eval + command '(print "first")) :noquery t :connection-type conn-type :coding 'utf-8-unix @@ -759,17 +760,16 @@ Return nil if that can't be determined." (ert-deftest process-tests/sentinel-with-multiple-processes () "Check that sentinels are called in time even when other processes have written output." - (let ((echo (executable-find "echo")) - (bash (executable-find "bash"))) - (skip-unless echo) - (skip-unless bash) + (let ((command (process-tests--emacs-command))) + (skip-unless command) (dolist (conn-type '(pipe pty)) (ert-info ((format "Connection type: %s" conn-type)) (process-tests--with-processes processes (let* ((calls ()) (process (make-process :name "echo" - :command (list echo "first") + :command (process-tests--eval + command '(print "first")) :noquery t :connection-type conn-type :coding 'utf-8-unix @@ -779,7 +779,9 @@ have written output." (push process processes) (push (make-process :name "bash" - :command (list bash "-c" "sleep 10 && echo second") + :command (process-tests--eval + command + '(progn (sleep-for 10) (print "second"))) :noquery t :connection-type conn-type) processes) @@ -787,5 +789,65 @@ have written output." (should (equal calls (list (list process "finished\n")))))))))) +(defun process-tests--eval (command form) + "Return a command that evaluates FORM in an Emacs subprocess. +COMMAND must be a list returned by +`process-tests--emacs-command'." + (let ((print-gensym t) + (print-circle t) + (print-length nil) + (print-level nil) + (print-escape-control-characters t) + (print-escape-newlines t) + (print-escape-multibyte t) + (print-escape-nonascii t)) + `(,@command "--quick" "--batch" ,(format "--eval=%S" form)))) + +(defun process-tests--emacs-command () + "Return a command to reinvoke the current Emacs instance. +Return nil if that doesn't appear to be possible." + (when-let ((binary (process-tests--emacs-binary)) + (dump (process-tests--dump-file))) + (cons binary + (unless (eq dump :not-needed) + (list (concat "--dump-file=" + (file-name-unquote dump))))))) + +(defun process-tests--emacs-binary () + "Return the filename of the currently running Emacs binary. +Return nil if that can't be determined." + (and (stringp invocation-name) + (not (file-remote-p invocation-name)) + (not (file-name-absolute-p invocation-name)) + (stringp invocation-directory) + (not (file-remote-p invocation-directory)) + (file-name-absolute-p invocation-directory) + (when-let ((file (process-tests--usable-file-for-reinvoke + (expand-file-name invocation-name + invocation-directory)))) + (and (file-executable-p file) file)))) + +(defun process-tests--dump-file () + "Return the filename of the dump file used to start Emacs. +Return nil if that can't be determined. Return `:not-needed' if +Emacs wasn't started with a dump file." + (if-let ((stats (and (fboundp 'pdumper-stats) (pdumper-stats)))) + (when-let ((file (process-tests--usable-file-for-reinvoke + (cdr (assq 'dump-file-name stats))))) + (and (file-readable-p file) file)) + :not-needed)) + +(defun process-tests--usable-file-for-reinvoke (filename) + "Return a version of FILENAME that can be used to reinvoke Emacs. +Return nil if FILENAME doesn't exist." + (when (and (stringp filename) + (not (file-remote-p filename))) + (cl-callf file-truename filename) + (and (stringp filename) + (not (file-remote-p filename)) + (file-name-absolute-p filename) + (file-regular-p filename) + filename))) + (provide 'process-tests) ;;; process-tests.el ends here From 36d33776c21b3765b8a611f09ae7d86417abee8a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Sun, 10 Jan 2021 17:05:18 +0100 Subject: [PATCH 019/133] Avoid macOS NSFilenamesPboardType warning (bug#33035) * src/nsterm.h (NS_USE_NSPasteboardTypeFileURL): New #define. * src/nsterm.m (ns_term_init): ([EmacsView performDragOperation:]): * src/nsselect.m (ns_string_to_symbol): (nxatoms_of_nsselect): NSFilenamesPboardType was deprecated in macOS 10.14; use NSPasteboardTypeFileURL instead when available. --- src/nsselect.m | 15 +++++++++++++-- src/nsterm.h | 9 +++++++++ src/nsterm.m | 21 ++++++++++++++++++--- 3 files changed, 40 insertions(+), 5 deletions(-) diff --git a/src/nsselect.m b/src/nsselect.m index 27db9248e46..5ab3ef77fec 100644 --- a/src/nsselect.m +++ b/src/nsselect.m @@ -78,7 +78,13 @@ Updated by Christian Limpach (chris@nice.ch) return QSECONDARY; if ([t isEqualToString: NSPasteboardTypeString]) return QTEXT; - if ([t isEqualToString: NSFilenamesPboardType]) + if ([t isEqualToString: +#if NS_USE_NSPasteboardTypeFileURL != 0 + NSPasteboardTypeFileURL +#else + NSFilenamesPboardType +#endif + ]) return QFILE_NAME; if ([t isEqualToString: NSPasteboardTypeTabularText]) return QTEXT; @@ -467,7 +473,12 @@ Updated by Christian Limpach (chris@nice.ch) [NSNumber numberWithLong:0], NXPrimaryPboard, [NSNumber numberWithLong:0], NXSecondaryPboard, [NSNumber numberWithLong:0], NSPasteboardTypeString, - [NSNumber numberWithLong:0], NSFilenamesPboardType, + [NSNumber numberWithLong:0], +#if NS_USE_NSPasteboardTypeFileURL != 0 + NSPasteboardTypeFileURL, +#else + NSFilenamesPboardType, +#endif [NSNumber numberWithLong:0], NSPasteboardTypeTabularText, nil] retain]; } diff --git a/src/nsterm.h b/src/nsterm.h index 2c9d8e85ba9..eae1d0725ea 100644 --- a/src/nsterm.h +++ b/src/nsterm.h @@ -39,6 +39,15 @@ typedef CGFloat EmacsCGFloat; typedef float EmacsCGFloat; #endif +/* NSFilenamesPboardType is deprecated in macOS 10.14, but + NSPasteboardTypeFileURL is only available in 10.13 (and GNUstep + probably lacks it too). */ +#if defined NS_IMPL_COCOA && MAC_OS_X_VERSION_MIN_REQUIRED >= 101300 +#define NS_USE_NSPasteboardTypeFileURL 1 +#else +#define NS_USE_NSPasteboardTypeFileURL 0 +#endif + /* ========================================================================== Trace support diff --git a/src/nsterm.m b/src/nsterm.m index 2defb9e2eec..c5815ce8d10 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -5602,7 +5602,11 @@ Needs to be here because ns_initialize_display_info () uses AppKit classes. ns_drag_types = [[NSArray arrayWithObjects: NSPasteboardTypeString, NSPasteboardTypeTabularText, +#if NS_USE_NSPasteboardTypeFileURL != 0 + NSPasteboardTypeFileURL, +#else NSFilenamesPboardType, +#endif NSPasteboardTypeURL, nil] retain]; /* If fullscreen is in init/default-frame-alist, focus isn't set @@ -8533,9 +8537,19 @@ -(BOOL)performDragOperation: (id ) sender { return NO; } - /* FIXME: NSFilenamesPboardType is deprecated in 10.14, but the - NSURL method can only handle one file at a time. Stick with the - existing code at the moment. */ +#if NS_USE_NSPasteboardTypeFileURL != 0 + else if ([type isEqualToString: NSPasteboardTypeFileURL]) + { + type_sym = Qfile; + + NSArray *urls = [pb readObjectsForClasses: @[[NSURL self]] + options: nil]; + NSEnumerator *uenum = [urls objectEnumerator]; + NSURL *url; + while ((url = [uenum nextObject])) + strings = Fcons ([[url path] lispString], strings); + } +#else // !NS_USE_NSPasteboardTypeFileURL else if ([type isEqualToString: NSFilenamesPboardType]) { NSArray *files; @@ -8551,6 +8565,7 @@ -(BOOL)performDragOperation: (id ) sender while ( (file = [fenum nextObject]) ) strings = Fcons ([file lispString], strings); } +#endif // !NS_USE_NSPasteboardTypeFileURL else if ([type isEqualToString: NSPasteboardTypeURL]) { NSURL *url = [NSURL URLFromPasteboard: pb]; From 455f08c095c5c1606142144508fc91eab0860a6a Mon Sep 17 00:00:00 2001 From: Stephen Berman Date: Mon, 18 Jan 2021 17:29:41 +0100 Subject: [PATCH 020/133] Fix problem with `epa-list-keys' bugging out * lisp/epa.el (epa--list-keys): Partially revert 517285f7cae which removed the wrong property (bug#44134). --- lisp/epa.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/epa.el b/lisp/epa.el index db2b1271473..e909b1d8698 100644 --- a/lisp/epa.el +++ b/lisp/epa.el @@ -359,8 +359,8 @@ DOC is documentation text to insert at the start." ;; Find the end of the documentation text at the start. ;; Set POINT to where it ends, or nil if ends at eob. - (unless (get-text-property point 'epa-list-keys) - (setq point (next-single-property-change point 'epa-list-keys))) + (unless (get-text-property point 'epa-key) + (setq point (next-single-property-change point 'epa-key))) ;; If caller specified documentation text for that, replace the old ;; documentation text (if any) with what was specified. @@ -374,7 +374,7 @@ DOC is documentation text to insert at the start." ;; Now delete the key description text, if any. (when point (delete-region point - (or (next-single-property-change point 'epa-list-keys) + (or (next-single-property-change point 'epa-key) (point-max))) (goto-char point)) From f9dab612726148919812ec4ff804df6120022407 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Mon, 18 Jan 2021 17:35:55 +0100 Subject: [PATCH 021/133] Don't double up keys in epa--list-keys * lisp/epa.el (epa--list-keys): Delete the list keys before redisplaying (bug#44134). --- lisp/epa.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/epa.el b/lisp/epa.el index e909b1d8698..197cd92f977 100644 --- a/lisp/epa.el +++ b/lisp/epa.el @@ -374,7 +374,7 @@ DOC is documentation text to insert at the start." ;; Now delete the key description text, if any. (when point (delete-region point - (or (next-single-property-change point 'epa-key) + (or (next-single-property-change point 'epa-list-keys) (point-max))) (goto-char point)) From c4be126c42600990375720511326c5ab8fb22a84 Mon Sep 17 00:00:00 2001 From: Aaron Jensen Date: Sat, 16 Jan 2021 12:28:46 -0600 Subject: [PATCH 022/133] * test/src/xdisp-tests.el: Fix tests to work in batch mode (xdisp-tests--window-text-pixel-size) (xdisp-tests--window-text-pixel-size-leading-space) (xdisp-tests--window-text-pixel-size-trailing-space): Fix tests. (Bug#45748) --- test/src/xdisp-tests.el | 33 +++++++++++++++------------------ 1 file changed, 15 insertions(+), 18 deletions(-) diff --git a/test/src/xdisp-tests.el b/test/src/xdisp-tests.el index ec96d777ffb..4e7d2ad8ab2 100644 --- a/test/src/xdisp-tests.el +++ b/test/src/xdisp-tests.el @@ -75,31 +75,28 @@ (ert-deftest xdisp-tests--window-text-pixel-size () ;; bug#45748 (with-temp-buffer (insert "xxx") - (let* ((window - (display-buffer (current-buffer) '(display-buffer-in-child-frame . nil))) - (char-width (frame-char-width)) - (size (window-text-pixel-size nil t t))) - (delete-frame (window-frame window)) - (should (equal (/ (car size) char-width) 3))))) + (switch-to-buffer (current-buffer)) + (let* ((char-width (frame-char-width)) + (size (window-text-pixel-size nil t t)) + (width-in-chars (/ (car size) char-width))) + (should (equal width-in-chars 3))))) (ert-deftest xdisp-tests--window-text-pixel-size-leading-space () ;; bug#45748 (with-temp-buffer (insert " xx") - (let* ((window - (display-buffer (current-buffer) '(display-buffer-in-child-frame . nil))) - (char-width (frame-char-width)) - (size (window-text-pixel-size nil t t))) - (delete-frame (window-frame window)) - (should (equal (/ (car size) char-width) 3))))) + (switch-to-buffer (current-buffer)) + (let* ((char-width (frame-char-width)) + (size (window-text-pixel-size nil t t)) + (width-in-chars (/ (car size) char-width))) + (should (equal width-in-chars 3))))) (ert-deftest xdisp-tests--window-text-pixel-size-trailing-space () ;; bug#45748 (with-temp-buffer (insert "xx ") - (let* ((window - (display-buffer (current-buffer) '(display-buffer-in-child-frame . nil))) - (char-width (frame-char-width)) - (size (window-text-pixel-size nil t t))) - (delete-frame (window-frame window)) - (should (equal (/ (car size) char-width) 3))))) + (switch-to-buffer (current-buffer)) + (let* ((char-width (frame-char-width)) + (size (window-text-pixel-size nil t t)) + (width-in-chars (/ (car size) char-width))) + (should (equal width-in-chars 3))))) ;;; xdisp-tests.el ends here From b2e6ed40268e7339be501b3481774773179ca476 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Mon, 18 Jan 2021 19:17:59 +0200 Subject: [PATCH 023/133] Fix recent changes for Cham script * lisp/language/cham.el ("Cham"): Fix sample-text. * lisp/leim/quail/cham.el: Really install this new file. --- lisp/language/cham.el | 2 +- lisp/leim/quail/cham.el | 116 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 117 insertions(+), 1 deletion(-) create mode 100644 lisp/leim/quail/cham.el diff --git a/lisp/language/cham.el b/lisp/language/cham.el index 59eaef67bfa..089988da918 100644 --- a/lisp/language/cham.el +++ b/lisp/language/cham.el @@ -36,7 +36,7 @@ (coding-system utf-8) (coding-priority utf-8) (input-method . "cham") - (sample-text . "Cham (ꨌꩌ)\tꨦꨤꩌ ꨦꨰꨁ") + (sample-text . "Cham (ꨌꩌ)\tꨦꨤꩌ ꨦꨁꨰ") (documentation . "\ The Cham script is a Brahmic script used to write Cham, an Austronesian language spoken by some 245,000 Chams diff --git a/lisp/leim/quail/cham.el b/lisp/leim/quail/cham.el new file mode 100644 index 00000000000..d12ae6cddf0 --- /dev/null +++ b/lisp/leim/quail/cham.el @@ -0,0 +1,116 @@ +;;; cham.el --- Quail package for inputting Cham characters -*- coding: utf-8; lexical-binding:t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Author: Eli Zaretskii +;; Keywords: i18n + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This file defines the following Cham keyboards: +;; +;; - QWERTY-based Cham. + +;;; Code: + +(require 'quail) + +(quail-define-package + "cham" "Cham" "ꨌꩌ" t + "A QWERTY-based Cham input method." + nil t nil nil t nil nil nil nil nil t) + +(quail-define-rules + ("a" ?ꨀ) + ("A" ?ꨄ) + ("i" ?ꨁ) + ("u" ?ꨂ) + ("e" ?ꨃ) + ("o" ?ꨅ) + ("k" ?ꨆ) + ("K" ?ꨇ) + ("g" ?ꨈ) + ("G" ?ꨉ) + ("q" ?ꨊ) + ("Q" ?ꨋ) + ("c" ?ꨌ) + ("C" ?ꨍ) + ("j" ?ꨎ) + ("J" ?ꨏ) + ("z" ?ꨐ) + ("Z" ?ꨑ) + ("zz" ?ꨒ) + ("t" ?ꨓ) + ("T" ?ꨔ) + ("d" ?ꨕ) + ("D" ?ꨖ) + ("n" ?ꨗ) + ("N" ?ꨘ) + ("p" ?ꨚ) + ("P" ?ꨛ) + ("f" ?ꨜ) + ("b" ?ꨝ) + ("B" ?ꨞ) + ("m" ?ꨟ) + ("M" ?ꨠ) + ("mm" ?ꨡ) + ("y" ?ꨢ) + ("r" ?ꨣ) + ("l" ?ꨤ) + ("w" ?ꨥ) + ("v" ?ꨥ) + ("x" ?ꨦ) + ("s" ?ꨧ) + ("h" ?ꨨ) + ("kk" ?ꩀ) + ("ww" ?ꩁ) + ("vv" ?ꩁ) + ("qq" ?ꩂ) + ("cc" ?ꩄ) + ("tt" ?ꩅ) + ("nn" ?ꩆ) + ("pp" ?ꩇ) + ("yy" ?ꩈ) + ("rr" ?ꩉ) + ("ll" ?ꩊ) + ("gg" ?ꩊ) + ("xx" ?ꩋ) + ("." ?ꩌ) + ("H" ?ꩍ) + ("0" ?꩐) + ("1" ?꩑) + ("2" ?꩒) + ("3" ?꩓) + ("4" ?꩔) + ("5" ?꩕) + ("6" ?꩖) + ("7" ?꩗) + ("8" ?꩘) + ("9" ?꩙) + ("!" ?ꨩ) + ("#" ?ꨪ) + ("$" ?ꨫ) + ("^" ?ꨬ) + ("&" ?ꨮ) + ("`" ?꩜) + ("=" ?ꨱ) + ("-" ?ꩃ) + ("~" ?꩟) + ) + +;;; cham.el ends here From 92144027915bc2fc9c222d87a8e2e5da3df46c82 Mon Sep 17 00:00:00 2001 From: Eric Ludlam Date: Mon, 18 Jan 2021 12:49:11 -0500 Subject: [PATCH 024/133] * lisp/cedet/ede/proj.el: Enable Project files to load (ede-proj-target-makefile): Give more precise type for its `rules` slot. * lisp/cedet/ede/base.el (ede-target-list): Don't define. (ede-project): Use `list-of` instead. --- lisp/cedet/ede/base.el | 5 +---- lisp/cedet/ede/proj.el | 2 +- 2 files changed, 2 insertions(+), 5 deletions(-) diff --git a/lisp/cedet/ede/base.el b/lisp/cedet/ede/base.el index 7799746e0c4..810d6ef3bd4 100644 --- a/lisp/cedet/ede/base.el +++ b/lisp/cedet/ede/base.el @@ -160,16 +160,13 @@ and querying them will cause the actual project to get loaded.") ;; Projects can also affect how EDE works, by changing what appears in ;; the EDE menu, or how some keys are bound. ;; -(unless (fboundp 'ede-target-list-p) - (cl-deftype ede-target-list () '(list-of ede-target))) - (defclass ede-project (ede-project-placeholder) ((subproj :initform nil :type list :documentation "Sub projects controlled by this project. For Automake based projects, each directory is treated as a project.") (targets :initarg :targets - :type ede-target-list + :type (list-of ede-target) :custom (repeat (object :objectcreatefcn ede-new-target-custom)) :label "Local Targets" :group (targets) diff --git a/lisp/cedet/ede/proj.el b/lisp/cedet/ede/proj.el index 59628ebf4c9..4af8b4104f5 100644 --- a/lisp/cedet/ede/proj.el +++ b/lisp/cedet/ede/proj.el @@ -184,7 +184,7 @@ Target variables are always renamed such as foo_CFLAGS, then included into commands where the variable would usually appear.") (rules :initarg :rules :initform nil - :type list + :type (list-of ede-makefile-rule) :custom (repeat (object :objecttype ede-makefile-rule)) :label "Additional Rules" :group (make) From bdb9889f784dc6113a74c259a53cf0623e49ab2d Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Sun, 17 Jan 2021 18:56:50 +0000 Subject: [PATCH 025/133] Use format-prompt in read-regexp. * lisp/replace.el (read-regexp): Use format-prompt (bug#12443). --- lisp/replace.el | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/lisp/replace.el b/lisp/replace.el index d41dc98a0d9..8f8cbfac542 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -866,13 +866,10 @@ If nil, uses `regexp-history'." ;; Do not automatically add default to the history for empty input. (history-add-new-input nil) (input (read-from-minibuffer - (cond ((string-match-p ":[ \t]*\\'" prompt) - prompt) - ((and default (> (length default) 0)) - (format "%s (default %s): " prompt - (query-replace-descr default))) - (t - (format "%s: " prompt))) + (if (string-match-p ":[ \t]*\\'" prompt) + prompt + (format-prompt prompt (and (length> default 0) + (query-replace-descr default)))) nil nil nil (or history 'regexp-history) suggestions t))) (if (equal input "") ;; Return the default value when the user enters empty input. From 8f4b3b812aab62a5a205bc2f8690c3b4c460ba09 Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Sun, 17 Jan 2021 15:53:53 +0000 Subject: [PATCH 026/133] Fix ibuffer-mark-by-file-name-regexp abbreviations * lisp/ibuffer.el (ibuffer--abbreviate-file-name): New function. (filename): Use it. * lisp/ibuf-ext.el (ibuffer-mark-by-file-name-regexp): Prefer read-regexp over read-string for reading regexps. Determine file name using ibuffer-buffer-file-name for consistency. Abbreviate file name using ibuffer-directory-abbrev-alist (bug#18859). --- lisp/ibuf-ext.el | 16 +++++----------- lisp/ibuffer.el | 9 ++++++--- 2 files changed, 11 insertions(+), 14 deletions(-) diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el index 7be1b3d16c9..ed5c9c02115 100644 --- a/lisp/ibuf-ext.el +++ b/lisp/ibuf-ext.el @@ -1823,18 +1823,12 @@ When BUF nil, default to the buffer at current line." ;;;###autoload (defun ibuffer-mark-by-file-name-regexp (regexp) "Mark all buffers whose file name matches REGEXP." - (interactive "sMark by file name (regexp): ") + (interactive (list (read-regexp "Mark by file name (regexp)"))) (ibuffer-mark-on-buffer - #'(lambda (buf) - (let ((name (or (buffer-file-name buf) - (with-current-buffer buf - (and - (boundp 'dired-directory) - (stringp dired-directory) - dired-directory))))) - (when name - ;; Match on the displayed file name (which is abbreviated). - (string-match regexp (abbreviate-file-name name))))))) + (lambda (buf) + (when-let ((name (with-current-buffer buf (ibuffer-buffer-file-name)))) + ;; Match on the displayed file name (which is abbreviated). + (string-match-p regexp (ibuffer--abbreviate-file-name name)))))) ;;;###autoload (defun ibuffer-mark-by-content-regexp (regexp &optional all-buffers) diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el index 4800e0243d7..84c53b16acf 100644 --- a/lisp/ibuffer.el +++ b/lisp/ibuffer.el @@ -1308,6 +1308,11 @@ a new window in the current frame, splitting vertically." (car dired-directory))))) (and dirname (expand-file-name dirname)))))) +(defun ibuffer--abbreviate-file-name (filename) + "Abbreviate FILENAME using `ibuffer-directory-abbrev-alist'." + (let ((directory-abbrev-alist ibuffer-directory-abbrev-alist)) + (abbreviate-file-name filename))) + (define-ibuffer-op ibuffer-do-save () "Save marked buffers as with `save-buffer'." (:complex t @@ -1885,9 +1890,7 @@ If point is on a group name, this function operates on that group." (cond ((zerop total) "No files") ((= 1 total) "1 file") (t (format "%d files" total)))))) - (let ((directory-abbrev-alist ibuffer-directory-abbrev-alist)) - (abbreviate-file-name - (or (ibuffer-buffer-file-name) "")))) + (ibuffer--abbreviate-file-name (or (ibuffer-buffer-file-name) ""))) (define-ibuffer-column filename-and-process (:name "Filename/Process" From 20add1cd22f9775a4475148b300cf2a4de4bd54a Mon Sep 17 00:00:00 2001 From: Eric Abrahamsen Date: Tue, 17 Mar 2020 20:53:05 -0700 Subject: [PATCH 027/133] Allow gnus-retrieve-headers to return headers directly Previously, all Gnus backends returned header information by writing nov lines into the nntp-server-buffer, which was later parsed. This commit allows the backends to return their header information as a list of already-parsed headers, though so far none of the backends actually do that. The agent, cache, cloud etc. now operate on parsed headers rather than nov text, ie. they use gnus-fetch-headers instead of gnus-retrieve-headers. * lisp/gnus/gnus-sum.el (gnus-fetch-headers): Handle the case in which gnus-retrieve-headers returns headers directly. * lisp/gnus/nnvirtual.el (nnvirtual-retrieve-headers): Use gnus-fetch-headers rather than gnus-retrieve-headers to get headers, meaning we're operating on already-parsed headers. (nnvirtual-convert-headers): Remove now-unnecessary function. (nnvirtual-update-xref-header): Rewrite to operate on parsed header. * lisp/gnus/gnus-cloud.el (gnus-cloud-available-chunks): Use gnus-fetch-headers instead of gnus-retrieve-headers. * lisp/gnus/gnus-cache.el (gnus-cache-retrieve-headers): Use gnus-fetch-headers. (gnus-cache-braid-nov, gnus-cache-braid-heads): Delete unnecessary functions -- we now do this work on a list of parsed headers. * lisp/gnus/gnus-agent.el (gnus-agent-retrieve-headers): Use gnus-fetch-headers. (gnus-agent-braid-nov): Remove unnecessary function. (gnus-agent-fetch-headers): Use gnus-fetch-headers. --- lisp/gnus/gnus-agent.el | 373 +++++++++++++--------------------------- lisp/gnus/gnus-async.el | 9 +- lisp/gnus/gnus-cache.el | 126 ++++---------- lisp/gnus/gnus-cloud.el | 16 +- lisp/gnus/gnus-sum.el | 65 +++++-- lisp/gnus/gnus.el | 9 +- lisp/gnus/nnvirtual.el | 170 +++++------------- lisp/obsolete/nnir.el | 1 - 8 files changed, 258 insertions(+), 511 deletions(-) diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index 56640ea8302..686623029ed 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -1789,6 +1789,7 @@ variables. Returns the first non-nil value found." . gnus-agent-enable-expiration) (agent-predicate . gnus-agent-predicate))))))) +;; FIXME: This looks an awful lot like `gnus-agent-retrieve-headers'. (defun gnus-agent-fetch-headers (group) "Fetch interesting headers into the agent. The group's overview file will be updated to include the headers while a list of available @@ -1810,10 +1811,9 @@ article numbers will be returned." (cdr active)))) (gnus-uncompress-range (gnus-active group))) (gnus-list-of-unread-articles group))) - (gnus-decode-encoded-word-function 'identity) - (gnus-decode-encoded-address-function 'identity) (file (gnus-agent-article-name ".overview" group)) - (file-name-coding-system nnmail-pathname-coding-system)) + (file-name-coding-system nnmail-pathname-coding-system) + headers fetched-headers) (unless fetch-all ;; Add articles with marks to the list of article headers we want to @@ -1824,7 +1824,7 @@ article numbers will be returned." (dolist (arts (gnus-info-marks (gnus-get-info group))) (unless (memq (car arts) '(seen recent killed cache)) (setq articles (gnus-range-add articles (cdr arts))))) - (setq articles (sort (gnus-uncompress-sequence articles) '<))) + (setq articles (sort (gnus-uncompress-range articles) '<))) ;; At this point, I have the list of articles to consider for ;; fetching. This is the list that I'll return to my caller. Some @@ -1867,38 +1867,52 @@ article numbers will be returned." 10 "gnus-agent-fetch-headers: undownloaded articles are `%s'" (gnus-compress-sequence articles t))) - (with-current-buffer nntp-server-buffer - (if articles - (progn - (gnus-message 8 "Fetching headers for %s..." group) + ;; Parse known headers from FILE. + (if (file-exists-p file) + (with-current-buffer gnus-agent-overview-buffer + (erase-buffer) + (let ((nnheader-file-coding-system + gnus-agent-file-coding-system)) + (nnheader-insert-nov-file file (car articles)) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (insert-buffer-substring gnus-agent-overview-buffer) + (setq headers + (gnus-get-newsgroup-headers-xover + articles nil (buffer-local-value + 'gnus-newsgroup-dependencies + gnus-summary-buffer) + gnus-newsgroup-name))))) + (gnus-make-directory (nnheader-translate-file-chars + (file-name-directory file) t))) - ;; Fetch them. - (gnus-make-directory (nnheader-translate-file-chars - (file-name-directory file) t)) + ;; Fetch our new headers. + (gnus-message 8 "Fetching headers for %s..." group) + (if articles + (setq fetched-headers (gnus-fetch-headers articles))) - (unless (eq 'nov (gnus-retrieve-headers articles group)) - (nnvirtual-convert-headers)) - (gnus-agent-check-overview-buffer) - ;; Move these headers to the overview buffer so that - ;; gnus-agent-braid-nov can merge them with the contents - ;; of FILE. - (copy-to-buffer - gnus-agent-overview-buffer (point-min) (point-max)) - ;; NOTE: Call g-a-brand-nov even when the file does not - ;; exist. As a minimum, it will validate the article - ;; numbers already in the buffer. - (gnus-agent-braid-nov articles file) - (let ((coding-system-for-write - gnus-agent-file-coding-system)) - (gnus-agent-check-overview-buffer) - (write-region (point-min) (point-max) file nil 'silent)) - (gnus-agent-update-view-total-fetched-for group t) - (gnus-agent-save-alist group articles nil) - articles) - (ignore-errors - (erase-buffer) - (nnheader-insert-file-contents file))))) - articles)) + ;; Merge two sets of headers. + (setq headers + (if (and headers fetched-headers) + (delete-dups + (sort (append headers (copy-sequence fetched-headers)) + (lambda (l r) + (< (mail-header-number l) + (mail-header-number r))))) + (or headers fetched-headers))) + + ;; Save the new set of headers to FILE. + (let ((coding-system-for-write + gnus-agent-file-coding-system)) + (with-current-buffer gnus-agent-overview-buffer + (goto-char (point-max)) + (mapc #'nnheader-insert-nov fetched-headers) + (sort-numeric-fields 1 (point-min) (point-max)) + (gnus-agent-check-overview-buffer) + (write-region (point-min) (point-max) file nil 'silent)) + (gnus-agent-update-view-total-fetched-for group t) + (gnus-agent-save-alist group articles nil))) + headers)) (defsubst gnus-agent-read-article-number () "Read the article number at point. @@ -1924,96 +1938,6 @@ Return nil when a valid article number can not be read." (set-buffer nntp-server-buffer) (insert-buffer-substring gnus-agent-overview-buffer b e)))) -(defun gnus-agent-braid-nov (articles file) - "Merge agent overview data with given file. -Takes unvalidated headers for ARTICLES from -`gnus-agent-overview-buffer' and validated headers from the given -FILE and places the combined valid headers into -`nntp-server-buffer'. This function can be used, when file -doesn't exist, to valid the overview buffer." - (let (start last) - (set-buffer gnus-agent-overview-buffer) - (goto-char (point-min)) - (set-buffer nntp-server-buffer) - (erase-buffer) - (when (file-exists-p file) - (nnheader-insert-file-contents file)) - (goto-char (point-max)) - (forward-line -1) - - (unless (or (= (point-min) (point-max)) - (< (setq last (read (current-buffer))) (car articles))) - ;; Old and new overlap -- We do it the hard way. - (when (nnheader-find-nov-line (car articles)) - ;; Replacing existing NOV entry - (delete-region (point) (progn (forward-line 1) (point)))) - (gnus-agent-copy-nov-line (pop articles)) - - (ignore-errors - (while articles - (while (let ((art (read (current-buffer)))) - (cond ((< art (car articles)) - (forward-line 1) - t) - ((= art (car articles)) - (beginning-of-line) - (delete-region - (point) (progn (forward-line 1) (point))) - nil) - (t - (beginning-of-line) - nil)))) - - (gnus-agent-copy-nov-line (pop articles))))) - - (goto-char (point-max)) - - ;; Append the remaining lines - (when articles - (when last - (set-buffer gnus-agent-overview-buffer) - (setq start (point)) - (set-buffer nntp-server-buffer)) - - (let ((p (point))) - (insert-buffer-substring gnus-agent-overview-buffer start) - (goto-char p)) - - (setq last (or last -134217728)) - (while (catch 'problems - (let (sort art) - (while (not (eobp)) - (setq art (gnus-agent-read-article-number)) - (cond ((not art) - ;; Bad art num - delete this line - (beginning-of-line) - (delete-region (point) (progn (forward-line 1) (point)))) - ((< art last) - ;; Art num out of order - enable sort - (setq sort t) - (forward-line 1)) - ((= art last) - ;; Bad repeat of art number - delete this line - (beginning-of-line) - (delete-region (point) (progn (forward-line 1) (point)))) - (t - ;; Good art num - (setq last art) - (forward-line 1)))) - (when sort - ;; something is seriously wrong as we simply shouldn't see out-of-order data. - ;; First, we'll fix the sort. - (sort-numeric-fields 1 (point-min) (point-max)) - - ;; but now we have to consider that we may have duplicate rows... - ;; so reset to beginning of file - (goto-char (point-min)) - (setq last -134217728) - - ;; and throw a code that restarts this scan - (throw 'problems t)) - nil)))))) - ;; Keeps the compiler from warning about the free variable in ;; gnus-agent-read-agentview. (defvar gnus-agent-read-agentview) @@ -2386,10 +2310,9 @@ modified) original contents, they are first saved to their own file." (gnus-orphan-score gnus-orphan-score) ;; Maybe some other gnus-summary local variables should also ;; be put here. - + fetched-headers gnus-headers gnus-score - articles predicate info marks ) (unless (gnus-check-group group) @@ -2410,38 +2333,35 @@ modified) original contents, they are first saved to their own file." (setq info (gnus-get-info group))))))) (when arts (setq marked-articles (nconc (gnus-uncompress-range arts) - marked-articles)) - )))) + marked-articles)))))) (setq marked-articles (sort marked-articles '<)) - ;; Fetch any new articles from the server - (setq articles (gnus-agent-fetch-headers group)) + (setq gnus-newsgroup-dependencies + (or gnus-newsgroup-dependencies + (gnus-make-hashtable))) - ;; Merge new articles with marked - (setq articles (sort (append marked-articles articles) '<)) + ;; Fetch headers for any new articles from the server. + (setq fetched-headers (gnus-agent-fetch-headers group)) - (when articles - ;; Parse them and see which articles we want to fetch. - (setq gnus-newsgroup-dependencies - (or gnus-newsgroup-dependencies - (gnus-make-hashtable (length articles)))) + (when fetched-headers (setq gnus-newsgroup-headers - (or gnus-newsgroup-headers - (gnus-get-newsgroup-headers-xover articles nil nil - group))) - ;; `gnus-agent-overview-buffer' may be killed for - ;; timeout reason. If so, recreate it. + (or gnus-newsgroup-headers + fetched-headers))) + (when marked-articles + ;; `gnus-agent-overview-buffer' may be killed for timeout + ;; reason. If so, recreate it. (gnus-agent-create-buffer) (setq predicate - (gnus-get-predicate - (gnus-agent-find-parameter group 'agent-predicate))) + (gnus-get-predicate + (gnus-agent-find-parameter group 'agent-predicate))) + + ;; If the selection predicate requires scoring, score each header. - ;; If the selection predicate requires scoring, score each header (unless (memq predicate '(gnus-agent-true gnus-agent-false)) (let ((score-param (gnus-agent-find-parameter group 'agent-score-file))) - ;; Translate score-param into real one + ;; Translate score-param into real one. (cond ((not score-param)) ((eq score-param 'file) @@ -3661,11 +3581,9 @@ has been fetched." (defun gnus-agent-retrieve-headers (articles group &optional fetch-old) (save-excursion (gnus-agent-create-buffer) - (let ((gnus-decode-encoded-word-function 'identity) - (gnus-decode-encoded-address-function 'identity) - (file (gnus-agent-article-name ".overview" group)) - uncached-articles - (file-name-coding-system nnmail-pathname-coding-system)) + (let ((file (gnus-agent-article-name ".overview" group)) + (file-name-coding-system nnmail-pathname-coding-system) + uncached-articles headers fetched-headers) (gnus-make-directory (nnheader-translate-file-chars (file-name-directory file) t)) @@ -3676,122 +3594,63 @@ has been fetched." 1) (car (last articles)))))) - ;; Populate temp buffer with known headers + ;; See if we've got cached headers for ARTICLES and put them in + ;; HEADERS. Articles with no cached headers go in + ;; UNCACHED-ARTICLES to be fetched from the server. (when (file-exists-p file) (with-current-buffer gnus-agent-overview-buffer (erase-buffer) (let ((nnheader-file-coding-system gnus-agent-file-coding-system)) - (nnheader-insert-nov-file file (car articles))))) + (nnheader-insert-nov-file file (car articles)) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (insert-buffer-substring gnus-agent-overview-buffer) + (setq headers + (gnus-get-newsgroup-headers-xover + articles nil (buffer-local-value + 'gnus-newsgroup-dependencies + gnus-summary-buffer) + gnus-newsgroup-name)))))) - (if (setq uncached-articles (gnus-agent-uncached-articles articles group - t)) - (progn - ;; Populate nntp-server-buffer with uncached headers - (set-buffer nntp-server-buffer) - (erase-buffer) - (cond ((not (eq 'nov (let (gnus-agent) ; Turn off agent - (gnus-retrieve-headers - uncached-articles group)))) - (nnvirtual-convert-headers)) - ((eq 'nntp (car gnus-current-select-method)) - ;; The author of gnus-get-newsgroup-headers-xover - ;; reports that the XOVER command is commonly - ;; unreliable. The problem is that recently - ;; posted articles may not be entered into the - ;; NOV database in time to respond to my XOVER - ;; query. - ;; - ;; I'm going to use his assumption that the NOV - ;; database is updated in order of ascending - ;; article ID. Therefore, a response containing - ;; article ID N implies that all articles from 1 - ;; to N-1 are up-to-date. Therefore, missing - ;; articles in that range have expired. + (setq uncached-articles + (gnus-agent-uncached-articles articles group t)) - (set-buffer nntp-server-buffer) - (let* ((fetched-articles (list nil)) - (tail-fetched-articles fetched-articles) - (min (car articles)) - (max (car (last articles)))) + (when uncached-articles + (let ((gnus-newsgroup-name group) + gnus-agent) ; Prevent loop. + ;; Fetch additional headers for the uncached articles. + (setq fetched-headers (gnus-fetch-headers uncached-articles)) + ;; Merge headers we got from the overview file with our + ;; newly-fetched headers. + (when fetched-headers + (setq headers + (delete-dups + (sort (append headers (copy-sequence fetched-headers)) + (lambda (l r) + (< (mail-header-number l) + (mail-header-number r)))))) - ;; Get the list of articles that were fetched - (goto-char (point-min)) - (let ((pm (point-max)) - art) - (while (< (point) pm) - (when (setq art (gnus-agent-read-article-number)) - (gnus-agent-append-to-list tail-fetched-articles art)) - (forward-line 1))) - - ;; Clip this list to the headers that will - ;; actually be returned - (setq fetched-articles (gnus-list-range-intersection - (cdr fetched-articles) - (cons min max))) - - ;; Clip the uncached articles list to exclude - ;; IDs after the last FETCHED header. The - ;; excluded IDs may be fetchable using HEAD. - (if (car tail-fetched-articles) - (setq uncached-articles - (gnus-list-range-intersection - uncached-articles - (cons (car uncached-articles) - (car tail-fetched-articles))))) - - ;; Create the list of articles that were - ;; "successfully" fetched. Success, in this - ;; case, means that the ID should not be - ;; fetched again. In the case of an expired - ;; article, the header will not be fetched. - (setq uncached-articles - (gnus-sorted-nunion fetched-articles - uncached-articles)) - ))) - - ;; Erase the temp buffer - (set-buffer gnus-agent-overview-buffer) - (erase-buffer) - - ;; Copy the nntp-server-buffer to the temp buffer - (set-buffer nntp-server-buffer) - (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) - - ;; Merge the temp buffer with the known headers (found on - ;; disk in FILE) into the nntp-server-buffer - (when uncached-articles - (gnus-agent-braid-nov uncached-articles file)) - - ;; Save the new set of known headers to FILE - (set-buffer nntp-server-buffer) + ;; Add the new set of known headers to the overview file. (let ((coding-system-for-write gnus-agent-file-coding-system)) - (gnus-agent-check-overview-buffer) - (write-region (point-min) (point-max) file nil 'silent)) - - (gnus-agent-update-view-total-fetched-for group t) - - ;; Update the group's article alist to include the newly - ;; fetched articles. - (gnus-agent-load-alist group) - (gnus-agent-save-alist group uncached-articles nil) - ) - - ;; Copy the temp buffer to the nntp-server-buffer - (set-buffer nntp-server-buffer) - (erase-buffer) - (insert-buffer-substring gnus-agent-overview-buffer))) - - (if (and fetch-old - (not (numberp fetch-old))) - t ; Don't remove anything. - (nnheader-nov-delete-outside-range - (car articles) - (car (last articles))) - t) - - 'nov)) + (with-current-buffer gnus-agent-overview-buffer + ;; We stick the new headers in at the end, then + ;; re-sort the whole buffer with + ;; `sort-numeric-fields'. If this turns out to be + ;; slow, we could consider a loop to add the headers + ;; in sorted order to begin with. + (goto-char (point-max)) + (mapc #'nnheader-insert-nov fetched-headers) + (sort-numeric-fields 1 (point-min) (point-max)) + (gnus-agent-check-overview-buffer) + (write-region (point-min) (point-max) file nil 'silent) + (gnus-agent-update-view-total-fetched-for group t) + ;; Update the group's article alist to include the + ;; newly fetched articles. + (gnus-agent-load-alist group) + (gnus-agent-save-alist group uncached-articles nil)))))) + headers))) (defun gnus-agent-request-article (article group) "Retrieve ARTICLE in GROUP from the agent cache." diff --git a/lisp/gnus/gnus-async.el b/lisp/gnus/gnus-async.el index fefd02c7bfb..ed948a26c0b 100644 --- a/lisp/gnus/gnus-async.el +++ b/lisp/gnus/gnus-async.el @@ -357,8 +357,13 @@ that was fetched." (let ((nntp-server-buffer (current-buffer)) (nnheader-callback-function (lambda (_arg) - (setq gnus-async-header-prefetched - (cons group unread))))) + (setq gnus-async-header-prefetched + (cons group unread))))) + ;; FIXME: If header prefetch is ever put into use, we'll + ;; have to handle the possibility that + ;; `gnus-retrieve-headers' might return a list of header + ;; vectors directly, rather than writing them into the + ;; current buffer. (gnus-retrieve-headers unread group gnus-fetch-old-headers)))))) (defun gnus-async-retrieve-fetched-headers (articles group) diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el index 36657e46219..9423d9f2f6b 100644 --- a/lisp/gnus/gnus-cache.el +++ b/lisp/gnus/gnus-cache.el @@ -294,49 +294,47 @@ it's not cached." (defun gnus-cache-retrieve-headers (articles group &optional fetch-old) "Retrieve the headers for ARTICLES in GROUP." (let ((cached - (setq gnus-newsgroup-cached (gnus-cache-articles-in-group group)))) + (setq gnus-newsgroup-cached (gnus-cache-articles-in-group group))) + (gnus-newsgroup-name group) + (gnus-fetch-old-headers fetch-old)) (if (not cached) ;; No cached articles here, so we just retrieve them ;; the normal way. (let ((gnus-use-cache nil)) - (gnus-retrieve-headers articles group fetch-old)) + (gnus-retrieve-headers articles group)) (let ((uncached-articles (gnus-sorted-difference articles cached)) (cache-file (gnus-cache-file-name group ".overview")) - type - (file-name-coding-system nnmail-pathname-coding-system)) + (file-name-coding-system nnmail-pathname-coding-system) + headers) ;; We first retrieve all the headers that we don't have in ;; the cache. (let ((gnus-use-cache nil)) (when uncached-articles - (setq type (and articles - (gnus-retrieve-headers - uncached-articles group fetch-old))))) + (setq headers (and articles + (gnus-fetch-headers uncached-articles))))) (gnus-cache-save-buffers) - ;; Then we insert the cached headers. - (save-excursion - (cond - ((not (file-exists-p cache-file)) - ;; There are no cached headers. - type) - ((null type) - ;; There were no uncached headers (or retrieval was - ;; unsuccessful), so we use the cached headers exclusively. - (set-buffer nntp-server-buffer) - (erase-buffer) - (let ((coding-system-for-read - gnus-cache-overview-coding-system)) - (insert-file-contents cache-file)) - 'nov) - ((eq type 'nov) - ;; We have both cached and uncached NOV headers, so we - ;; braid them. - (gnus-cache-braid-nov group cached) - type) - (t - ;; We braid HEADs. - (gnus-cache-braid-heads group (gnus-sorted-intersection - cached articles)) - type))))))) + ;; Then we include the cached headers. + (when (file-exists-p cache-file) + (setq headers + (delete-dups + (sort + (append headers + (let ((coding-system-for-read + gnus-cache-overview-coding-system)) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (insert-file-contents cache-file) + (gnus-get-newsgroup-headers-xover + (gnus-sorted-difference + cached uncached-articles) + nil (buffer-local-value + 'gnus-newsgroup-dependencies + gnus-summary-buffer) + group)))) + (lambda (l r) + (< (mail-header-number l) + (mail-header-number r))))))) + headers)))) (defun gnus-cache-enter-article (&optional n) "Enter the next N articles into the cache. @@ -529,70 +527,6 @@ Returns the list of articles removed." (setq gnus-cache-active-altered t))) articles))) -(defun gnus-cache-braid-nov (group cached &optional file) - (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*")) - beg end) - (gnus-cache-save-buffers) - (with-current-buffer cache-buf - (erase-buffer) - (let ((coding-system-for-read gnus-cache-overview-coding-system) - (file-name-coding-system nnmail-pathname-coding-system)) - (insert-file-contents - (or file (gnus-cache-file-name group ".overview")))) - (goto-char (point-min)) - (insert "\n") - (goto-char (point-min))) - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (while cached - (while (and (not (eobp)) - (< (read (current-buffer)) (car cached))) - (forward-line 1)) - (beginning-of-line) - (set-buffer cache-buf) - (if (search-forward (concat "\n" (int-to-string (car cached)) "\t") - nil t) - (setq beg (point-at-bol) - end (progn (end-of-line) (point))) - (setq beg nil)) - (set-buffer nntp-server-buffer) - (when beg - (insert-buffer-substring cache-buf beg end) - (insert "\n")) - (setq cached (cdr cached))) - (kill-buffer cache-buf))) - -(defun gnus-cache-braid-heads (group cached) - (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*"))) - (with-current-buffer cache-buf - (erase-buffer)) - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (dolist (entry cached) - (while (and (not (eobp)) - (looking-at "2.. +\\([0-9]+\\) ") - (< (progn (goto-char (match-beginning 1)) - (read (current-buffer))) - entry)) - (search-forward "\n.\n" nil 'move)) - (beginning-of-line) - (set-buffer cache-buf) - (erase-buffer) - (let ((coding-system-for-read gnus-cache-coding-system) - (file-name-coding-system nnmail-pathname-coding-system)) - (insert-file-contents (gnus-cache-file-name group entry))) - (goto-char (point-min)) - (insert "220 ") - (princ (pop cached) (current-buffer)) - (insert " Article retrieved.\n") - (search-forward "\n\n" nil 'move) - (delete-region (point) (point-max)) - (forward-char -1) - (insert ".") - (set-buffer nntp-server-buffer) - (insert-buffer-substring cache-buf)) - (kill-buffer cache-buf))) - ;;;###autoload (defun gnus-jog-cache () "Go through all groups and put the articles into the cache. diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el index f7c71f43ce8..00b85f546c2 100644 --- a/lisp/gnus/gnus-cloud.el +++ b/lisp/gnus/gnus-cloud.el @@ -30,6 +30,8 @@ (require 'parse-time) (require 'nnimap) +(declare-function gnus-fetch-headers "gnus-sum") +(defvar gnus-alter-header-function) (eval-when-compile (require 'epg)) ;; setf-method for `epg-context-armor' (autoload 'epg-make-context "epg") @@ -391,8 +393,6 @@ When FULL is t, upload everything, not just a difference from the last full." (gnus-group-refresh-group group)) (gnus-error 2 "Failed to upload Gnus Cloud data to %s" group))))) -(defvar gnus-alter-header-function) - (defun gnus-cloud-add-timestamps (elems) (dolist (elem elems) (let* ((file-name (plist-get elem :file-name)) @@ -407,14 +407,10 @@ When FULL is t, upload everything, not just a difference from the last full." (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method) (let* ((group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)) (active (gnus-active group)) - headers head) - (when (gnus-retrieve-headers (gnus-uncompress-range active) group) - (with-current-buffer nntp-server-buffer - (goto-char (point-min)) - (while (setq head (nnheader-parse-head)) - (when gnus-alter-header-function - (funcall gnus-alter-header-function head)) - (push head headers)))) + (gnus-newsgroup-name group) + (headers (gnus-fetch-headers (gnus-uncompress-range active)))) + (when gnus-alter-header-function + (mapc gnus-alter-header-function headers)) (sort (nreverse headers) (lambda (h1 h2) (> (gnus-cloud-chunk-sequence (mail-header-subject h1)) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index b0f9ed4c6f0..5bd58b690af 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -5658,10 +5658,21 @@ or a straight list of headers." (setf (mail-header-subject header) subject)))))) (defun gnus-fetch-headers (articles &optional limit force-new dependencies) - "Fetch headers of ARTICLES." + "Fetch headers of ARTICLES. +This calls the `gnus-retrieve-headers' function of the current +group's backend server. The server can do one of two things: + +1. Write the headers for ARTICLES into the + `nntp-server-buffer' (the current buffer) in a parseable format, or +2. Return the headers directly as a list of vectors. + +In the first case, `gnus-retrieve-headers' returns a symbol +value, either `nov' or `headers'. This value determines which +parsing function is used to read the headers. It is also stored +into the variable `gnus-headers-retrieved-by', which is consulted +later when possibly building full threads." (gnus-message 7 "Fetching headers for %s..." gnus-newsgroup-name) - (prog1 - (pcase (setq gnus-headers-retrieved-by + (let ((res (setq gnus-headers-retrieved-by (gnus-retrieve-headers articles gnus-newsgroup-name (or limit @@ -5671,22 +5682,34 @@ or a straight list of headers." (not (eq gnus-fetch-old-headers 'some)) (not (numberp gnus-fetch-old-headers))) (> (length articles) 1)) - gnus-fetch-old-headers)))) - ('nov - (gnus-get-newsgroup-headers-xover - articles force-new dependencies gnus-newsgroup-name t)) - ('headers - (gnus-get-newsgroup-headers dependencies force-new)) - ((pred listp) - (let ((dependencies - (or dependencies - (with-current-buffer gnus-summary-buffer - gnus-newsgroup-dependencies)))) - (delq nil (mapcar #'(lambda (header) - (gnus-dependencies-add-header - header dependencies force-new)) - gnus-headers-retrieved-by))))) - (gnus-message 7 "Fetching headers for %s...done" gnus-newsgroup-name))) + gnus-fetch-old-headers)))))) + (prog1 + (pcase res + ('nov + (gnus-get-newsgroup-headers-xover + articles force-new dependencies gnus-newsgroup-name t)) + ;; For now, assume that any backend returning its own + ;; headers takes some effort to do so, so return `headers'. + ((pred listp) + (setq gnus-headers-retrieved-by 'headers) + (let ((dependencies + (or dependencies + (buffer-local-value + 'gnus-newsgroup-dependencies gnus-summary-buffer)))) + (when (functionp gnus-alter-header-function) + (mapc gnus-alter-header-function res)) + (mapc (lambda (header) + ;; The agent or the cache may have already + ;; registered this header in the dependency + ;; table. + (unless (gethash (mail-header-id header) dependencies) + (gnus-dependencies-add-header + header dependencies force-new))) + res) + res)) + (_ (gnus-get-newsgroup-headers dependencies force-new))) + (gnus-message 7 "Fetching headers for %s...done" + gnus-newsgroup-name)))) (defun gnus-select-newsgroup (group &optional read-all select-articles) "Select newsgroup GROUP. @@ -6443,6 +6466,10 @@ The resulting hash table is returned, or nil if no Xrefs were found." (unless (gnus-ephemeral-group-p group) (gnus-group-update-group group t)))))) +;; FIXME: Refactor this with `gnus-get-newsgroup-headers-xover' and +;; extract the necessary bits for the direct-header-return case. Also +;; look at this and see how similar it is to +;; `nnheader-parse-naked-head'. (defun gnus-get-newsgroup-headers (&optional dependencies force-new) (let ((dependencies (or dependencies diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 3b172db2111..2e9ee7189d2 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -2388,7 +2388,14 @@ Typical marks are those that make no sense in a standalone back end, such as a mark that says whether an article is stored in the cache \(which doesn't make sense in a standalone back end).") -(defvar gnus-headers-retrieved-by nil) +(defvar gnus-headers-retrieved-by nil + "Holds the return value of `gnus-retrieve-headers'. +This is either the symbol `nov' or the symbol `headers'. This +value is checked during the summary creation process, when +building threads. A value of `nov' indicates that header +retrieval is relatively cheap and threading is encouraged to +include more old articles. A value of `headers' indicates that +retrieval is expensive and should be minimized.") (defvar gnus-article-reply nil) (defvar gnus-override-method nil) (defvar gnus-opened-servers nil) diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el index 1e2feda6365..ba2934351d6 100644 --- a/lisp/gnus/nnvirtual.el +++ b/lisp/gnus/nnvirtual.el @@ -101,15 +101,10 @@ It is computed from the marks of individual component groups.") (erase-buffer) (if (stringp (car articles)) 'headers - (let ((vbuf (nnheader-set-temp-buffer - (gnus-get-buffer-create " *virtual headers*"))) - (carticles (nnvirtual-partition-sequence articles)) + (let ((carticles (nnvirtual-partition-sequence articles)) (sysname (system-name)) - cgroup carticle article result prefix) - (while carticles - (setq cgroup (caar carticles)) - (setq articles (cdar carticles)) - (pop carticles) + cgroup headers all-headers article prefix) + (pcase-dolist (`(,cgroup . ,articles) carticles) (when (and articles (gnus-check-server (gnus-find-method-for-group cgroup) t) @@ -119,69 +114,37 @@ It is computed from the marks of individual component groups.") ;; This is probably evil if people have set ;; gnus-use-cache to nil themselves, but I ;; have no way of finding the true value of it. - (let ((gnus-use-cache t)) - (setq result (gnus-retrieve-headers - articles cgroup nil)))) - (set-buffer nntp-server-buffer) - ;; If we got HEAD headers, we convert them into NOV - ;; headers. This is slow, inefficient and, come to think - ;; of it, downright evil. So sue me. I couldn't be - ;; bothered to write a header parse routine that could - ;; parse a mixed HEAD/NOV buffer. - (when (eq result 'headers) - (nnvirtual-convert-headers)) - (goto-char (point-min)) - (while (not (eobp)) - (delete-region (point) - (progn - (setq carticle (read nntp-server-buffer)) - (point))) + (let ((gnus-use-cache t) + (gnus-newsgroup-name cgroup) + (gnus-fetch-old-headers nil)) + (setq headers (gnus-fetch-headers articles)))) + (erase-buffer) + ;; Remove all header article numbers from `articles'. + ;; If there's anything left, those are expired or + ;; canceled articles, so we update the component group + ;; below. + (dolist (h headers) + (setq articles (delq (mail-header-number h) articles) + article (nnvirtual-reverse-map-article + cgroup (mail-header-number h))) + ;; Update all the header numbers according to their + ;; reverse mapping, and drop any with no such mapping. + (when article + ;; Do this first, before we re-set the header's + ;; article number. + (nnvirtual-update-xref-header + h cgroup prefix sysname) + (setf (mail-header-number h) article) + (push h all-headers))) + ;; Anything left in articles is expired or canceled. + ;; Could be smart and not tell it about articles already + ;; known? + (when articles + (gnus-group-make-articles-read cgroup articles)))) - ;; We remove this article from the articles list, if - ;; anything is left in the articles list after going through - ;; the entire buffer, then those articles have been - ;; expired or canceled, so we appropriately update the - ;; component group below. They should be coming up - ;; generally in order, so this shouldn't be slow. - (setq articles (delq carticle articles)) - - (setq article (nnvirtual-reverse-map-article cgroup carticle)) - (if (null article) - ;; This line has no reverse mapping, that means it - ;; was an extra article reference returned by nntp. - (progn - (beginning-of-line) - (delete-region (point) (progn (forward-line 1) (point)))) - ;; Otherwise insert the virtual article number, - ;; and clean up the xrefs. - (princ article nntp-server-buffer) - (nnvirtual-update-xref-header cgroup carticle - prefix sysname) - (forward-line 1)) - ) - - (set-buffer vbuf) - (goto-char (point-max)) - (insert-buffer-substring nntp-server-buffer)) - ;; Anything left in articles is expired or canceled. - ;; Could be smart and not tell it about articles already known? - (when articles - (gnus-group-make-articles-read cgroup articles)) - ) - - ;; The headers are ready for reading, so they are inserted into - ;; the nntp-server-buffer, which is where Gnus expects to find - ;; them. - (prog1 - (with-current-buffer nntp-server-buffer - (erase-buffer) - (insert-buffer-substring vbuf) - ;; FIX FIX FIX, we should be able to sort faster than - ;; this if needed, since each cgroup is sorted, we just - ;; need to merge - (sort-numeric-fields 1 (point-min) (point-max)) - 'nov) - (kill-buffer vbuf))))))) + (sort all-headers (lambda (h1 h2) + (< (mail-header-number h1) + (mail-header-number h2))))))))) (defvoo nnvirtual-last-accessed-component-group nil) @@ -372,61 +335,18 @@ It is computed from the marks of individual component groups.") ;;; Internal functions. -(defun nnvirtual-convert-headers () - "Convert HEAD headers into NOV headers." - (with-current-buffer nntp-server-buffer - (let* ((dependencies (make-hash-table :test #'equal)) - (headers (gnus-get-newsgroup-headers dependencies))) - (erase-buffer) - (mapc 'nnheader-insert-nov headers)))) - - -(defun nnvirtual-update-xref-header (group article prefix sysname) - "Edit current NOV header in current buffer to have an xref to the component group, and also server prefix any existing xref lines." - ;; Move to beginning of Xref field, creating a slot if needed. - (beginning-of-line) - (looking-at - "[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t") - (goto-char (match-end 0)) - (unless (search-forward "\t" (point-at-eol) 'move) - (insert "\t")) - - ;; Remove any spaces at the beginning of the Xref field. - (while (eq (char-after (1- (point))) ? ) - (forward-char -1) - (delete-char 1)) - - (insert "Xref: " sysname " " group ":") - (princ article (current-buffer)) - (insert " ") - - ;; If there were existing xref lines, clean them up to have the correct - ;; component server prefix. - (save-restriction - (narrow-to-region (point) - (or (search-forward "\t" (point-at-eol) t) - (point-at-eol))) - (goto-char (point-min)) - (when (re-search-forward "Xref: *[^\n:0-9 ]+ *" nil t) - (replace-match "" t t)) - (goto-char (point-min)) - (when (re-search-forward - (concat (regexp-quote (gnus-group-real-name group)) ":[0-9]+") - nil t) - (replace-match "" t t)) - (unless (eobp) - (insert " ") - (when (not (string= "" prefix)) - (while (re-search-forward "[^ ]+:[0-9]+" nil t) - (save-excursion - (goto-char (match-beginning 0)) - (insert prefix)))))) - - ;; Ensure a trailing \t. - (end-of-line) - (or (eq (char-after (1- (point))) ?\t) - (insert ?\t))) - +(defun nnvirtual-update-xref-header (header group prefix sysname) + "Add xref to component GROUP to HEADER. +Also add a server PREFIX any existing xref lines." + (let ((bits (split-string (mail-header-xref header) + nil t "[[:blank:]]")) + (art-no (mail-header-number header))) + (setf (mail-header-xref header) + (concat + (format "%s %s:%d " sysname group art-no) + (mapconcat (lambda (bit) + (concat prefix bit)) + bits " "))))) (defun nnvirtual-possibly-change-server (server) (or (not server) diff --git a/lisp/obsolete/nnir.el b/lisp/obsolete/nnir.el index 147efed0057..0b7d1e454c3 100644 --- a/lisp/obsolete/nnir.el +++ b/lisp/obsolete/nnir.el @@ -504,7 +504,6 @@ Add an entry here when adding a new search engine.") ,@(mapcar (lambda (elem) (list 'const (car elem))) nnir-engines))))) - (defmacro nnir-add-result (dirnam artno score prefix server artlist) "Construct a result vector and add it to ARTLIST. DIRNAM, ARTNO, SCORE, PREFIX and SERVER are passed to From 35119b2bc0fd602a19fa0b07d305592d139be6a8 Mon Sep 17 00:00:00 2001 From: Stephen Gildea Date: Mon, 18 Jan 2021 13:27:22 -0800 Subject: [PATCH 028/133] time-stamp-tests now pass in more locales Update time-stamp-tests to use format-time-string to generate the date words (month, day of week, AM/PM) instead of hard-coding English. Now the tests pass in locales other than "C" and US English. Expand the test coverage of modifier characters. --- test/lisp/time-stamp-tests.el | 127 ++++++++++++++++++++-------------- 1 file changed, 75 insertions(+), 52 deletions(-) diff --git a/test/lisp/time-stamp-tests.el b/test/lisp/time-stamp-tests.el index 81488c3df19..4ae3c1917dd 100644 --- a/test/lisp/time-stamp-tests.el +++ b/test/lisp/time-stamp-tests.el @@ -262,40 +262,48 @@ (ert-deftest time-stamp-format-day-of-week () "Test time-stamp formats for named day of week." (with-time-stamp-test-env - ;; implemented and documented since 1997 - (should (equal (time-stamp-string "%3a" ref-time1) "Mon")) - (should (equal (time-stamp-string "%#A" ref-time1) "MONDAY")) - ;; documented 1997-2019 - (should (equal (time-stamp-string "%3A" ref-time1) "MON")) - (should (equal (time-stamp-string "%:a" ref-time1) "Monday")) - ;; implemented since 2001, documented since 2019 - (should (equal (time-stamp-string "%#a" ref-time1) "MON")) - (should (equal (time-stamp-string "%:A" ref-time1) "Monday")) - ;; allowed but undocumented since 2019 (warned 1997-2019) - (should (equal (time-stamp-string "%^A" ref-time1) "MONDAY")) - ;; warned 1997-2019, changed in 2019 - (should (equal (time-stamp-string "%a" ref-time1) "Mon")) - (should (equal (time-stamp-string "%^a" ref-time1) "MON")) - (should (equal (time-stamp-string "%A" ref-time1) "Monday")))) + (let ((Mon (format-time-string "%a" ref-time1 t)) + (MON (format-time-string "%^a" ref-time1 t)) + (Monday (format-time-string "%A" ref-time1 t)) + (MONDAY (format-time-string "%^A" ref-time1 t))) + ;; implemented and documented since 1997 + (should (equal (time-stamp-string "%3a" ref-time1) Mon)) + (should (equal (time-stamp-string "%#A" ref-time1) MONDAY)) + ;; documented 1997-2019 + (should (equal (time-stamp-string "%3A" ref-time1) MON)) + (should (equal (time-stamp-string "%:a" ref-time1) Monday)) + ;; implemented since 2001, documented since 2019 + (should (equal (time-stamp-string "%#a" ref-time1) MON)) + (should (equal (time-stamp-string "%:A" ref-time1) Monday)) + ;; allowed but undocumented since 2019 (warned 1997-2019) + (should (equal (time-stamp-string "%^A" ref-time1) MONDAY)) + ;; warned 1997-2019, changed in 2019 + (should (equal (time-stamp-string "%a" ref-time1) Mon)) + (should (equal (time-stamp-string "%^a" ref-time1) MON)) + (should (equal (time-stamp-string "%A" ref-time1) Monday))))) (ert-deftest time-stamp-format-month-name () "Test time-stamp formats for month name." (with-time-stamp-test-env - ;; implemented and documented since 1997 - (should (equal (time-stamp-string "%3b" ref-time1) "Jan")) - (should (equal (time-stamp-string "%#B" ref-time1) "JANUARY")) - ;; documented 1997-2019 - (should (equal (time-stamp-string "%3B" ref-time1) "JAN")) - (should (equal (time-stamp-string "%:b" ref-time1) "January")) - ;; implemented since 2001, documented since 2019 - (should (equal (time-stamp-string "%#b" ref-time1) "JAN")) - (should (equal (time-stamp-string "%:B" ref-time1) "January")) - ;; allowed but undocumented since 2019 (warned 1997-2019) - (should (equal (time-stamp-string "%^B" ref-time1) "JANUARY")) - ;; warned 1997-2019, changed in 2019 - (should (equal (time-stamp-string "%b" ref-time1) "Jan")) - (should (equal (time-stamp-string "%^b" ref-time1) "JAN")) - (should (equal (time-stamp-string "%B" ref-time1) "January")))) + (let ((Jan (format-time-string "%b" ref-time1 t)) + (JAN (format-time-string "%^b" ref-time1 t)) + (January (format-time-string "%B" ref-time1 t)) + (JANUARY (format-time-string "%^B" ref-time1 t))) + ;; implemented and documented since 1997 + (should (equal (time-stamp-string "%3b" ref-time1) Jan)) + (should (equal (time-stamp-string "%#B" ref-time1) JANUARY)) + ;; documented 1997-2019 + (should (equal (time-stamp-string "%3B" ref-time1) JAN)) + (should (equal (time-stamp-string "%:b" ref-time1) January)) + ;; implemented since 2001, documented since 2019 + (should (equal (time-stamp-string "%#b" ref-time1) JAN)) + (should (equal (time-stamp-string "%:B" ref-time1) January)) + ;; allowed but undocumented since 2019 (warned 1997-2019) + (should (equal (time-stamp-string "%^B" ref-time1) JANUARY)) + ;; warned 1997-2019, changed in 2019 + (should (equal (time-stamp-string "%b" ref-time1) Jan)) + (should (equal (time-stamp-string "%^b" ref-time1) JAN)) + (should (equal (time-stamp-string "%B" ref-time1) January))))) (ert-deftest time-stamp-format-day-of-month () "Test time-stamp formats for day of month." @@ -483,14 +491,18 @@ (ert-deftest time-stamp-format-am-pm () "Test time-stamp formats for AM and PM strings." (with-time-stamp-test-env - ;; implemented and documented since 1997 - (should (equal (time-stamp-string "%#p" ref-time1) "pm")) - (should (equal (time-stamp-string "%#p" ref-time3) "am")) - (should (equal (time-stamp-string "%P" ref-time1) "PM")) - (should (equal (time-stamp-string "%P" ref-time3) "AM")) - ;; warned 1997-2019, changed in 2019 - (should (equal (time-stamp-string "%p" ref-time1) "PM")) - (should (equal (time-stamp-string "%p" ref-time3) "AM")))) + (let ((pm (format-time-string "%#p" ref-time1 t)) + (am (format-time-string "%#p" ref-time3 t)) + (PM (format-time-string "%p" ref-time1 t)) + (AM (format-time-string "%p" ref-time3 t))) + ;; implemented and documented since 1997 + (should (equal (time-stamp-string "%#p" ref-time1) pm)) + (should (equal (time-stamp-string "%#p" ref-time3) am)) + (should (equal (time-stamp-string "%P" ref-time1) PM)) + (should (equal (time-stamp-string "%P" ref-time3) AM)) + ;; warned 1997-2019, changed in 2019 + (should (equal (time-stamp-string "%p" ref-time1) PM)) + (should (equal (time-stamp-string "%p" ref-time3) AM))))) (ert-deftest time-stamp-format-day-number-in-week () "Test time-stamp formats for day number in week." @@ -567,10 +579,15 @@ (ert-deftest time-stamp-format-ignored-modifiers () "Test additional args allowed (but ignored) to allow for future expansion." (with-time-stamp-test-env - ;; allowed modifiers - (should (equal (time-stamp-string "%.,@-+_ ^(stuff)P" ref-time3) "AM")) - ;; not all punctuation is allowed - (should-not (equal (time-stamp-string "%&P" ref-time3) "AM")))) + (let ((May (format-time-string "%B" ref-time3 t))) + ;; allowed modifiers + (should (equal (time-stamp-string "%.,@+ (stuff)B" ref-time3) May)) + ;; parens nest + (should (equal (time-stamp-string "%(st(u)ff)B" ref-time3) May)) + ;; escaped parens do not change the nesting level + (should (equal (time-stamp-string "%(st\\)u\\(ff)B" ref-time3) May)) + ;; not all punctuation is allowed + (should-not (equal (time-stamp-string "%&B" ref-time3) May))))) (ert-deftest time-stamp-format-non-conversions () "Test that without a %, the text is copied literally." @@ -580,16 +597,22 @@ (ert-deftest time-stamp-format-string-width () "Test time-stamp string width modifiers." (with-time-stamp-test-env - ;; strings truncate on the right or are blank-padded on the left - (should (equal (time-stamp-string "%0P" ref-time3) "")) - (should (equal (time-stamp-string "%1P" ref-time3) "A")) - (should (equal (time-stamp-string "%2P" ref-time3) "AM")) - (should (equal (time-stamp-string "%3P" ref-time3) " AM")) - (should (equal (time-stamp-string "%0%" ref-time3) "")) - (should (equal (time-stamp-string "%1%" ref-time3) "%")) - (should (equal (time-stamp-string "%2%" ref-time3) " %")) - (should (equal (time-stamp-string "%#3a" ref-time3) "SUN")) - (should (equal (time-stamp-string "%#3b" ref-time2) "NOV")))) + (let ((May (format-time-string "%b" ref-time3 t)) + (SUN (format-time-string "%^a" ref-time3 t)) + (NOV (format-time-string "%^b" ref-time2 t))) + ;; strings truncate on the right or are blank-padded on the left + (should (equal (time-stamp-string "%0b" ref-time3) "")) + (should (equal (time-stamp-string "%1b" ref-time3) (substring May 0 1))) + (should (equal (time-stamp-string "%2b" ref-time3) (substring May 0 2))) + (should (equal (time-stamp-string "%3b" ref-time3) May)) + (should (equal (time-stamp-string "%4b" ref-time3) (concat " " May))) + (should (equal (time-stamp-string "%0%" ref-time3) "")) + (should (equal (time-stamp-string "%1%" ref-time3) "%")) + (should (equal (time-stamp-string "%2%" ref-time3) " %")) + (should (equal (time-stamp-string "%9%" ref-time3) " %")) + (should (equal (time-stamp-string "%10%" ref-time3) " %")) + (should (equal (time-stamp-string "%#3a" ref-time3) SUN)) + (should (equal (time-stamp-string "%#3b" ref-time2) NOV))))) ;;; Tests of helper functions From 4ca808ee7adda7b17a7dedffbce9e9e49ee4cd93 Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Tue, 19 Jan 2021 03:05:44 +0200 Subject: [PATCH 029/133] Make sure the new window is not too tall * lisp/progmodes/xref.el (xref-show-definitions-buffer-at-bottom): Make sure the new window is not too tall (bug#45945). --- lisp/progmodes/xref.el | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index b6778de807d..aecb30a0ad4 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -1001,8 +1001,12 @@ When only one definition found, jump to it right away instead." When there is more than one definition, split the selected window and show the list in a small window at the bottom. And use a local keymap that binds `RET' to `xref-quit-and-goto-xref'." - (let ((xrefs (funcall fetcher)) - (dd default-directory)) + (let* ((xrefs (funcall fetcher)) + (dd default-directory) + ;; XXX: Make percentage customizable maybe? + (max-height (/ (window-height) 2)) + (size-fun (lambda (window) + (fit-window-to-buffer window max-height)))) (cond ((not (cdr xrefs)) (xref-pop-to-location (car xrefs) @@ -1013,7 +1017,8 @@ local keymap that binds `RET' to `xref-quit-and-goto-xref'." (xref--transient-buffer-mode) (xref--show-common-initialize (xref--analyze xrefs) fetcher alist) (pop-to-buffer (current-buffer) - '(display-buffer-in-direction . ((direction . below)))) + `(display-buffer-in-direction . ((direction . below) + (window-height . ,size-fun)))) (current-buffer)))))) (define-obsolete-function-alias 'xref--show-defs-buffer-at-bottom From f844ce69cd0a07d45852a8b04ed3f1c84a699ed8 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 19 Jan 2021 04:28:18 +0100 Subject: [PATCH 030/133] Revert "* .gitignore: add src/fingerprint.c" This reverts commit 2644353cbc65927a6a0a76d68e00d017771cdd03. The src/fingerprint.c file is no longer generated, and the spelling of the obsolete function was correct. --- .gitignore | 1 - lisp/dired-x.el | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/.gitignore b/.gitignore index 7e3e4341814..dd4eab759cb 100644 --- a/.gitignore +++ b/.gitignore @@ -298,4 +298,3 @@ nt/emacs.rc nt/emacsclient.rc src/gdb.ini /var/ -src/fingerprint.c diff --git a/lisp/dired-x.el b/lisp/dired-x.el index aebffe339eb..5a52eccbbe3 100644 --- a/lisp/dired-x.el +++ b/lisp/dired-x.el @@ -1483,7 +1483,7 @@ a prefix argument, when it offers the filename near point as a default." ;;; Internal functions. ;; Fixme: This should probably use `thing-at-point'. -- fx -(define-obsolete-function-alias 'dired-file-name-at-point +(define-obsolete-function-alias 'dired-filename-at-point #'dired-x-guess-file-name-at-point "28.1") (defun dired-x-guess-file-name-at-point () "Return the filename closest to point, expanded. From 973799f17996c99f500024f35604d49b70ce4439 Mon Sep 17 00:00:00 2001 From: Lucas Werkmeister Date: Tue, 19 Jan 2021 04:47:14 +0100 Subject: [PATCH 031/133] Mark the various nxml flags as safa * lisp/nxml/nxml-mode.el (nxml-char-ref-display-glyph-flag) (nxml-sexp-element-flag, nxml-slash-auto-complete-flag) (nxml-child-indent, nxml-attribute-indent) (nxml-bind-meta-tab-to-complete-flag) (nxml-prefer-utf-16-to-utf-8-flag) (nxml-prefer-utf-16-little-to-big-endian-flag) (nxml-default-buffer-file-coding-system) (nxml-auto-insert-xml-declaration-flag): Add :safe to allow easier cusomization (bug#45969). --- lisp/nxml/nxml-mode.el | 30 ++++++++++++++++++++---------- 1 file changed, 20 insertions(+), 10 deletions(-) diff --git a/lisp/nxml/nxml-mode.el b/lisp/nxml/nxml-mode.el index 5bc3049d90f..0602943db20 100644 --- a/lisp/nxml/nxml-mode.el +++ b/lisp/nxml/nxml-mode.el @@ -54,26 +54,30 @@ "Non-nil means display glyph following character reference. The glyph is displayed in face `nxml-glyph'." :group 'nxml - :type 'boolean) + :type 'boolean + :safe #'booleanp) (defcustom nxml-sexp-element-flag t "Non-nil means sexp commands treat an element as a single expression." :version "27.1" ; nil -> t :group 'nxml - :type 'boolean) + :type 'boolean + :safe #'booleanp) (defcustom nxml-slash-auto-complete-flag nil "Non-nil means typing a slash automatically completes the end-tag. This is used by `nxml-electric-slash'." :group 'nxml - :type 'boolean) + :type 'boolean + :safe #'booleanp) (defcustom nxml-child-indent 2 "Indentation for the children of an element relative to the start-tag. This only applies when the line or lines containing the start-tag contains nothing else other than that start-tag." :group 'nxml - :type 'integer) + :type 'integer + :safe #'integerp) (defcustom nxml-attribute-indent 4 "Indentation for the attributes of an element relative to the start-tag. @@ -81,12 +85,14 @@ This only applies when the first attribute of a tag starts a line. In other cases, the first attribute on one line is indented the same as the first attribute on the previous line." :group 'nxml - :type 'integer) + :type 'integer + :safe #'integerp) (defcustom nxml-bind-meta-tab-to-complete-flag t "Non-nil means to use nXML completion in \\[completion-at-point]." :group 'nxml - :type 'boolean) + :type 'boolean + :safe #'booleanp) (defcustom nxml-prefer-utf-16-to-utf-8-flag nil "Non-nil means prefer UTF-16 to UTF-8 when saving a buffer. @@ -94,7 +100,8 @@ This is used only when a buffer does not contain an encoding declaration and when its current `buffer-file-coding-system' specifies neither UTF-16 nor UTF-8." :group 'nxml - :type 'boolean) + :type 'boolean + :safe #'booleanp) (defcustom nxml-prefer-utf-16-little-to-big-endian-flag (eq system-type 'windows-nt) @@ -103,7 +110,8 @@ This is used only for saving a buffer; when reading the byte-order is auto-detected. It may be relevant both when there is no encoding declaration and when the encoding declaration specifies `UTF-16'." :group 'nxml - :type 'boolean) + :type 'boolean + :safe #'booleanp) (defcustom nxml-default-buffer-file-coding-system nil "Default value for `buffer-file-coding-system' for a buffer for a new file. @@ -112,13 +120,15 @@ A value of nil means use the default value of A buffer's `buffer-file-coding-system' affects what \\[nxml-insert-xml-declaration] inserts." :group 'nxml - :type 'coding-system) + :type 'coding-system + :safe #'coding-system-p) (defcustom nxml-auto-insert-xml-declaration-flag nil "Non-nil means automatically insert an XML declaration in a new file. The XML declaration is inserted using `nxml-insert-xml-declaration'." :group 'nxml - :type 'boolean) + :type 'boolean + :safe #'booleanp) (defface nxml-delimited-data '((t (:inherit font-lock-doc-face))) From 43982a8f1017f709f78d5722796c266d4f72de05 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 19 Jan 2021 05:13:03 +0100 Subject: [PATCH 032/133] Don't infloop in comint-redirect-results-list-from-process * lisp/comint.el (comint-redirect-results-list-from-process): Ensure forward progress (bug#45950). --- lisp/comint.el | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/lisp/comint.el b/lisp/comint.el index 53153af7d27..e52d67d0e50 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -3863,7 +3863,11 @@ REGEXP-GROUP is the regular expression group in REGEXP to use." (push (buffer-substring-no-properties (match-beginning regexp-group) (match-end regexp-group)) - results)) + results) + (when (zerop (length (match-string 0))) + ;; If the regexp can be empty (for instance, "^.*$"), we + ;; don't advance, so ensure forward progress. + (forward-line 1))) (nreverse results)))) ;; Converting process modes to use comint mode From 378a01e16808ce319138141bdc0779d96e17f8bf Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 19 Jan 2021 06:05:53 +0100 Subject: [PATCH 033/133] Actually make the calc trail window dedicated * lisp/calc/calc.el (calc-trail-display): Actually make the trail window dedicated (bug#45928). --- lisp/calc/calc.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index d684c7ba97f..ec09abb34c4 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -2144,7 +2144,7 @@ the United States." (let ((w (split-window nil (/ (* (window-width) 2) 3) t))) (set-window-buffer w calc-trail-buffer) (and calc-make-windows-dedicated - (set-window-dedicated-p nil t)))) + (set-window-dedicated-p w t)))) (calc-wrapper (setq overlay-arrow-string calc-trail-overlay overlay-arrow-position calc-trail-pointer) From 4e64d023563988a570b6c2ac60d48af7f2d64a68 Mon Sep 17 00:00:00 2001 From: "James N. V. Cash" Date: Tue, 19 Jan 2021 07:07:37 +0100 Subject: [PATCH 034/133] Define keymap-name-history * lisp/help-fns.el (keymap-name-history): Define the history variable (bug#45879). This avoids problems in other completing systems like Helm. Copyright-paperwork-exempt: yes --- lisp/help-fns.el | 3 +++ 1 file changed, 3 insertions(+) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index d559221a827..7be2826361c 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -76,6 +76,9 @@ frame.") ;; costly, really). "Radix-tree representation replacing `definition-prefixes'.") +(defvar keymap-name-history nil + "History for input to `describe-keymap'.") + (defun help-definition-prefixes () "Return the up-to-date radix-tree form of `definition-prefixes'." (when (> (hash-table-count definition-prefixes) 0) From b62a1e358befe996a4e2f4038ef48a9dd44901f8 Mon Sep 17 00:00:00 2001 From: Protesilaos Stavrou Date: Tue, 19 Jan 2021 08:11:39 +0100 Subject: [PATCH 035/133] Add 'perl-non-scalar-variable' face to perl-mode * etc/NEWS: Document the new face (bug#45840). * lisp/progmodes/perl-mode.el (perl-non-scalar-variable): Define new face. (perl-font-lock-keywords-2): Apply 'perl-non-scalar-variable' face. --- etc/NEWS | 6 ++++++ lisp/progmodes/perl-mode.el | 11 +++++++++-- 2 files changed, 15 insertions(+), 2 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index d632283e7f3..8fc5f3e046c 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -352,6 +352,12 @@ When emacsclient connects, Emacs will (by default) output a message about how to exit the client frame. If 'server-client-instructions' is set to nil, this message is inhibited. +** Perl mode + +--- +*** New face 'perl-non-scalar-variable'. +This is used to fontify non-scalar variables. + ** Python mode *** 'python-shell-interpreter' now defaults to python3 on systems with python3. diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el index 2a2a4978c62..d047dd543c2 100644 --- a/lisp/progmodes/perl-mode.el +++ b/lisp/progmodes/perl-mode.el @@ -95,6 +95,12 @@ :prefix "perl-" :group 'languages) +(defface perl-non-scalar-variable + '((t :inherit font-lock-variable-name-face :underline t)) + "Face used for non-scalar variables." + :version "28.1" + :group 'perl) + (defvar perl-mode-abbrev-table nil "Abbrev table in use in perl-mode buffers.") (define-abbrev-table 'perl-mode-abbrev-table ()) @@ -187,11 +193,12 @@ ;; ;; Fontify function, variable and file name references. ("&\\(\\sw+\\(::\\sw+\\)*\\)" 1 font-lock-function-name-face) - ;; Additionally underline non-scalar variables. Maybe this is a bad idea. + ;; Additionally fontify non-scalar variables. `perl-non-scalar-variable' + ;; will underline them by default. ;;'("[$@%*][#{]?\\(\\sw+\\)" 1 font-lock-variable-name-face) ("[$*]{?\\(\\sw+\\(::\\sw+\\)*\\)" 1 font-lock-variable-name-face) ("\\([@%]\\|\\$#\\)\\(\\sw+\\(::\\sw+\\)*\\)" - (2 (cons font-lock-variable-name-face '(underline)))) + (2 'perl-non-scalar-variable)) ("<\\(\\sw+\\)>" 1 font-lock-constant-face) ;; ;; Fontify keywords with/and labels as we do in `c++-font-lock-keywords'. From ba0cf1d7017894ff9e539cba83881865b3a025a1 Mon Sep 17 00:00:00 2001 From: Drew Adams Date: Tue, 19 Jan 2021 09:11:18 -0300 Subject: [PATCH 036/133] Tweaks to the color widget (Bug#45829) * lisp/wid-edit.el (widget-color-match, widget-color-validate): New functions. (color): Use the new functions. Base size on longest defined color name, defaulting to the longest RGB hex string. --- lisp/wid-edit.el | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 7dda04eda21..68a0d3d2356 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -4026,17 +4026,19 @@ is inline." ;;; The `color' Widget. -;; Fixme: match (define-widget 'color 'editable-field "Choose a color name (with sample)." :format "%{%t%}: %v (%{sample%})\n" :value-create 'widget-color-value-create - :size 10 + :size (1+ (apply #'max 13 ; Longest RGB hex string. + (mapcar #'length (defined-colors)))) :tag "Color" :value "black" :completions (or facemenu-color-alist (defined-colors)) :sample-face-get 'widget-color-sample-face-get :notify 'widget-color-notify + :match #'widget-color-match + :validate #'widget-color-validate :action 'widget-color-action) (defun widget-color-value-create (widget) @@ -4085,6 +4087,19 @@ is inline." (overlay-put (widget-get widget :sample-overlay) 'face (widget-apply widget :sample-face-get)) (widget-default-notify widget child event)) + +(defun widget-color-match (_widget value) + "Non-nil if VALUE is a defined color or a RGB hex string." + (and (stringp value) + (or (color-defined-p value) + (string-match-p "^#\\(?:[[:xdigit:]]\\{3\\}\\)\\{1,4\\}$" value)))) + +(defun widget-color-validate (widget) + "Check that WIDGET's value is a valid color." + (let ((value (widget-value widget))) + (unless (widget-color-match widget value) + (widget-put widget :error (format "Invalid color: %S" value)) + widget))) ;;; The Help Echo From 33ff86a20ab5a0b6a7ffe5056341334c4bcafca6 Mon Sep 17 00:00:00 2001 From: Mauro Aranda Date: Tue, 19 Jan 2021 09:11:37 -0300 Subject: [PATCH 037/133] Add test for the widget-color-match function (Bug#45829) * test/lisp/wid-edit-tests.el (widget-test-color-match): New test. --- test/lisp/wid-edit-tests.el | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/test/lisp/wid-edit-tests.el b/test/lisp/wid-edit-tests.el index 17fdfefce84..f843649784a 100644 --- a/test/lisp/wid-edit-tests.el +++ b/test/lisp/wid-edit-tests.el @@ -322,4 +322,15 @@ return nil, even with a non-nil bubblep argument." (widget-backward 1) (should (string= "Second" (widget-value (widget-at)))))) +(ert-deftest widget-test-color-match () + "Test that the :match function for the color widget works." + (let ((widget (widget-convert 'color))) + (should (widget-apply widget :match "red")) + (should (widget-apply widget :match "#fa3")) + (should (widget-apply widget :match "#ff0000")) + (should (widget-apply widget :match "#111222333")) + (should (widget-apply widget :match "#111122223333")) + (should-not (widget-apply widget :match "someundefinedcolorihope")) + (should-not (widget-apply widget :match "#11223")))) + ;;; wid-edit-tests.el ends here From f2f06b020904e7d53af1e686a441887f24fb589c Mon Sep 17 00:00:00 2001 From: Mauro Aranda Date: Tue, 19 Jan 2021 09:25:00 -0300 Subject: [PATCH 038/133] Fix list-colors-print handling of callback arg * lisp/facemenu.el (list-colors-print): Keeping backward-compatibility, don't fail when passed a closure object as CALLBACK. (Bug#45831) --- lisp/facemenu.el | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/lisp/facemenu.el b/lisp/facemenu.el index 2609397b0d9..dc5f8f46aba 100644 --- a/lisp/facemenu.el +++ b/lisp/facemenu.el @@ -606,9 +606,14 @@ color. The function should accept a single argument, the color name." (defun list-colors-print (list &optional callback) (let ((callback-fn - (if callback - `(lambda (button) - (funcall ,callback (button-get button 'color-name)))))) + ;; Expect CALLBACK to be a function, but allow it to be a form that + ;; evaluates to a function, for backward-compatibility. (Bug#45831) + (cond ((functionp callback) + (lambda (button) + (funcall callback (button-get button 'color-name)))) + (callback + `(lambda (button) + (funcall ,callback (button-get button 'color-name))))))) (dolist (color list) (if (consp color) (if (cdr color) From 91a6e1933722439cb81ed58d655a8c62ee05009f Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Tue, 19 Jan 2021 14:12:22 +0100 Subject: [PATCH 039/133] Handle also test/lib-src directory * test/Makefile.in (SUBDIRS): Add lib-src. * test/README: Add predefined selectors. * test/file-organization.org: Mention test/lib-src directory. --- test/Makefile.in | 2 +- test/README | 4 +++- test/file-organization.org | 16 +++++++++------- 3 files changed, 13 insertions(+), 9 deletions(-) diff --git a/test/Makefile.in b/test/Makefile.in index 4ca43c8c443..c5e86df3761 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -247,7 +247,7 @@ endef $(foreach test,${TESTS},$(eval $(call test_template,${test}))) ## Get the tests for only a specific directory. -SUBDIRS = $(sort $(shell find lisp src -type d ! -path "*resources*" -print)) +SUBDIRS = $(sort $(shell find lib-src lisp src -type d ! -path "*resources*" -print)) define subdir_template .PHONY: check-$(subst /,-,$(1)) diff --git a/test/README b/test/README index 58f5f38bec6..5f3c10adbe1 100644 --- a/test/README +++ b/test/README @@ -60,7 +60,9 @@ https://www.gnu.org/software/emacs/manual/html_node/ert/Test-Selectors.html You could use predefined selectors of the Makefile. "make SELECTOR='$(SELECTOR_DEFAULT)'" runs all tests for .el -except the tests tagged as expensive or unstable. +except the tests tagged as expensive or unstable. Other predefined +selectors are $(SELECTOR_EXPENSIVE) (run all tests except unstable +ones) and $(SELECTOR_ALL) (run all tests). If your test file contains the tests "test-foo", "test2-foo" and "test-foo-remote", and you want to run only the former two tests, you diff --git a/test/file-organization.org b/test/file-organization.org index efc354529c5..7cf5b88d6d0 100644 --- a/test/file-organization.org +++ b/test/file-organization.org @@ -17,13 +17,15 @@ Sub-directories are in many cases themed after packages (~gnus~, ~org~, ~calc~), related functionality (~net~, ~emacs-lisp~, ~progmodes~) or status (~obsolete~). -C source is stored in the ~src~ directory, which is flat. +C source is stored in the ~src~ directory, which is flat. Source for +utility programs is stored in the ~lib-src~ directory. ** Test Files Automated tests should be stored in the ~test/lisp~ directory for -tests of functionality implemented in Lisp, and in the ~test/src~ -directory for functionality implemented in C. Tests should reflect +tests of functionality implemented in Lisp, in the ~test/src~ +directory for functionality implemented in C, and in the +~test/lib-src~ directory for utility programs. Tests should reflect the directory structure of the source tree; so tests for files in the ~lisp/emacs-lisp~ source directory should reside in the ~test/lisp/emacs-lisp~ directory. @@ -36,10 +38,10 @@ files of any name which are themselves placed in a directory named after the feature with ~-tests~ appended, such as ~/test/lisp/emacs-lisp/eieio-tests~ -Similarly, features implemented in C should reside in ~/test/src~ and -be named after the C file with ~-tests.el~ added to the base-name of -the tested source file. Thus, tests for ~src/fileio.c~ should be in -~test/src/fileio-tests.el~. +Similarly, tests of features implemented in C should reside in +~/test/src~ or in ~test/lib-src~ and be named after the C file with +~-tests.el~ added to the base-name of the tested source file. Thus, +tests for ~src/fileio.c~ should be in ~test/src/fileio-tests.el~. There are also some test materials that cannot be run automatically (i.e. via ert). These should be placed in ~/test/manual~; they are From e544b863433e37fbd2555d3b48da3a88a6307ddb Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 19 Jan 2021 15:54:40 +0100 Subject: [PATCH 040/133] Don't stop Gnus startup on password failures * lisp/gnus/nntp.el (nntp-send-authinfo): Don't signal an `nntp-authinfo-rejected' error, because that will stop Gnus startup (bug#45855). Instead signal an error that will be caught higher up. --- lisp/gnus/nntp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index 7e10e151a4d..c2bb960f945 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -1209,7 +1209,7 @@ If SEND-IF-FORCE, only send authinfo to the server if the (read-passwd (format "NNTP (%s@%s) password: " user nntp-address))))))) (if (not result) - (signal 'nntp-authinfo-rejected "Password rejected") + (error "Password rejected") result)))))) ;;; Internal functions. From 3b731b123d11e4c13e2dd16b336b146081f94a30 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 19 Jan 2021 16:07:54 +0100 Subject: [PATCH 041/133] Fix slow abbrev expansion in `message-mode' in some circumstances * lisp/gnus/message.el (message--syntax-propertize): Use the correct Message mode syntax table to avoid having `message-cite-prefix-regexp' trigger very heavy backtracing when called from an abbrev context (which defines "_" as a word constituent) (bug#45944). --- lisp/gnus/message.el | 33 +++++++++++++++++---------------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 50e02187484..b22b4543e71 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -3057,22 +3057,23 @@ See also `message-forbidden-properties'." (defun message--syntax-propertize (beg end) "Syntax-propertize certain message text specially." - (let ((citation-regexp (concat "^" message-cite-prefix-regexp ".*$")) - (smiley-regexp (regexp-opt message-smileys))) - (goto-char beg) - (while (search-forward-regexp citation-regexp - end 'noerror) - (let ((start (match-beginning 0)) - (end (match-end 0))) - (add-text-properties start (1+ start) - `(syntax-table ,(string-to-syntax "<"))) - (add-text-properties end (min (1+ end) (point-max)) - `(syntax-table ,(string-to-syntax ">"))))) - (goto-char beg) - (while (search-forward-regexp smiley-regexp - end 'noerror) - (add-text-properties (match-beginning 0) (match-end 0) - `(syntax-table ,(string-to-syntax ".")))))) + (with-syntax-table message-mode-syntax-table + (let ((citation-regexp (concat "^" message-cite-prefix-regexp ".*$")) + (smiley-regexp (regexp-opt message-smileys))) + (goto-char beg) + (while (search-forward-regexp citation-regexp + end 'noerror) + (let ((start (match-beginning 0)) + (end (match-end 0))) + (add-text-properties start (1+ start) + `(syntax-table ,(string-to-syntax "<"))) + (add-text-properties end (min (1+ end) (point-max)) + `(syntax-table ,(string-to-syntax ">"))))) + (goto-char beg) + (while (search-forward-regexp smiley-regexp + end 'noerror) + (add-text-properties (match-beginning 0) (match-end 0) + `(syntax-table ,(string-to-syntax "."))))))) ;;;###autoload (define-derived-mode message-mode text-mode "Message" From 297edbebec5eaf2924f65bd2015b65d16cbf9254 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Tue, 19 Jan 2021 11:43:25 +0100 Subject: [PATCH 042/133] Missing dynamic variable declarations in Calc * lisp/calc/calc-embed.el (calc-embedded-set-modes): Prevent the-language and the-display-just from being lexically bound here, because they may be assigned using 'set'. --- lisp/calc/calc-embed.el | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lisp/calc/calc-embed.el b/lisp/calc/calc-embed.el index ea79bfa69a0..fda0b4bbedb 100644 --- a/lisp/calc/calc-embed.el +++ b/lisp/calc/calc-embed.el @@ -651,6 +651,8 @@ The command \\[yank] can retrieve it from there." (defvar calc-embed-prev-modes) (defun calc-embedded-set-modes (gmodes modes local-modes &optional temp) + (defvar the-language) + (defvar the-display-just) (let ((the-language (calc-embedded-language)) (the-display-just (calc-embedded-justify)) (v gmodes) From 5369b69bd86ee6d9565a82842cbeb37749cd5a6b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Tue, 19 Jan 2021 11:55:13 +0100 Subject: [PATCH 043/133] Parse square root sign in embedded Calc mode MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * lisp/calc/calc-lang.el (math-read-big-rec): Recognise √ since it may be used in Big mode. --- lisp/calc/calc-lang.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/calc/calc-lang.el b/lisp/calc/calc-lang.el index b4b2d4cc4f4..0117f449dd5 100644 --- a/lisp/calc/calc-lang.el +++ b/lisp/calc/calc-lang.el @@ -2181,7 +2181,7 @@ order to Calc's." v math-read-big-baseline)) ;; Small radical sign. - ((and (= other-char ?V) + ((and (memq other-char '(?V ?√)) (= (math-read-big-char (1+ math-rb-h1) (1- v)) ?\_)) (setq h (1+ math-rb-h1)) (math-read-big-emptyp math-rb-h1 math-rb-v1 h (1- v) nil t) From 3c584438552f8d01651d7b9358eae5ce8da81fae Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 19 Jan 2021 17:26:01 +0100 Subject: [PATCH 044/133] Only show "2x entries" i vc log buffers if needed * lisp/vc/vc.el (vc-print-log-setup-buttons): Only show the "more" buttons if we got more or equal to the number of entries we asked for (bug#18959). --- lisp/vc/vc.el | 42 +++++++++++++++++++++++++++--------------- 1 file changed, 27 insertions(+), 15 deletions(-) diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 6c96d8ca7c4..bc9f11202b1 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -2392,6 +2392,7 @@ If it contains `file', show short logs for files. Not all VC backends support short logs!") (defvar log-view-vc-fileset) +(defvar log-view-message-re) (defun vc-print-log-setup-buttons (working-revision is-start-revision limit pl-return) "Insert at the end of the current buffer buttons to show more log entries. @@ -2401,21 +2402,32 @@ Does nothing if IS-START-REVISION is non-nil, or if LIMIT is nil, or if PL-RETURN is `limit-unsupported'." (when (and limit (not (eq 'limit-unsupported pl-return)) (not is-start-revision)) - (goto-char (point-max)) - (insert "\n") - (insert-text-button "Show 2X entries" - 'action (lambda (&rest _ignore) - (vc-print-log-internal - log-view-vc-backend log-view-vc-fileset - working-revision nil (* 2 limit))) - 'help-echo "Show the log again, and double the number of log entries shown") - (insert " ") - (insert-text-button "Show unlimited entries" - 'action (lambda (&rest _ignore) - (vc-print-log-internal - log-view-vc-backend log-view-vc-fileset - working-revision nil nil)) - 'help-echo "Show the log again, including all entries"))) + (let ((entries 0)) + (goto-char (point-min)) + (while (re-search-forward log-view-message-re nil t) + (cl-incf entries)) + ;; If we got fewer entries than we asked for, then displaying + ;; the "more" buttons isn't useful. + (when (>= entries limit) + (goto-char (point-max)) + (insert "\n") + (insert-text-button + "Show 2X entries" + 'action (lambda (&rest _ignore) + (vc-print-log-internal + log-view-vc-backend log-view-vc-fileset + working-revision nil (* 2 limit))) + 'help-echo + "Show the log again, and double the number of log entries shown") + (insert " ") + (insert-text-button + "Show unlimited entries" + 'action (lambda (&rest _ignore) + (vc-print-log-internal + log-view-vc-backend log-view-vc-fileset + working-revision nil nil)) + 'help-echo "Show the log again, including all entries") + (insert "\n"))))) (defun vc-print-log-internal (backend files working-revision &optional is-start-revision limit type) From deb90c893d3a0094db77753d8a795716784bbc7e Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 19 Jan 2021 12:10:48 -0500 Subject: [PATCH 045/133] * lisp/startup.el: Fix bug#45857, bug#30994, and bug#45913. (command-line): Don't re-evaluate the `custom-delayed-init-variables` a second time after reading the `early-init.el` file. (x-apply-session-resources): Set `blink-cursor-mode` rather than `no-blinking-cursor`. * lisp/frame.el (blink-cursor-start): Turn `blink-cursor-mode` off if `blink-cursor-mode` was set to nil. (blink-cursor-mode): Default to it being enabled regardless of `window-system`. * lisp/custom.el (custom-initialize-delay): Fox docstring now that autoload.el preserves the `:initialize` info. --- etc/NEWS | 4 ++++ lisp/cus-start.el | 2 +- lisp/custom.el | 12 +----------- lisp/frame.el | 16 +++++++++------- lisp/startup.el | 11 +++-------- 5 files changed, 18 insertions(+), 27 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 8fc5f3e046c..7a012b48912 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -326,6 +326,10 @@ the buffer cycles the whole buffer between "only top-level headings", * Changes in Specialized Modes and Packages in Emacs 28.1 +** 'blink-cursor-mode' is now enabled by default regardless of the UI. +It used to be enabled when Emacs is started in GUI mode but not when started +in text mode. The cursor still only actually blinks in GUI frames. + ** pcase +++ *** The `pred` pattern can now take the form (pred (not FUN)). diff --git a/lisp/cus-start.el b/lisp/cus-start.el index 0293d34d1cd..27fdb723441 100644 --- a/lisp/cus-start.el +++ b/lisp/cus-start.el @@ -880,7 +880,7 @@ since it could result in memory overflow and make Emacs crash." ;; Don't re-add to custom-delayed-init-variables post-startup. (unless after-init-time ;; Note this is the _only_ initialize property we handle. - (if (eq (cadr (memq :initialize rest)) 'custom-initialize-delay) + (if (eq (cadr (memq :initialize rest)) #'custom-initialize-delay) ;; These vars are defined early and should hence be initialized ;; early, even if this file happens to be loaded late. so add them ;; to the end of custom-delayed-init-variables. Otherwise, diff --git a/lisp/custom.el b/lisp/custom.el index 58ecd0439ad..5e354c4c595 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -125,17 +125,7 @@ This is used in files that are preloaded (or for autoloaded variables), so that the initialization is done in the run-time context rather than the build-time context. This also has the side-effect that the (delayed) initialization is performed with -the :set function. - -For variables in preloaded files, you can simply use this -function for the :initialize property. For autoloaded variables, -you will also need to add an autoload stanza calling this -function, and another one setting the standard-value property. -Or you can wrap the defcustom in a progn, to force the autoloader -to include all of it." ; see eg vc-sccs-search-project-dir - ;; No longer true: - ;; "See `send-mail-function' in sendmail.el for an example." - +the :set function." ;; Defvar it so as to mark it special, etc (bug#25770). (internal--define-uninitialized-variable symbol) diff --git a/lisp/frame.el b/lisp/frame.el index e2d7f21a498..06aab269ddd 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -2552,13 +2552,15 @@ Use 0 or negative value to blink forever." This starts the timer `blink-cursor-timer', which makes the cursor blink if appropriate. It also arranges to cancel that timer when the next command starts, by installing a pre-command hook." - (when (null blink-cursor-timer) + (cond + ((null blink-cursor-mode) (blink-cursor-mode -1)) + ((null blink-cursor-timer) ;; Set up the timer first, so that if this signals an error, ;; blink-cursor-end is not added to pre-command-hook. (setq blink-cursor-blinks-done 1) (blink-cursor--start-timer) (add-hook 'pre-command-hook #'blink-cursor-end) - (internal-show-cursor nil nil))) + (internal-show-cursor nil nil)))) (defun blink-cursor-timer-function () "Timer function of timer `blink-cursor-timer'." @@ -2615,7 +2617,7 @@ stopped by `blink-cursor-suspend'. Internally calls `blink-cursor--should-blink' and returns its result." (let ((should-blink (blink-cursor--should-blink))) (when (and should-blink (not blink-cursor-idle-timer)) - (remove-hook 'post-command-hook 'blink-cursor-check) + (remove-hook 'post-command-hook #'blink-cursor-check) (blink-cursor--start-idle-timer)) should-blink)) @@ -2637,16 +2639,16 @@ This command is effective only on graphical frames. On text-only terminals, cursor blinking is controlled by the terminal." :init-value (not (or noninteractive no-blinking-cursor - (eq system-type 'ms-dos) - (not (display-blink-cursor-p)))) - :initialize 'custom-initialize-delay + (eq system-type 'ms-dos))) + :initialize #'custom-initialize-delay :group 'cursor :global t (blink-cursor-suspend) (remove-hook 'after-delete-frame-functions #'blink-cursor--rescan-frames) (remove-function after-focus-change-function #'blink-cursor--rescan-frames) (when blink-cursor-mode - (add-function :after after-focus-change-function #'blink-cursor--rescan-frames) + (add-function :after after-focus-change-function + #'blink-cursor--rescan-frames) (add-hook 'after-delete-frame-functions #'blink-cursor--rescan-frames) (blink-cursor-check))) diff --git a/lisp/startup.el b/lisp/startup.el index 552802a38d7..7011fbf4583 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -1172,6 +1172,7 @@ please check its value") ;; are dependencies between them. (nreverse custom-delayed-init-variables)) (mapc #'custom-reevaluate-setting custom-delayed-init-variables) + (setq custom-delayed-init-variables nil) ;; Warn for invalid user name. (when init-file-user @@ -1301,12 +1302,6 @@ please check its value") (startup--setup-quote-display) (setq internal--text-quoting-flag t)) - ;; Re-evaluate again the predefined variables whose initial value - ;; depends on the runtime context, in case some of them depend on - ;; the window-system features. Example: blink-cursor-mode. - (mapc #'custom-reevaluate-setting custom-delayed-init-variables) - (setq custom-delayed-init-variables nil) - (normal-erase-is-backspace-setup-frame) ;; Register default TTY colors for the case the terminal hasn't a @@ -1487,13 +1482,13 @@ to reading the init file), or afterwards when the user first opens a graphical frame. This can set the values of `menu-bar-mode', `tool-bar-mode', -`tab-bar-mode', and `no-blinking-cursor', as well as the `cursor' face. +`tab-bar-mode', and `blink-cursor-mode', as well as the `cursor' face. Changed settings will be marked as \"CHANGED outside of Customize\"." (let ((no-vals '("no" "off" "false" "0")) (settings '(("menuBar" "MenuBar" menu-bar-mode nil) ("toolBar" "ToolBar" tool-bar-mode nil) ("scrollBar" "ScrollBar" scroll-bar-mode nil) - ("cursorBlink" "CursorBlink" no-blinking-cursor t)))) + ("cursorBlink" "CursorBlink" blink-cursor-mode nil)))) (dolist (x settings) (if (member (x-get-resource (nth 0 x) (nth 1 x)) no-vals) (set (nth 2 x) (nth 3 x))))) From f3b9d5b3155fac293d46e55827a1e0ce07afb0ae Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Tue, 19 Jan 2021 18:45:55 +0100 Subject: [PATCH 046/133] Some Tramp fixes, resulting from test campaign * doc/misc/tramp.texi (Remote shell setup): Clarifications for `tramp-actions-before-shell' example. * lisp/net/tramp-sh.el (tramp-sh-handle-insert-directory): Do not expand FILENAME explicitely. (tramp-open-shell): Add "-i" for interactive shells. * test/lisp/net/tramp-tests.el (tramp-test07-file-exists-p) (tramp-test14-delete-directory) (tramp-test43-asynchronous-requests): Skip for MS windows. --- doc/misc/tramp.texi | 8 ++++++-- lisp/net/tramp-sh.el | 8 +++++--- test/lisp/net/tramp-tests.el | 22 +++++++++++----------- 3 files changed, 22 insertions(+), 16 deletions(-) diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 2c4b792cc21..e9ffd6a8c43 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -2369,8 +2369,7 @@ that can identify such questions using @lisp @group (defconst my-tramp-prompt-regexp - (concat (regexp-opt '("Enter the birth date of your mother:") t) - "\\s-*") + "Enter the birth date of your mother:\\s-*" "Regular expression matching my login prompt question.") @end group @@ -2389,6 +2388,11 @@ that can identify such questions using @end group @end lisp +The regular expressions used in @code{tramp-actions-before-shell} must +match the end of the connection buffer. Due to performance reasons, +this search starts at the end of the buffer, and it is limited to 256 +characters backwards. + @item Conflicting names for users and variables in @file{.profile} diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index e8ee372cb25..618a9fb9d02 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -2608,12 +2608,11 @@ The method used must be an out-of-band method." (defun tramp-sh-handle-insert-directory (filename switches &optional wildcard full-directory-p) "Like `insert-directory' for Tramp files." - (setq filename (expand-file-name filename)) (unless switches (setq switches "")) ;; Check, whether directory is accessible. (unless wildcard (access-file filename "Reading directory")) - (with-parsed-tramp-file-name filename nil + (with-parsed-tramp-file-name (expand-file-name filename) nil (if (and (featurep 'ls-lisp) (not (symbol-value 'ls-lisp-use-insert-directory-program))) (tramp-handle-insert-directory @@ -4306,11 +4305,14 @@ file exists and nonzero exit status otherwise." ;; ensure they have the correct values when the shell starts, not ;; just processes run within the shell. (Which processes include ;; our initial probes to ensure the remote shell is usable.) + ;; For the time being, we assume that all shells interpret -i as + ;; interactive shell. Must be the last argument, because (for + ;; example) bash expects long options first. (tramp-send-command vec (format (concat "exec env TERM='%s' INSIDE_EMACS='%s,tramp:%s' " - "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s") + "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s -i") tramp-terminal-type (or (getenv "INSIDE_EMACS") emacs-version) tramp-version (or (getenv-internal "ENV" tramp-remote-process-environment) "") diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index ef0968a3385..5deee658296 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2272,8 +2272,8 @@ This checks also `file-name-as-directory', `file-name-directory', (delete-file tmp-name) (should-not (file-exists-p tmp-name)) - ;; Trashing files doesn't work for crypted remote files. - (unless (tramp--test-crypt-p) + ;; Trashing files doesn't work on MS Windows, and for crypted remote files. + (unless (or (tramp--test-windows-nt-p) (tramp--test-crypt-p)) (let ((trash-directory (tramp--test-make-temp-name 'local quoted)) (delete-by-moving-to-trash t)) (make-directory trash-directory) @@ -2786,9 +2786,9 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (should-not (file-directory-p tmp-name1)) ;; Trashing directories works only since Emacs 27.1. It doesn't - ;; work for crypted remote directories and for ange-ftp. - (when (and (not (tramp--test-crypt-p)) (not (tramp--test-ftp-p)) - (tramp--test-emacs27-p)) + ;; work on MS Windows, for crypted remote directories and for ange-ftp. + (when (and (not (tramp--test-windows-nt-p)) (not (tramp--test-crypt-p)) + (not (tramp--test-ftp-p)) (tramp--test-emacs27-p)) (let ((trash-directory (tramp--test-make-temp-name 'local quoted)) (delete-by-moving-to-trash t)) (make-directory trash-directory) @@ -6349,6 +6349,7 @@ process sentinels. They shall not disturb each other." (tramp--test-sh-p))) (skip-unless (not (tramp--test-crypt-p))) (skip-unless (not (tramp--test-docker-p))) + (skip-unless (not (tramp--test-windows-nt-p))) (with-timeout (tramp--test-asynchronous-requests-timeout (tramp--test-timeout-handler)) @@ -6358,12 +6359,11 @@ process sentinels. They shall not disturb each other." (shell-file-name (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh")) ;; It doesn't work on w32 systems. (watchdog - (unless (tramp--test-windows-nt-p) - (start-process-shell-command - "*watchdog*" nil - (format - "sleep %d; kill -USR1 %d" - tramp--test-asynchronous-requests-timeout (emacs-pid))))) + (start-process-shell-command + "*watchdog*" nil + (format + "sleep %d; kill -USR1 %d" + tramp--test-asynchronous-requests-timeout (emacs-pid)))) (tmp-name (tramp--test-make-temp-name)) (default-directory tmp-name) ;; Do not cache Tramp properties. From 039ab602cbf877eef1b18c6ef8b36dcf52ece5c4 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 19 Jan 2021 12:53:42 -0500 Subject: [PATCH 047/133] * etc/NEWS.19: Add entry for `indent-line-to` * lisp/version.el (emacs-major-version, emacs-minor-version): Remove redundant version info already displayed by `C-h o`. --- etc/NEWS.19 | 2 ++ lisp/version.el | 6 ++---- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/etc/NEWS.19 b/etc/NEWS.19 index 43235e0e154..f2cef62971b 100644 --- a/etc/NEWS.19 +++ b/etc/NEWS.19 @@ -2824,6 +2824,8 @@ the text of the region according to the new value. the fill-column has been exceeded; the function can determine on its own whether filling (or justification) is necessary. +**** New helper function 'indent-line-to' + ** Processes *** process-tty-name is a new function that returns the name of the diff --git a/lisp/version.el b/lisp/version.el index fcfc2f8b806..3a3093fdd4a 100644 --- a/lisp/version.el +++ b/lisp/version.el @@ -29,14 +29,12 @@ (defconst emacs-major-version (progn (string-match "^[0-9]+" emacs-version) (string-to-number (match-string 0 emacs-version))) - "Major version number of this version of Emacs. -This variable first existed in version 19.23.") + "Major version number of this version of Emacs.") (defconst emacs-minor-version (progn (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version) (string-to-number (match-string 1 emacs-version))) - "Minor version number of this version of Emacs. -This variable first existed in version 19.23.") + "Minor version number of this version of Emacs.") (defconst emacs-build-system (system-name) "Name of the system on which Emacs was built, or nil if not available.") From bfa140d7cf82ed640d033391cde505ab020de0f2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Sat, 16 Jan 2021 17:30:57 +0100 Subject: [PATCH 048/133] Calc: use Unicode brackets in Big mode when available (bug#45917) * lisp/calc/calccomp.el (math--big-bracket-alist) (math--big-bracket, math--comp-bracket, math--comp-round-bracket): New. (math-compose-expr, math-compose-log, math-compose-log10) (math-compose-choose, math-compose-integ, math-compose-sum) (math-compose-prod): Use big brackets when available. --- lisp/calc/calccomp.el | 247 +++++++++++++++++++++++++++--------------- 1 file changed, 162 insertions(+), 85 deletions(-) diff --git a/lisp/calc/calccomp.el b/lisp/calc/calccomp.el index 07e70cad0a8..5f38ee71c78 100644 --- a/lisp/calc/calccomp.el +++ b/lisp/calc/calccomp.el @@ -138,19 +138,19 @@ (math-format-number (nth 2 aa)))))) (if (= calc-number-radix 10) c - (list 'horiz "(" c - (list 'subscr ")" - (int-to-string calc-number-radix))))) + (list 'subscr (math--comp-round-bracket c) + (int-to-string calc-number-radix)))) (math-format-number a))) (if (not (eq calc-language 'big)) (math-format-number a prec) (if (memq (car-safe a) '(cplx polar)) (if (math-zerop (nth 2 a)) (math-compose-expr (nth 1 a) prec) - (list 'horiz "(" - (math-compose-expr (nth 1 a) 0) - (if (eq (car a) 'cplx) ", " "; ") - (math-compose-expr (nth 2 a) 0) ")")) + (math--comp-round-bracket + (list 'horiz + (math-compose-expr (nth 1 a) 0) + (if (eq (car a) 'cplx) ", " "; ") + (math-compose-expr (nth 2 a) 0)))) (if (or (= calc-number-radix 10) (not (Math-realp a)) (and calc-group-digits @@ -340,12 +340,13 @@ (funcall spfn a prec) (math-compose-var a))))) ((eq (car a) 'intv) - (list 'horiz - (if (memq (nth 1 a) '(0 1)) "(" "[") - (math-compose-expr (nth 2 a) 0) - " .. " - (math-compose-expr (nth 3 a) 0) - (if (memq (nth 1 a) '(0 2)) ")" "]"))) + (math--comp-bracket + (if (memq (nth 1 a) '(0 1)) ?\( ?\[) + (if (memq (nth 1 a) '(0 2)) ?\) ?\]) + (list 'horiz + (math-compose-expr (nth 2 a) 0) + " .. " + (math-compose-expr (nth 3 a) 0)))) ((eq (car a) 'date) (if (eq (car calc-date-format) 'X) (math-format-date a) @@ -377,7 +378,7 @@ (and (eq (car-safe (nth 1 a)) 'cplx) (math-negp (nth 1 (nth 1 a))) (eq (nth 2 (nth 1 a)) 0))) - (list 'horiz "(" (math-compose-expr (nth 1 a) 0) ")") + (math--comp-round-bracket (math-compose-expr (nth 1 a) 0)) (math-compose-expr (nth 1 a) 201)) (let ((calc-language 'flat) (calc-number-radix 10) @@ -444,7 +445,7 @@ (if (> prec (nth 2 a)) (if (setq spfn (get calc-language 'math-big-parens)) (list 'horiz (car spfn) c (cdr spfn)) - (list 'horiz "(" c ")")) + (math--comp-round-bracket c)) c))) ((and (eq (car a) 'calcFunc-choriz) (not (eq calc-language 'unform)) @@ -612,7 +613,7 @@ (list 'horiz "{left ( " (math-compose-expr a -1) " right )}"))) - (list 'horiz "(" (math-compose-expr a 0) ")")))) + (math--comp-round-bracket (math-compose-expr a 0))))) ((and (memq calc-language '(tex latex)) (memq (car a) '(/ calcFunc-choose calcFunc-evalto)) (>= prec 0)) @@ -638,7 +639,7 @@ (rhs (math-compose-expr (nth 2 a) (nth 3 op) (eq (nth 1 op) '/)))) (and (equal (car op) "^") (eq (math-comp-first-char lhs) ?-) - (setq lhs (list 'horiz "(" lhs ")"))) + (setq lhs (math--comp-round-bracket lhs))) (and (memq calc-language '(tex latex)) (or (equal (car op) "^") (equal (car op) "_")) (not (and (stringp rhs) (= (length rhs) 1))) @@ -721,7 +722,7 @@ (list 'horiz "{left ( " (math-compose-expr a -1) " right )}"))) - (list 'horiz "(" (math-compose-expr a 0) ")")))) + (math--comp-round-bracket (math-compose-expr a 0))))) (t (let ((lhs (math-compose-expr (nth 1 a) (nth 2 op)))) (list 'horiz @@ -759,7 +760,7 @@ (list 'horiz "{left ( " (math-compose-expr a -1) " right )}"))) - (list 'horiz "(" (math-compose-expr a 0) ")")))) + (math--comp-round-bracket (math-compose-expr a 0))))) (t (let ((rhs (math-compose-expr (nth 1 a) (nth 3 op)))) (list 'horiz @@ -966,6 +967,69 @@ (and (memq (car a) '(^ calcFunc-subscr)) (math-tex-expr-is-flat (nth 1 a))))) +;; FIXME: maybe try box drawing chars if big bracket chars are unavailable, +;; like ┌ ┐n +;; │a + b│ ┌ a + b ┐n +;; │-----│ or │ ----- │ ? +;; │ c │ └ c ┘ +;; └ ┘ +;; They are more common than the chars below, but look a bit square. +;; Rounded corners exist but are less commonly available. + +(defconst math--big-bracket-alist + '((?\( . (?⎛ ?⎝ ?⎜)) + (?\) . (?⎞ ?⎠ ?⎟)) + (?\[ . (?⎡ ?⎣ ?⎢)) + (?\] . (?⎤ ?⎦ ?⎥)) + (?\{ . (?⎧ ?⎩ ?⎪ ?⎨)) + (?\} . (?⎫ ?⎭ ?⎪ ?⎬))) + "Alist mapping bracket chars to (UPPER LOWER EXTENSION MIDPIECE). +Not all brackets have midpieces.") + +(defun math--big-bracket (bracket-char height baseline) + "Composition for BRACKET-CHAR of HEIGHT with BASELINE." + (if (<= height 1) + (char-to-string bracket-char) + (let ((pieces (cdr (assq bracket-char math--big-bracket-alist)))) + (if (memq nil (mapcar #'char-displayable-p pieces)) + (char-to-string bracket-char) + (let* ((upper (nth 0 pieces)) + (lower (nth 1 pieces)) + (extension (nth 2 pieces)) + (midpiece (nth 3 pieces))) + (cons 'vleft ; alignment doesn't matter; width is 1 char + (cons baseline + (mapcar + #'char-to-string + (append + (list upper) + (if midpiece + (let ((lower-ext (/ (- height 3) 2))) + (append + (make-list (- height 3 lower-ext) extension) + (list midpiece) + (make-list lower-ext extension))) + (make-list (- height 2) extension)) + (list lower)))))))))) + +(defun math--comp-bracket (left-bracket right-bracket comp) + "Put the composition COMP inside LEFT-BRACKET and RIGHT-BRACKET." + (if (eq calc-language 'big) + (let ((height (math-comp-height comp)) + (baseline (1- (math-comp-ascent comp)))) + (list 'horiz + (math--big-bracket left-bracket height baseline) + comp + (math--big-bracket right-bracket height baseline))) + (list 'horiz + (char-to-string left-bracket) + comp + (char-to-string right-bracket)))) + +(defun math--comp-round-bracket (comp) + "Put the composition COMP inside plain brackets." + (math--comp-bracket ?\( ?\) comp)) + (put 'calcFunc-log 'math-compose-big #'math-compose-log) (defun math-compose-log (a _prec) (and (= (length a) 3) @@ -973,18 +1037,14 @@ (list 'subscr "log" (let ((calc-language 'flat)) (math-compose-expr (nth 2 a) 1000))) - "(" - (math-compose-expr (nth 1 a) 1000) - ")"))) + (math--comp-round-bracket (math-compose-expr (nth 1 a) 1000))))) (put 'calcFunc-log10 'math-compose-big #'math-compose-log10) (defun math-compose-log10 (a _prec) (and (= (length a) 2) (list 'horiz - (list 'subscr "log" "10") - "(" - (math-compose-expr (nth 1 a) 1000) - ")"))) + (list 'subscr "log" "10") + (math--comp-round-bracket (math-compose-expr (nth 1 a) 1000))))) (put 'calcFunc-deriv 'math-compose-big #'math-compose-deriv) (put 'calcFunc-tderiv 'math-compose-big #'math-compose-deriv) @@ -1027,12 +1087,9 @@ (defun math-compose-choose (a _prec) (let ((a1 (math-compose-expr (nth 1 a) 0)) (a2 (math-compose-expr (nth 2 a) 0))) - (list 'horiz - "(" - (list 'vcent - (math-comp-height a1) - a1 " " a2) - ")"))) + (math--comp-round-bracket (list 'vcent + (+ (math-comp-height a1)) + a1 " " a2)))) (put 'calcFunc-integ 'math-compose-big #'math-compose-integ) (defun math-compose-integ (a prec) @@ -1052,9 +1109,12 @@ "d%s" (nth 1 (nth 2 a))))) (nth 1 a)) 185)) - (calc-language 'flat) - (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0))) - (high (and (nth 4 a) (math-compose-expr (nth 4 a) 0))) + (low (and (nth 3 a) + (let ((calc-language 'flat)) + (math-compose-expr (nth 3 a) 0)))) + (high (and (nth 4 a) + (let ((calc-language 'flat)) + (math-compose-expr (nth 4 a) 0)))) ;; Check if we have Unicode integral top/bottom parts. (fancy (and (char-displayable-p ?⌠) (char-displayable-p ?⌡))) @@ -1066,40 +1126,47 @@ ((char-displayable-p ?│) "│ ") ;; U+007C VERTICAL LINE (t "| ")))) - (list 'horiz - (if parens "(" "") - (append (list 'vcent (if fancy - (if high 2 1) - (if high 3 2))) - (and high (list (if fancy - (list 'horiz high " ") - (list 'horiz " " high)))) - (if fancy - (list "⌠ " fancy-stem "⌡ ") - '(" /" - " | " - " | " - " | " - "/ ")) - (and low (list (if fancy - (list 'horiz low " ") - (list 'horiz low " "))))) - expr - (if over - "" - (list 'horiz " d" var)) - (if parens ")" ""))))) + (let ((comp + (list 'horiz + (append (list 'vcent (if fancy + (if high 2 1) + (if high 3 2))) + (and high (list (if fancy + (list 'horiz high " ") + (list 'horiz " " high)))) + (if fancy + (list "⌠ " fancy-stem "⌡ ") + '(" /" + " | " + " | " + " | " + "/ ")) + (and low (list (if fancy + (list 'horiz low " ") + (list 'horiz low " "))))) + expr + (if over + "" + (list 'horiz " d" var))))) + (if parens + (math--comp-round-bracket comp) + comp))))) (put 'calcFunc-sum 'math-compose-big #'math-compose-sum) (defun math-compose-sum (a prec) (and (memq (length a) '(3 5 6)) (let* ((expr (math-compose-expr (nth 1 a) 185)) - (calc-language 'flat) - (var (math-compose-expr (nth 2 a) 0)) - (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0))) - (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0)))) - (list 'horiz - (if (memq prec '(180 201)) "(" "") + (var + (let ((calc-language 'flat)) + (math-compose-expr (nth 2 a) 0))) + (low (and (nth 3 a) + (let ((calc-language 'flat)) + (math-compose-expr (nth 3 a) 0)))) + (high (and (nth 4 a) + (let ((calc-language 'flat)) + (math-compose-vector (nthcdr 4 a) ", " 0)))) + (comp + (list 'horiz (append (list 'vcent (if high 3 2)) (and high (list high)) '("---- " @@ -1112,32 +1179,42 @@ (list var))) (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod)) " " "") - expr - (if (memq prec '(180 201)) ")" ""))))) + expr))) + (if (memq prec '(180 201)) + (math--comp-round-bracket comp) + comp)))) (put 'calcFunc-prod 'math-compose-big #'math-compose-prod) (defun math-compose-prod (a prec) (and (memq (length a) '(3 5 6)) (let* ((expr (math-compose-expr (nth 1 a) 198)) - (calc-language 'flat) - (var (math-compose-expr (nth 2 a) 0)) - (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0))) - (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0)))) - (list 'horiz - (if (memq prec '(196 201)) "(" "") - (append (list 'vcent (if high 3 2)) - (and high (list high)) - '("----- " - " | | " - " | | " - " | | ") - (if low - (list (list 'horiz var " = " low)) - (list var))) - (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod)) - " " "") - expr - (if (memq prec '(196 201)) ")" ""))))) + (var + (let ((calc-language 'flat)) + (math-compose-expr (nth 2 a) 0))) + (low (and (nth 3 a) + (let ((calc-language 'flat)) + (math-compose-expr (nth 3 a) 0)))) + (high (and (nth 4 a) + (let ((calc-language 'flat)) + (math-compose-vector (nthcdr 4 a) ", " 0)))) + (comp + (list 'horiz + (append (list 'vcent (if high 3 2)) + (and high (list high)) + '("----- " + " | | " + " | | " + " | | ") + (if low + (list (list 'horiz var " = " low)) + (list var))) + (if (memq (car-safe (nth 1 a)) + '(calcFunc-sum calcFunc-prod)) + " " "") + expr))) + (if (memq prec '(196 201)) + (math--comp-round-bracket comp) + comp)))) ;; The variables math-svo-c, math-svo-wid and math-svo-off are local ;; to math-stack-value-offset in calc.el, but are used by From 1248c67484d599b36e094f0e641c82482fd269ce Mon Sep 17 00:00:00 2001 From: Ted Zlatanov Date: Tue, 19 Jan 2021 13:35:07 +0000 Subject: [PATCH 049/133] * test/infra/gitlab-ci.yml: Bootstrap only from web, schedule, or C-related. --- test/infra/gitlab-ci.yml | 37 +++++++++++++++++++++++++++++++++---- 1 file changed, 33 insertions(+), 4 deletions(-) diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index 3214f01eddb..ddabacfe010 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -49,6 +49,8 @@ variables: # DOCKER_TLS_CERTDIR: "/certs" # Put the configuration for each run in a separate directory to avoid conflicts DOCKER_CONFIG: "/.docker-config-${CI_COMMIT_SHA}" + # We don't use ${CI_COMMIT_SHA} to be able to do one bootstrap across multiple builds + BUILD_TAG: ${CI_COMMIT_REF_SLUG} default: image: docker:19.03.12 @@ -96,17 +98,42 @@ default: # - "**/*.log" # using the variables for each job script: - - docker pull ${CI_REGISTRY_IMAGE}:${target}-${CI_COMMIT_SHA} + - docker pull ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} # TODO: with make -j4 several of the tests were failing, for example shadowfile-tests, but passed without it - - docker run -i --rm -e EMACS_EMBA_CI=${EMACS_EMBA_CI} ${CI_REGISTRY_IMAGE}:${target}-${CI_COMMIT_SHA} make ${make_params} + - docker run -i --rm -e EMACS_EMBA_CI=${EMACS_EMBA_CI} ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} make ${make_params} .build-template: + rules: + - if: '$CI_PIPELINE_SOURCE == "web"' + when: always + - changes: + - "**/Makefile.in" + - .gitlab-ci.yml + - aclocal.m4 + - autogen.sh + - configure.ac + - lib/*.{h,c} + - lisp/emacs-lisp/*.el + - src/*.{h,c} + - test/infra/* + - changes: + # gfilemonitor, kqueue + - src/gfilenotify.c + - src/kqueue.c + # MS Windows + - "**/w32*" + # GNUstep + - lisp/term/ns-win.el + - src/ns*.{h,m} + - src/macfont.{h,m} + when: never script: - - docker build --pull --target ${target} -t ${CI_REGISTRY_IMAGE}:${target}-${CI_COMMIT_SHA} -f test/infra/Dockerfile.emba . - - docker push ${CI_REGISTRY_IMAGE}:${target}-${CI_COMMIT_SHA} + - docker build --pull --target ${target} -t ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} -f test/infra/Dockerfile.emba . + - docker push ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} .gnustep-template: rules: + - if: '$CI_PIPELINE_SOURCE == "web"' - if: '$CI_PIPELINE_SOURCE == "schedule"' changes: - "**/Makefile.in" @@ -120,6 +147,7 @@ default: .filenotify-gio-template: rules: + - if: '$CI_PIPELINE_SOURCE == "web"' - if: '$CI_PIPELINE_SOURCE == "schedule"' changes: - "**/Makefile.in" @@ -208,6 +236,7 @@ test-all-inotify: extends: [.job-template] rules: # note there's no "changes" section, so this always runs on a schedule + - if: '$CI_PIPELINE_SOURCE == "web"' - if: '$CI_PIPELINE_SOURCE == "schedule"' variables: target: emacs-inotify From e718d3a84920f545b6a3540a3ba9c2ccd7eefdf7 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Tue, 19 Jan 2021 20:12:47 +0200 Subject: [PATCH 050/133] Better check for nil in search-/query-replace-highlight-submatches (bug#45973) * lisp/isearch.el (isearch-highlight): * lisp/replace.el (replace-highlight): Use integer-or-marker-p to check matches. --- lisp/isearch.el | 30 +++++++++++++++++------------- lisp/replace.el | 30 +++++++++++++++++------------- 2 files changed, 34 insertions(+), 26 deletions(-) diff --git a/lisp/isearch.el b/lisp/isearch.el index c6f7fe7bd4a..a86678572c4 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -3757,23 +3757,27 @@ since they have special meaning in a regexp." (overlay-put isearch-overlay 'priority 1001) (overlay-put isearch-overlay 'face isearch-face))) - (when (and search-highlight-submatches - isearch-regexp) + (when (and search-highlight-submatches isearch-regexp) (mapc 'delete-overlay isearch-submatches-overlays) (setq isearch-submatches-overlays nil) - (let ((submatch-data (cddr (butlast match-data))) + ;; 'cddr' removes whole expression match from match-data + (let ((submatch-data (cddr match-data)) (group 0) - ov face) + b e ov face) (while submatch-data - (setq group (1+ group)) - (setq ov (make-overlay (pop submatch-data) (pop submatch-data)) - face (intern-soft (format "isearch-group-%d" group))) - ;; Recycle faces from beginning. - (unless (facep face) - (setq group 1 face 'isearch-group-1)) - (overlay-put ov 'face face) - (overlay-put ov 'priority 1002) - (push ov isearch-submatches-overlays))))) + (setq b (pop submatch-data) + e (pop submatch-data)) + (when (and (integer-or-marker-p b) + (integer-or-marker-p e)) + (setq ov (make-overlay b e) + group (1+ group) + face (intern-soft (format "isearch-group-%d" group))) + ;; Recycle faces from beginning + (unless (facep face) + (setq group 1 face 'isearch-group-1)) + (overlay-put ov 'face face) + (overlay-put ov 'priority 1002) + (push ov isearch-submatches-overlays)))))) (defun isearch-dehighlight () (when isearch-overlay diff --git a/lisp/replace.el b/lisp/replace.el index 8f8cbfac542..db5b340631a 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -2425,23 +2425,27 @@ It is called with three arguments, as if it were (overlay-put replace-overlay 'priority 1001) ;higher than lazy overlays (overlay-put replace-overlay 'face 'query-replace))) - (when (and query-replace-highlight-submatches - regexp-flag) + (when (and query-replace-highlight-submatches regexp-flag) (mapc 'delete-overlay replace-submatches-overlays) (setq replace-submatches-overlays nil) - (let ((submatch-data (cddr (butlast (match-data t)))) + ;; 'cddr' removes whole expression match from match-data + (let ((submatch-data (cddr (match-data t))) (group 0) - ov face) + b e ov face) (while submatch-data - (setq group (1+ group)) - (setq ov (make-overlay (pop submatch-data) (pop submatch-data)) - face (intern-soft (format "isearch-group-%d" group))) - ;; Recycle faces from beginning. - (unless (facep face) - (setq group 1 face 'isearch-group-1)) - (overlay-put ov 'face face) - (overlay-put ov 'priority 1002) - (push ov replace-submatches-overlays)))) + (setq b (pop submatch-data) + e (pop submatch-data)) + (when (and (integer-or-marker-p b) + (integer-or-marker-p e)) + (setq ov (make-overlay b e) + group (1+ group) + face (intern-soft (format "isearch-group-%d" group))) + ;; Recycle faces from beginning + (unless (facep face) + (setq group 1 face 'isearch-group-1)) + (overlay-put ov 'face face) + (overlay-put ov 'priority 1002) + (push ov replace-submatches-overlays))))) (if query-replace-lazy-highlight (let ((isearch-string search-string) From eec059b124ed57956cf896904ef8240b24cc7ead Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Tue, 19 Jan 2021 20:27:29 +0200 Subject: [PATCH 051/133] * lisp/help-fns.el: Move defvar keymap-name-history closer to where it's used. --- lisp/help-fns.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 7be2826361c..da905192467 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -76,9 +76,6 @@ frame.") ;; costly, really). "Radix-tree representation replacing `definition-prefixes'.") -(defvar keymap-name-history nil - "History for input to `describe-keymap'.") - (defun help-definition-prefixes () "Return the up-to-date radix-tree form of `definition-prefixes'." (when (> (hash-table-count definition-prefixes) 0) @@ -1656,6 +1653,9 @@ in `describe-keymap'. See also `Searching the Active Keymaps'." (get-char-property (point) 'local-map) (current-local-map))))) +(defvar keymap-name-history nil + "History for input to `describe-keymap'.") + ;;;###autoload (defun describe-keymap (keymap) "Describe key bindings in KEYMAP. From 8725f7690a44306f03d7cbb9eaa45590fcaf88db Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Tue, 19 Jan 2021 21:50:11 +0200 Subject: [PATCH 052/133] Declare some project commands interactive-only * lisp/progmodes/project.el (project-async-shell-command) (project-shell-command, project-compile): Declare interactive-only (bug#45765). --- lisp/progmodes/project.el | 3 +++ 1 file changed, 3 insertions(+) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 06966f33b72..18124227d1b 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -929,6 +929,7 @@ if one already exists." (defun project-async-shell-command () "Run `async-shell-command' in the current project's root directory." (interactive) + (declare (interactive-only async-shell-command)) (let ((default-directory (project-root (project-current t)))) (call-interactively #'async-shell-command))) @@ -936,6 +937,7 @@ if one already exists." (defun project-shell-command () "Run `shell-command' in the current project's root directory." (interactive) + (declare (interactive-only shell-command)) (let ((default-directory (project-root (project-current t)))) (call-interactively #'shell-command))) @@ -973,6 +975,7 @@ loop using the command \\[fileloop-continue]." (defun project-compile () "Run `compile' in the project root." (interactive) + (declare (interactive-only compile)) (let ((default-directory (project-root (project-current t)))) (call-interactively #'compile))) From 8ed97a8d543b9596166c670212265dabc44aa3d5 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Tue, 19 Jan 2021 21:35:06 +0100 Subject: [PATCH 053/133] Make child signal read pipe non-blocking. Otherwise Emacs might hang when trying to read the pipe twice in a row. This is consistent with the other file descriptors we pass to 'pselect'. * src/process.c (child_signal_init): Make read end of pipe non-blocking. --- src/process.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/process.c b/src/process.c index 09f87908a45..57105982c15 100644 --- a/src/process.c +++ b/src/process.c @@ -7179,6 +7179,8 @@ child_signal_init (void) exits. */ eassert (0 <= fds[0]); eassert (0 <= fds[1]); + if (fcntl (fds[0], F_SETFL, O_NONBLOCK) != 0) + emacs_perror ("fcntl"); add_read_fd (fds[0], child_signal_read, NULL); fd_callback_info[fds[0]].flags &= ~KEYBOARD_FD; child_signal_read_fd = fds[0]; From 5536893c6e629d9541c75a1b0b239eaa96c6eaeb Mon Sep 17 00:00:00 2001 From: Nick Drozd Date: Wed, 20 Jan 2021 02:46:17 +0100 Subject: [PATCH 054/133] test/lisp/replace-tests.el: Add nested match group test * test/lisp/replace-tests.el (replace-regexp-bug45973): Add test (bug#45973). --- test/lisp/replace-tests.el | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el index 8c2682a1f13..2db570c97dd 100644 --- a/test/lisp/replace-tests.el +++ b/test/lisp/replace-tests.el @@ -587,5 +587,18 @@ bound to HIGHLIGHT-LOCUS." (get-text-property (point) 'occur-target)) (should (funcall check-overlays has-overlay))))))) +(ert-deftest replace-regexp-bug45973 () + "Test for https://debbugs.gnu.org/45973 ." + (let ((before "1RB 1LC 1RC 1RB 1RD 0LE 1LA 1LD 1RH 0LA") + (after "1LB 1RC 1LC 1LB 1LD 0RE 1RA 1RD 1LH 0RA")) + (with-temp-buffer + (insert before) + (goto-char (point-min)) + (replace-regexp + "\\(\\(L\\)\\|\\(R\\)\\)" + '(replace-eval-replacement + replace-quote + (if (match-string 2) "R" "L"))) + (should (equal (buffer-string) after))))) ;;; replace-tests.el ends here From 5aff1bfdaf6fb64b50087c93f212faa18fbe17fb Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 20 Jan 2021 03:25:46 +0100 Subject: [PATCH 055/133] Make sh-mode use `auto-mode-interpreter-regexp' * lisp/progmodes/sh-script.el (sh-mode): Use `auto-mode-interpreter-regexp' instead of open-coding the value (bug#17158). --- lisp/progmodes/sh-script.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index a417de32640..d3692d47205 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -1556,7 +1556,7 @@ with your script for an edit-interpret-debug cycle." (sh-set-shell (cond ((save-excursion (goto-char (point-min)) - (looking-at "#![ \t]?\\([^ \t\n]*/bin/env[ \t]\\)?\\([^ \t\n]+\\)")) + (looking-at auto-mode-interpreter-regexp)) (match-string 2)) ((not buffer-file-name) sh-shell-file) ;; Checks that use `buffer-file-name' follow. From f925aabcceb353f04e4d2507b6d05eb74822f83b Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 20 Jan 2021 03:54:18 +0100 Subject: [PATCH 056/133] Mention that the mouse will switch on transient-mark-mode in manual * doc/lispref/markers.texi (The Mark): Mention that the mouse will enable the `(only)' transient mark mode (bug#14945). --- doc/lispref/markers.texi | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/doc/lispref/markers.texi b/doc/lispref/markers.texi index cdd0938b458..b39373f0727 100644 --- a/doc/lispref/markers.texi +++ b/doc/lispref/markers.texi @@ -560,7 +560,9 @@ deactivate the mark. If the value is @w{@code{(only . @var{oldval})}}, then @code{transient-mark-mode} is set to the value @var{oldval} after any subsequent command that moves point and is not shift-translated (@pxref{Key Sequence Input, shift-translation}), or after any other -action that would normally deactivate the mark. +action that would normally deactivate the mark. (Marking a region +with the mouse will temporarily enable @code{transient-mark-mode} in +this way.) @end defopt @defopt mark-even-if-inactive From 3bbec2eb2b2a48a0eaac8e83c27313bfbe9d420e Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 20 Jan 2021 04:17:41 +0100 Subject: [PATCH 057/133] Fix up example in the Modifying Menus node in the lispref manual * doc/lispref/keymaps.texi (Modifying Menus): Make the second example more regular (bug#14257). --- doc/lispref/keymaps.texi | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/doc/lispref/keymaps.texi b/doc/lispref/keymaps.texi index 37bab7ea9bc..55d179b8753 100644 --- a/doc/lispref/keymaps.texi +++ b/doc/lispref/keymaps.texi @@ -2852,9 +2852,8 @@ Here is how to insert an item called @samp{Work} in the @samp{Signals} menu of Shell mode, after the item @code{break}: @example -(define-key-after - (lookup-key shell-mode-map [menu-bar signals]) - [work] '("Work" . work-command) 'break) +(define-key-after shell-mode-map [menu-bar signals work] + '("Work" . work-command) 'break) @end example @end defun From 40a5df81434ce02fba01779256b50976fb74da4f Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 20 Jan 2021 04:44:18 +0100 Subject: [PATCH 058/133] Make `symbol-at-point' work in buffers with no symbols * lisp/thingatpt.el (thing-at-point--end-of-symbol): New function (bug#14234). (symbol): Use it instead of `forward-symbol', because the latter will move to the end of the buffer even if there is no symbol there. Instead error out like `forward-sexp' and friends. --- lisp/thingatpt.el | 8 ++++++++ test/lisp/thingatpt-tests.el | 14 ++++++++++++++ 2 files changed, 22 insertions(+) diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index d3ba941fcc2..69c23c35431 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -218,6 +218,14 @@ The bounds of THING are determined by `bounds-of-thing-at-point'." (put 'sexp 'beginning-op 'thing-at-point--beginning-of-sexp) +;; Symbols + +(put 'symbol 'end-op 'thing-at-point--end-of-symbol) + +(defun thing-at-point--end-of-symbol () + "Move point to the end of the current symbol." + (re-search-forward "\\(\\sw\\|\\s_\\)+")) + ;; Lists (put 'list 'bounds-of-thing-at-point 'thing-at-point-bounds-of-list-at-point) diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el index c43c81af9fd..b7c315062f9 100644 --- a/test/lisp/thingatpt-tests.el +++ b/test/lisp/thingatpt-tests.el @@ -146,4 +146,18 @@ position to retrieve THING.") (should (thing-at-point-looking-at "2abcd")) (should (equal (match-data) m2))))) +(ert-deftest test-narrow-buffer-symbol () + (with-temp-buffer + (insert "foo bar zot") + (goto-char 5) + (should (equal (symbol-at-point) 'bar))) + (with-temp-buffer + (insert "`[[`(") + (goto-char 2) + (should (equal (symbol-at-point) nil))) + (with-temp-buffer + (insert "aa `[[`(") + (goto-char 4) + (should (equal (symbol-at-point) nil)))) + ;;; thingatpt.el ends here From c502cdd2b71f396b202e22103cd8aa5b0796fdab Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 20 Jan 2021 05:08:56 +0100 Subject: [PATCH 059/133] Don't add Content-Type when ceasing an rmail edit * lisp/mail/rmailedit.el (rmail-cease-edit): Take an optional parameter to avoid altering the message (bug#13327). (rmail-abort-edit): Use it. --- lisp/mail/rmailedit.el | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/lisp/mail/rmailedit.el b/lisp/mail/rmailedit.el index 2680ed7f3a3..c3b351d7bc8 100644 --- a/lisp/mail/rmailedit.el +++ b/lisp/mail/rmailedit.el @@ -145,8 +145,9 @@ This function runs the hooks `text-mode-hook' and `rmail-edit-mode-hook'. (declare-function rmail-summary-enable "rmailsum" ()) (declare-function rmail-summary-update-line "rmailsum" (n)) -(defun rmail-cease-edit () - "Finish editing message; switch back to Rmail proper." +(defun rmail-cease-edit (&optional abort) + "Finish editing message; switch back to Rmail proper. +If ABORT, this is the result of aborting an edit." (interactive) (if (rmail-summary-exists) (with-current-buffer rmail-summary-buffer @@ -271,6 +272,8 @@ This function runs the hooks `text-mode-hook' and `rmail-edit-mode-hook'. ;; No match for rmail-mime-charset-pattern, but there was some ;; other Content-Type. We should not insert another. (Bug#4624) (content-type) + ;; Don't insert anything if aborting. + (abort) ((null old-coding) ;; If there was no charset= spec, insert one. (backward-char 1) @@ -352,7 +355,7 @@ This function runs the hooks `text-mode-hook' and `rmail-edit-mode-hook'. (widen) (delete-region (point-min) (point-max)) (insert rmail-old-text) - (rmail-cease-edit) + (rmail-cease-edit t) (rmail-highlight-headers)) (defun rmail-edit-headers-alist (&optional widen markers) From 8b33b76eb9fbb857bccbe3d223c961c486e4e8f9 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 20 Jan 2021 05:44:16 +0100 Subject: [PATCH 060/133] Revert "Make `symbol-at-point' work in buffers with no symbols" This reverts commit 40a5df81434ce02fba01779256b50976fb74da4f. This fails when a point is after a symbol, and there's nothing else in the buffer. --- lisp/thingatpt.el | 8 -------- test/lisp/thingatpt-tests.el | 14 -------------- 2 files changed, 22 deletions(-) diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index 69c23c35431..d3ba941fcc2 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -218,14 +218,6 @@ The bounds of THING are determined by `bounds-of-thing-at-point'." (put 'sexp 'beginning-op 'thing-at-point--beginning-of-sexp) -;; Symbols - -(put 'symbol 'end-op 'thing-at-point--end-of-symbol) - -(defun thing-at-point--end-of-symbol () - "Move point to the end of the current symbol." - (re-search-forward "\\(\\sw\\|\\s_\\)+")) - ;; Lists (put 'list 'bounds-of-thing-at-point 'thing-at-point-bounds-of-list-at-point) diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el index b7c315062f9..c43c81af9fd 100644 --- a/test/lisp/thingatpt-tests.el +++ b/test/lisp/thingatpt-tests.el @@ -146,18 +146,4 @@ position to retrieve THING.") (should (thing-at-point-looking-at "2abcd")) (should (equal (match-data) m2))))) -(ert-deftest test-narrow-buffer-symbol () - (with-temp-buffer - (insert "foo bar zot") - (goto-char 5) - (should (equal (symbol-at-point) 'bar))) - (with-temp-buffer - (insert "`[[`(") - (goto-char 2) - (should (equal (symbol-at-point) nil))) - (with-temp-buffer - (insert "aa `[[`(") - (goto-char 4) - (should (equal (symbol-at-point) nil)))) - ;;; thingatpt.el ends here From 849fe71de7b041c21cb776c7428c39e0ce67df14 Mon Sep 17 00:00:00 2001 From: Fabrice Bauzac Date: Mon, 18 Jan 2021 23:02:21 +0100 Subject: [PATCH 061/133] Sort Ibuffer filename/process column as displayed * lisp/ibuf-ext.el (ibuffer-do-sort-by-filename/process): Use the same function for sorting and for displaying the filename/process (Bug#45800). Copyright-paperwork-exempt: yes --- lisp/ibuf-ext.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el index ed5c9c02115..44574abd46a 100644 --- a/lisp/ibuf-ext.el +++ b/lisp/ibuf-ext.el @@ -1497,10 +1497,10 @@ Ordering is lexicographic." (string-lessp ;; FIXME: For now just compare the file name and the process name ;; (if it exists). Is there a better way to do this? - (or (buffer-file-name (car a)) + (or (with-current-buffer (car a) (ibuffer-buffer-file-name)) (let ((pr-a (get-buffer-process (car a)))) (and (processp pr-a) (process-name pr-a)))) - (or (buffer-file-name (car b)) + (or (with-current-buffer (car b) (ibuffer-buffer-file-name)) (let ((pr-b (get-buffer-process (car b)))) (and (processp pr-b) (process-name pr-b)))))) From 420661af07448857f0a17e15dc27bceeb6aff541 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 20 Jan 2021 09:52:07 -0500 Subject: [PATCH 062/133] Don't let `maybe_quit` prevent resetting `consing_until_gc` (bug#43389) * src/alloc.c (garbage_collect): Postpone `unblock_input` a bit. * src/window.c (window_parameter): Avoid `maybe_quit`. --- src/alloc.c | 6 ++++-- src/window.c | 2 +- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src/alloc.c b/src/alloc.c index c0a55e61b97..b86ed4ed262 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6101,11 +6101,13 @@ garbage_collect (void) gc_in_progress = 0; - unblock_input (); - consing_until_gc = gc_threshold = consing_threshold (gc_cons_threshold, Vgc_cons_percentage, 0); + /* Unblock *after* re-setting `consing_until_gc` in case `unblock_input` + signals an error (see bug#43389). */ + unblock_input (); + if (garbage_collection_messages && NILP (Vmemory_full)) { if (message_p || minibuf_level > 0) diff --git a/src/window.c b/src/window.c index e025e0b0821..eb16e2a4338 100644 --- a/src/window.c +++ b/src/window.c @@ -2260,7 +2260,7 @@ return value is a list of elements of the form (PARAMETER . VALUE). */) Lisp_Object window_parameter (struct window *w, Lisp_Object parameter) { - Lisp_Object result = Fassq (parameter, w->window_parameters); + Lisp_Object result = assq_no_quit (parameter, w->window_parameters); return CDR_SAFE (result); } From ce1a42a6eb41ab7a4473de9e8d8961498568576a Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 20 Jan 2021 16:47:39 +0100 Subject: [PATCH 063/133] Add tests for symbol-at-point (bug#14234) --- test/lisp/thingatpt-tests.el | 45 ++++++++++++++++++++++++++++++++++++ 1 file changed, 45 insertions(+) diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el index c43c81af9fd..8eec853d461 100644 --- a/test/lisp/thingatpt-tests.el +++ b/test/lisp/thingatpt-tests.el @@ -146,4 +146,49 @@ position to retrieve THING.") (should (thing-at-point-looking-at "2abcd")) (should (equal (match-data) m2))))) +(ert-deftest test-symbol-thing-1 () + (with-temp-buffer + (insert "foo bar zot") + (goto-char 4) + (should (eq (symbol-at-point) 'foo)) + (forward-char 1) + (should (eq (symbol-at-point) 'bar)) + (forward-char 1) + (should (eq (symbol-at-point) 'bar)) + (forward-char 1) + (should (eq (symbol-at-point) 'bar)) + (forward-char 1) + (should (eq (symbol-at-point) 'bar)) + (forward-char 1) + (should (eq (symbol-at-point) 'zot)))) + +(ert-deftest test-symbol-thing-2 () + (with-temp-buffer + (insert " bar ") + (goto-char (point-max)) + (should (eq (symbol-at-point) nil)) + (forward-char -1) + (should (eq (symbol-at-point) 'bar)))) + +(ert-deftest test-symbol-thing-2 () + (with-temp-buffer + (insert " bar ") + (goto-char (point-max)) + (should (eq (symbol-at-point) nil)) + (forward-char -1) + (should (eq (symbol-at-point) 'bar)))) + +(ert-deftest test-symbol-thing-3 () + (with-temp-buffer + (insert "bar") + (goto-char 2) + (should (eq (symbol-at-point) 'bar)))) + +(ert-deftest test-symbol-thing-3 () + :expected-result :failed ; FIXME bug#14234 + (with-temp-buffer + (insert "`[[`(") + (goto-char 2) + (should (eq (symbol-at-point) nil)))) + ;;; thingatpt.el ends here From f30cf07ecba8f4316b268b7ad57705a0aa16d660 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 20 Jan 2021 16:58:09 +0100 Subject: [PATCH 064/133] Make symbol-at-point return nil if there's no symbols in the buffer * lisp/thingatpt.el (thing-at-point--beginning-of-symbol): Special op that errors out when there's no symbols in the buffer before point (bug#14234). (symbol): Use it. --- lisp/thingatpt.el | 9 +++++++++ test/lisp/thingatpt-tests.el | 1 - 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index d3ba941fcc2..67d4092d407 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -218,6 +218,15 @@ The bounds of THING are determined by `bounds-of-thing-at-point'." (put 'sexp 'beginning-op 'thing-at-point--beginning-of-sexp) +;; Symbols + +(put 'symbol 'beginning-op 'thing-at-point--beginning-of-symbol) + +(defun thing-at-point--beginning-of-symbol () + "Move point to the beginning of the current symbol." + (and (re-search-backward "\\(\\sw\\|\\s_\\)+") + (skip-syntax-backward "w_"))) + ;; Lists (put 'list 'bounds-of-thing-at-point 'thing-at-point-bounds-of-list-at-point) diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el index 8eec853d461..62a27f09cbd 100644 --- a/test/lisp/thingatpt-tests.el +++ b/test/lisp/thingatpt-tests.el @@ -185,7 +185,6 @@ position to retrieve THING.") (should (eq (symbol-at-point) 'bar)))) (ert-deftest test-symbol-thing-3 () - :expected-result :failed ; FIXME bug#14234 (with-temp-buffer (insert "`[[`(") (goto-char 2) From cad2c4b14a98d24d6cba4089bd48340899dcff52 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 20 Jan 2021 17:25:40 +0100 Subject: [PATCH 065/133] Tweak tty-find-type to allow TERM=screen.xterm * lisp/faces.el (tty-find-type): Allow TERM=screen.xterm to find term/screen.el (bug#45824). --- lisp/faces.el | 2 +- test/lisp/faces-tests.el | 8 ++++++++ 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/lisp/faces.el b/lisp/faces.el index 4e98338432f..d654b1f0e2a 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -2199,7 +2199,7 @@ the above example." (not (funcall pred type))) ;; Strip off last hyphen and what follows, then try again (setq type - (if (setq hyphend (string-match-p "[-_][^-_]+$" type)) + (if (setq hyphend (string-match-p "[-_.][^-_.]+$" type)) (substring type 0 hyphend) nil)))) type) diff --git a/test/lisp/faces-tests.el b/test/lisp/faces-tests.el index 6e77259fe1b..c0db9c9de17 100644 --- a/test/lisp/faces-tests.el +++ b/test/lisp/faces-tests.el @@ -217,5 +217,13 @@ )) ) +(ert-deftest test-tty-find-type () + (let ((pred (lambda (string) + (locate-library (concat "term/" string ".el"))))) + (should (tty-find-type pred "cygwin")) + (should (tty-find-type pred "cygwin-foo")) + (should (equal (tty-find-type pred "xterm") "xterm")) + (should (equal (tty-find-type pred "screen.xterm") "screen")))) + (provide 'faces-tests) ;;; faces-tests.el ends here From 72d4522b05c81ba9400603963db55e47c6d836ce Mon Sep 17 00:00:00 2001 From: Gabriel do Nascimento Ribeiro Date: Wed, 20 Jan 2021 17:45:08 +0100 Subject: [PATCH 066/133] Add option remember-diary-regexp * lisp/textmodes/remember.el (remember-diary-extract-entries): Use it (bug#45808). (remember-diary-regexp): New variable. --- etc/NEWS | 3 +++ lisp/textmodes/remember.el | 12 +++++++++--- 2 files changed, 12 insertions(+), 3 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 7a012b48912..a0e1e3b2a18 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1557,6 +1557,9 @@ that makes it a valid button. ** Miscellaneous +--- +*** New user option 'remember-diary-regexp'. + *** New function 'buffer-line-statistics'. This function returns some statistics about the line lengths in a buffer. diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el index 98d3a3856ea..92706e38073 100644 --- a/lisp/textmodes/remember.el +++ b/lisp/textmodes/remember.el @@ -159,7 +159,8 @@ ;; ;; This should be before other entries that may return t ;; (add-to-list 'remember-handler-functions 'remember-diary-extract-entries) ;; -;; This module recognizes entries of the form +;; This module recognizes entries of the form (defined by +;; `remember-diary-regexp') ;; ;; DIARY: .... ;; @@ -532,13 +533,18 @@ If this is nil, then `diary-file' will be used instead." (autoload 'diary-make-entry "diary-lib") +(defcustom remember-diary-regexp "^DIARY:\\s-*\\(.+\\)" + "Regexp to extract diary entries." + :type 'regexp + :version "28.1") + ;;;###autoload (defun remember-diary-extract-entries () - "Extract diary entries from the region." + "Extract diary entries from the region based on `remember-diary-regexp'." (save-excursion (goto-char (point-min)) (let (list) - (while (re-search-forward "^DIARY:\\s-*\\(.+\\)" nil t) + (while (re-search-forward remember-diary-regexp nil t) (push (remember-diary-convert-entry (match-string 1)) list)) (when list (diary-make-entry (mapconcat 'identity list "\n") From edf6350e7ffd51f93fd84df3e0f9734e337cd51c Mon Sep 17 00:00:00 2001 From: Gabriel do Nascimento Ribeiro Date: Wed, 20 Jan 2021 17:53:04 +0100 Subject: [PATCH 067/133] Add option remember-text-format-function * lisp/textmodes/remember.el (remember-text-format-function): New variable (bug#45809). (remember-append-to-file): Use it. --- etc/NEWS | 3 +++ lisp/textmodes/remember.el | 17 ++++++++++++++--- 2 files changed, 17 insertions(+), 3 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index a0e1e3b2a18..c8cbce1882a 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1560,6 +1560,9 @@ that makes it a valid button. --- *** New user option 'remember-diary-regexp'. +--- +*** New user option 'remember-text-format-function'. + *** New function 'buffer-line-statistics'. This function returns some statistics about the line lengths in a buffer. diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el index 92706e38073..6c94f8d03c8 100644 --- a/lisp/textmodes/remember.el +++ b/lisp/textmodes/remember.el @@ -411,13 +411,24 @@ The default emulates `current-time-string' for backward compatibility." :group 'remember :version "27.1") +(defcustom remember-text-format-function nil + "The function to format the remembered text. +The function receives the remembered text as argument and should +return the text to be remembered." + :type 'function + :group 'remember + :version "28.1") + (defun remember-append-to-file () "Remember, with description DESC, the given TEXT." (let* ((text (buffer-string)) (desc (remember-buffer-desc)) - (remember-text (concat "\n" remember-leader-text - (format-time-string remember-time-format) - " (" desc ")\n\n" text + (remember-text (concat "\n" + (if remember-text-format-function + (funcall remember-text-format-function text) + (concat remember-leader-text + (format-time-string remember-time-format) + " (" desc ")\n\n" text)) (save-excursion (goto-char (point-max)) (if (bolp) nil "\n")))) (buf (find-buffer-visiting remember-data-file))) From 38173af10df67cb36521cdcc2f1f42103d67de98 Mon Sep 17 00:00:00 2001 From: Gabriel do Nascimento Ribeiro Date: Wed, 20 Jan 2021 17:54:43 +0100 Subject: [PATCH 068/133] Respect remember-save-after-remembering on remember-diary-extract-entries * lisp/textmodes/remember.el (remember-diary-extract-entries): Save automatically if `remember-save-after-remembering' is non-nil (bug#45811). --- lisp/textmodes/remember.el | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el index 6c94f8d03c8..7f107977d53 100644 --- a/lisp/textmodes/remember.el +++ b/lisp/textmodes/remember.el @@ -559,7 +559,10 @@ If this is nil, then `diary-file' will be used instead." (push (remember-diary-convert-entry (match-string 1)) list)) (when list (diary-make-entry (mapconcat 'identity list "\n") - nil remember-diary-file)) + nil remember-diary-file) + (when remember-save-after-remembering + (with-current-buffer (find-buffer-visiting diary-file) + (save-buffer)))) nil))) ;; Continue processing ;;; Internal Functions: From bd423b869978f33bea8d399684f02b0b5b53da43 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Wed, 20 Jan 2021 18:51:52 +0100 Subject: [PATCH 069/133] Fix environment handling in tramp-handle-make-process * lisp/net/tramp.el (tramp-test-message): Add `tramp-suppress-trace' property. (tramp-handle-make-process): Handle also 'tramp-remote-process-environment'. --- lisp/net/tramp.el | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 2816c58fe7f..7b34a748822 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1990,6 +1990,8 @@ the resulting error message." (tramp-dissect-file-name default-directory) 0 fmt-string arguments) (apply #'message fmt-string arguments))) +(put #'tramp-test-message 'tramp-suppress-trace t) + ;; This function provides traces in case of errors not triggered by ;; Tramp functions. (defun tramp-signal-hook-function (error-symbol data) @@ -3801,15 +3803,20 @@ It does not support `:stderr'." (get-buffer-create buffer) ;; BUFFER can be nil. We use a temporary buffer. (generate-new-buffer tramp-temp-buffer-name))) - ;; We use as environment the difference to toplevel - ;; `process-environment'. (env (mapcar (lambda (elt) - (unless - (member - elt (default-toplevel-value 'process-environment)) - (when (string-match-p "=" elt) elt))) - process-environment)) + (when (string-match-p "=" elt) elt)) + tramp-remote-process-environment)) + ;; We use as environment the difference to toplevel + ;; `process-environment'. + (env (dolist (elt process-environment env) + (when + (and + (string-match-p "=" elt) + (not + (member + elt (default-toplevel-value 'process-environment)))) + (setq env (cons elt env))))) (env (setenv-internal env "INSIDE_EMACS" (concat (or (getenv "INSIDE_EMACS") emacs-version) From 7fe7efe0bbb00a541df1da68ca4cb4af14441fe1 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 20 Jan 2021 18:52:17 +0100 Subject: [PATCH 070/133] cua-toggle-global-mark doc string clarification * lisp/emulation/cua-gmrk.el (cua-toggle-global-mark): Clarify that also inserted characters are affected (bug#8083). --- lisp/emulation/cua-gmrk.el | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/lisp/emulation/cua-gmrk.el b/lisp/emulation/cua-gmrk.el index 195bba1f317..6f6b9fce130 100644 --- a/lisp/emulation/cua-gmrk.el +++ b/lisp/emulation/cua-gmrk.el @@ -87,9 +87,11 @@ (defun cua-toggle-global-mark (stay) "Set or cancel the global marker. -When the global marker is set, CUA cut and copy commands will automatically -insert the deleted or copied text before the global marker, even when the -global marker is in another buffer. +When the global marker is set, CUA cut and copy commands will +automatically insert the inserted, deleted or copied text before +the global marker, even when the global marker is in another +buffer. + If the global marker isn't set, set the global marker at point in the current buffer. Otherwise jump to the global marker position and cancel it. With prefix argument, don't jump to global mark when canceling it." From 434057ad925cad3ebcae1802fab60733ae5decae Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 20 Jan 2021 19:42:21 +0100 Subject: [PATCH 071/133] Fix footnote-mode problem when reopening an old file * lisp/mail/footnote.el (footnote--regenerate-alist): New function (bug#7258). (footnote-mode): Use it to restore footnotes after opening an old file with footnotes. --- lisp/mail/footnote.el | 27 ++++++++++++++++++++++++++- 1 file changed, 26 insertions(+), 1 deletion(-) diff --git a/lisp/mail/footnote.el b/lisp/mail/footnote.el index ea109eec12a..9c1a738035e 100644 --- a/lisp/mail/footnote.el +++ b/lisp/mail/footnote.el @@ -910,7 +910,32 @@ play around with the following keys: (unless (assoc bullet-regexp filladapt-token-table) (setq filladapt-token-table (append filladapt-token-table - (list (list bullet-regexp 'bullet))))))))) + (list (list bullet-regexp 'bullet))))))) + (footnote--regenerate-alist))) + +(defun footnote--regenerate-alist () + (save-excursion + (goto-char (point-min)) + (if (not (re-search-forward footnote-section-tag-regexp nil t)) + (error "No footnote section in this buffer") + (setq footnote--markers-alist + (cl-loop + with start-of-footnotes = (match-beginning 0) + with regexp = (footnote--current-regexp) + for (note text) in + (cl-loop for pos = (re-search-forward regexp nil t) + while pos + collect (list (match-string 1) + (copy-marker (match-beginning 0) t))) + do (goto-char (point-min)) + collect (cl-list* + (string-to-number note) + text + (cl-loop + for pos = (re-search-forward regexp start-of-footnotes t) + while pos + when (equal note (match-string 1)) + collect (copy-marker (match-beginning 0) t)))))))) (provide 'footnote) From 09bfb12edc57ace138090861e335366d8f1cc4b2 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 20 Jan 2021 13:54:11 -0500 Subject: [PATCH 072/133] * lisp/emacs-lisp/byte-opt.el (byte-optimize-lapcode): Re-indent --- lisp/emacs-lisp/byte-opt.el | 912 ++++++++++++++++++------------------ 1 file changed, 456 insertions(+), 456 deletions(-) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index f29f85b9650..6d1f4179ce1 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1561,467 +1561,467 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; You may notice that sequences like "dup varset discard" are ;; optimized but sequences like "dup varset TAG1: discard" are not. ;; You may be tempted to change this; resist that temptation. - (cond ;; - ;; pop --> - ;; ...including: - ;; const-X pop --> - ;; varref-X pop --> - ;; dup pop --> - ;; - ((and (eq 'byte-discard (car lap1)) - (memq (car lap0) side-effect-free)) - (setq keep-going t) - (setq tmp (aref byte-stack+-info (symbol-value (car lap0)))) - (setq rest (cdr rest)) - (cond ((= tmp 1) - (byte-compile-log-lap - " %s discard\t-->\t" lap0) - (setq lap (delq lap0 (delq lap1 lap)))) - ((= tmp 0) - (byte-compile-log-lap - " %s discard\t-->\t discard" lap0) - (setq lap (delq lap0 lap))) - ((= tmp -1) - (byte-compile-log-lap - " %s discard\t-->\tdiscard discard" lap0) - (setcar lap0 'byte-discard) - (setcdr lap0 0)) - ((error "Optimizer error: too much on the stack")))) - ;; - ;; goto*-X X: --> X: - ;; - ((and (memq (car lap0) byte-goto-ops) - (eq (cdr lap0) lap1)) - (cond ((eq (car lap0) 'byte-goto) - (setq lap (delq lap0 lap)) - (setq tmp "")) - ((memq (car lap0) byte-goto-always-pop-ops) - (setcar lap0 (setq tmp 'byte-discard)) - (setcdr lap0 0)) - ((error "Depth conflict at tag %d" (nth 2 lap0)))) - (and (memq byte-optimize-log '(t byte)) - (byte-compile-log " (goto %s) %s:\t-->\t%s %s:" - (nth 1 lap1) (nth 1 lap1) - tmp (nth 1 lap1))) - (setq keep-going t)) - ;; - ;; varset-X varref-X --> dup varset-X - ;; varbind-X varref-X --> dup varbind-X - ;; const/dup varset-X varref-X --> const/dup varset-X const/dup - ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup - ;; The latter two can enable other optimizations. - ;; - ;; For lexical variables, we could do the same - ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2 - ;; but this is a very minor gain, since dup is stack-ref-0, - ;; i.e. it's only better if X>5, and even then it comes - ;; at the cost of an extra stack slot. Let's not bother. - ((and (eq 'byte-varref (car lap2)) - (eq (cdr lap1) (cdr lap2)) - (memq (car lap1) '(byte-varset byte-varbind))) - (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) - (not (eq (car lap0) 'byte-constant))) - nil - (setq keep-going t) - (if (memq (car lap0) '(byte-constant byte-dup)) - (progn - (setq tmp (if (or (not tmp) - (macroexp--const-symbol-p - (car (cdr lap0)))) - (cdr lap0) - (byte-compile-get-constant t))) - (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s" - lap0 lap1 lap2 lap0 lap1 - (cons (car lap0) tmp)) - (setcar lap2 (car lap0)) - (setcdr lap2 tmp)) - (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1) - (setcar lap2 (car lap1)) - (setcar lap1 'byte-dup) - (setcdr lap1 0) - ;; The stack depth gets locally increased, so we will - ;; increase maxdepth in case depth = maxdepth here. - ;; This can cause the third argument to byte-code to - ;; be larger than necessary. - (setq add-depth 1)))) - ;; - ;; dup varset-X discard --> varset-X - ;; dup varbind-X discard --> varbind-X - ;; dup stack-set-X discard --> stack-set-X-1 - ;; (the varbind variant can emerge from other optimizations) - ;; - ((and (eq 'byte-dup (car lap0)) - (eq 'byte-discard (car lap2)) - (memq (car lap1) '(byte-varset byte-varbind - byte-stack-set))) - (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) - (setq keep-going t - rest (cdr rest)) - (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1))) - (setq lap (delq lap0 (delq lap2 lap)))) - ;; - ;; not goto-X-if-nil --> goto-X-if-non-nil - ;; not goto-X-if-non-nil --> goto-X-if-nil - ;; - ;; it is wrong to do the same thing for the -else-pop variants. - ;; - ((and (eq 'byte-not (car lap0)) - (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil))) - (byte-compile-log-lap " not %s\t-->\t%s" - lap1 - (cons - (if (eq (car lap1) 'byte-goto-if-nil) - 'byte-goto-if-not-nil - 'byte-goto-if-nil) - (cdr lap1))) - (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil) - 'byte-goto-if-not-nil - 'byte-goto-if-nil)) - (setq lap (delq lap0 lap)) - (setq keep-going t)) - ;; - ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: - ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: - ;; - ;; it is wrong to do the same thing for the -else-pop variants. - ;; - ((and (memq (car lap0) - '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX - (eq 'byte-goto (car lap1)) ; gotoY - (eq (cdr lap0) lap2)) ; TAG X - (let ((inverse (if (eq 'byte-goto-if-nil (car lap0)) - 'byte-goto-if-not-nil 'byte-goto-if-nil))) - (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:" - lap0 lap1 lap2 - (cons inverse (cdr lap1)) lap2) - (setq lap (delq lap0 lap)) - (setcar lap1 inverse) - (setq keep-going t))) - ;; - ;; const goto-if-* --> whatever - ;; - ((and (eq 'byte-constant (car lap0)) - (memq (car lap1) byte-conditional-ops) - ;; If the `byte-constant's cdr is not a cons cell, it has - ;; to be an index into the constant pool); even though - ;; it'll be a constant, that constant is not known yet - ;; (it's typically a free variable of a closure, so will - ;; only be known when the closure will be built at - ;; run-time). - (consp (cdr lap0))) - (cond ((if (memq (car lap1) '(byte-goto-if-nil - byte-goto-if-nil-else-pop)) - (car (cdr lap0)) - (not (car (cdr lap0)))) - (byte-compile-log-lap " %s %s\t-->\t" - lap0 lap1) - (setq rest (cdr rest) - lap (delq lap0 (delq lap1 lap)))) - (t - (byte-compile-log-lap " %s %s\t-->\t%s" - lap0 lap1 - (cons 'byte-goto (cdr lap1))) - (when (memq (car lap1) byte-goto-always-pop-ops) - (setq lap (delq lap0 lap))) - (setcar lap1 'byte-goto))) - (setq keep-going t)) - ;; - ;; varref-X varref-X --> varref-X dup - ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup - ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup - ;; We don't optimize the const-X variations on this here, - ;; because that would inhibit some goto optimizations; we - ;; optimize the const-X case after all other optimizations. - ;; - ((and (memq (car lap0) '(byte-varref byte-stack-ref)) - (progn - (setq tmp (cdr rest)) - (setq tmp2 0) - (while (eq (car (car tmp)) 'byte-dup) - (setq tmp2 (1+ tmp2)) - (setq tmp (cdr tmp))) - t) - (eq (if (eq 'byte-stack-ref (car lap0)) - (+ tmp2 1 (cdr lap0)) - (cdr lap0)) - (cdr (car tmp))) - (eq (car lap0) (car (car tmp)))) - (if (memq byte-optimize-log '(t byte)) - (let ((str "")) - (setq tmp2 (cdr rest)) - (while (not (eq tmp tmp2)) - (setq tmp2 (cdr tmp2) - str (concat str " dup"))) - (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup" - lap0 str lap0 lap0 str))) - (setq keep-going t) - (setcar (car tmp) 'byte-dup) - (setcdr (car tmp) 0) - (setq rest tmp)) - ;; - ;; TAG1: TAG2: --> TAG1: - ;; (and other references to TAG2 are replaced with TAG1) - ;; - ((and (eq (car lap0) 'TAG) - (eq (car lap1) 'TAG)) - (and (memq byte-optimize-log '(t byte)) - (byte-compile-log " adjacent tags %d and %d merged" - (nth 1 lap1) (nth 1 lap0))) - (setq tmp3 lap) - (while (setq tmp2 (rassq lap0 tmp3)) - (setcdr tmp2 lap1) - (setq tmp3 (cdr (memq tmp2 tmp3)))) - (setq lap (delq lap0 lap) - keep-going t) - ;; replace references to tag in jump tables, if any - (dolist (table byte-compile-jump-tables) - (maphash #'(lambda (value tag) - (when (equal tag lap0) - (puthash value lap1 table))) - table))) - ;; - ;; unused-TAG: --> - ;; - ((and (eq 'TAG (car lap0)) - (not (rassq lap0 lap)) - ;; make sure this tag isn't used in a jump-table - (cl-loop for table in byte-compile-jump-tables - when (member lap0 (hash-table-values table)) - return nil finally return t)) - (and (memq byte-optimize-log '(t byte)) - (byte-compile-log " unused tag %d removed" (nth 1 lap0))) - (setq lap (delq lap0 lap) - keep-going t)) - ;; - ;; goto ... --> goto - ;; return ... --> return - ;; (unless a jump-table is being used, where deleting may affect - ;; other valid case bodies) - ;; - ((and (memq (car lap0) '(byte-goto byte-return)) - (not (memq (car lap1) '(TAG nil))) - ;; FIXME: Instead of deferring simply when jump-tables are - ;; being used, keep a list of tags used for switch tags and - ;; use them instead (see `byte-compile-inline-lapcode'). - (not byte-compile-jump-tables)) - (setq tmp rest) - (let ((i 0) - (opt-p (memq byte-optimize-log '(t lap))) - str deleted) - (while (and (setq tmp (cdr tmp)) - (not (eq 'TAG (car (car tmp))))) - (if opt-p (setq deleted (cons (car tmp) deleted) - str (concat str " %s") - i (1+ i)))) - (if opt-p - (let ((tagstr - (if (eq 'TAG (car (car tmp))) - (format "%d:" (car (cdr (car tmp)))) - (or (car tmp) "")))) - (if (< i 6) - (apply 'byte-compile-log-lap-1 - (concat " %s" str - " %s\t-->\t%s %s") - lap0 - (nconc (nreverse deleted) - (list tagstr lap0 tagstr))) - (byte-compile-log-lap - " %s <%d unreachable op%s> %s\t-->\t%s %s" - lap0 i (if (= i 1) "" "s") - tagstr lap0 tagstr)))) - (rplacd rest tmp)) - (setq keep-going t)) - ;; - ;; unbind --> unbind - ;; (this may enable other optimizations.) - ;; - ((and (eq 'byte-unbind (car lap1)) - (memq (car lap0) byte-after-unbind-ops)) - (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0) - (setcar rest lap1) - (setcar (cdr rest) lap0) - (setq keep-going t)) - ;; - ;; varbind-X unbind-N --> discard unbind-(N-1) - ;; save-excursion unbind-N --> unbind-(N-1) - ;; save-restriction unbind-N --> unbind-(N-1) - ;; - ((and (eq 'byte-unbind (car lap1)) - (memq (car lap0) '(byte-varbind byte-save-excursion - byte-save-restriction)) - (< 0 (cdr lap1))) - (if (zerop (setcdr lap1 (1- (cdr lap1)))) - (delq lap1 rest)) - (if (eq (car lap0) 'byte-varbind) - (setcar rest (cons 'byte-discard 0)) + (cond + ;; pop --> + ;; ...including: + ;; const-X pop --> + ;; varref-X pop --> + ;; dup pop --> + ;; + ((and (eq 'byte-discard (car lap1)) + (memq (car lap0) side-effect-free)) + (setq keep-going t) + (setq tmp (aref byte-stack+-info (symbol-value (car lap0)))) + (setq rest (cdr rest)) + (cond ((= tmp 1) + (byte-compile-log-lap + " %s discard\t-->\t" lap0) + (setq lap (delq lap0 (delq lap1 lap)))) + ((= tmp 0) + (byte-compile-log-lap + " %s discard\t-->\t discard" lap0) (setq lap (delq lap0 lap))) - (byte-compile-log-lap " %s %s\t-->\t%s %s" - lap0 (cons (car lap1) (1+ (cdr lap1))) - (if (eq (car lap0) 'byte-varbind) - (car rest) - (car (cdr rest))) - (if (and (/= 0 (cdr lap1)) - (eq (car lap0) 'byte-varbind)) - (car (cdr rest)) - "")) - (setq keep-going t)) - ;; - ;; goto*-X ... X: goto-Y --> goto*-Y - ;; goto-X ... X: return --> return - ;; - ((and (memq (car lap0) byte-goto-ops) - (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap)))) - '(byte-goto byte-return))) - (cond ((and (not (eq tmp lap0)) - (or (eq (car lap0) 'byte-goto) - (eq (car tmp) 'byte-goto))) - (byte-compile-log-lap " %s [%s]\t-->\t%s" - (car lap0) tmp tmp) - (if (eq (car tmp) 'byte-return) - (setcar lap0 'byte-return)) - (setcdr lap0 (cdr tmp)) - (setq keep-going t)))) - ;; - ;; goto-*-else-pop X ... X: goto-if-* --> whatever - ;; goto-*-else-pop X ... X: discard --> whatever - ;; - ((and (memq (car lap0) '(byte-goto-if-nil-else-pop - byte-goto-if-not-nil-else-pop)) - (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap))))) - (eval-when-compile - (cons 'byte-discard byte-conditional-ops))) - (not (eq lap0 (car tmp)))) - (setq tmp2 (car tmp)) - (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop - byte-goto-if-nil) - (byte-goto-if-not-nil-else-pop - byte-goto-if-not-nil)))) - (if (memq (car tmp2) tmp3) - (progn (setcar lap0 (car tmp2)) - (setcdr lap0 (cdr tmp2)) - (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s" - (car lap0) tmp2 lap0)) - ;; Get rid of the -else-pop's and jump one step further. + ((= tmp -1) + (byte-compile-log-lap + " %s discard\t-->\tdiscard discard" lap0) + (setcar lap0 'byte-discard) + (setcdr lap0 0)) + ((error "Optimizer error: too much on the stack")))) + ;; + ;; goto*-X X: --> X: + ;; + ((and (memq (car lap0) byte-goto-ops) + (eq (cdr lap0) lap1)) + (cond ((eq (car lap0) 'byte-goto) + (setq lap (delq lap0 lap)) + (setq tmp "")) + ((memq (car lap0) byte-goto-always-pop-ops) + (setcar lap0 (setq tmp 'byte-discard)) + (setcdr lap0 0)) + ((error "Depth conflict at tag %d" (nth 2 lap0)))) + (and (memq byte-optimize-log '(t byte)) + (byte-compile-log " (goto %s) %s:\t-->\t%s %s:" + (nth 1 lap1) (nth 1 lap1) + tmp (nth 1 lap1))) + (setq keep-going t)) + ;; + ;; varset-X varref-X --> dup varset-X + ;; varbind-X varref-X --> dup varbind-X + ;; const/dup varset-X varref-X --> const/dup varset-X const/dup + ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup + ;; The latter two can enable other optimizations. + ;; + ;; For lexical variables, we could do the same + ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2 + ;; but this is a very minor gain, since dup is stack-ref-0, + ;; i.e. it's only better if X>5, and even then it comes + ;; at the cost of an extra stack slot. Let's not bother. + ((and (eq 'byte-varref (car lap2)) + (eq (cdr lap1) (cdr lap2)) + (memq (car lap1) '(byte-varset byte-varbind))) + (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) + (not (eq (car lap0) 'byte-constant))) + nil + (setq keep-going t) + (if (memq (car lap0) '(byte-constant byte-dup)) + (progn + (setq tmp (if (or (not tmp) + (macroexp--const-symbol-p + (car (cdr lap0)))) + (cdr lap0) + (byte-compile-get-constant t))) + (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s" + lap0 lap1 lap2 lap0 lap1 + (cons (car lap0) tmp)) + (setcar lap2 (car lap0)) + (setcdr lap2 tmp)) + (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1) + (setcar lap2 (car lap1)) + (setcar lap1 'byte-dup) + (setcdr lap1 0) + ;; The stack depth gets locally increased, so we will + ;; increase maxdepth in case depth = maxdepth here. + ;; This can cause the third argument to byte-code to + ;; be larger than necessary. + (setq add-depth 1)))) + ;; + ;; dup varset-X discard --> varset-X + ;; dup varbind-X discard --> varbind-X + ;; dup stack-set-X discard --> stack-set-X-1 + ;; (the varbind variant can emerge from other optimizations) + ;; + ((and (eq 'byte-dup (car lap0)) + (eq 'byte-discard (car lap2)) + (memq (car lap1) '(byte-varset byte-varbind + byte-stack-set))) + (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) + (setq keep-going t + rest (cdr rest)) + (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1))) + (setq lap (delq lap0 (delq lap2 lap)))) + ;; + ;; not goto-X-if-nil --> goto-X-if-non-nil + ;; not goto-X-if-non-nil --> goto-X-if-nil + ;; + ;; it is wrong to do the same thing for the -else-pop variants. + ;; + ((and (eq 'byte-not (car lap0)) + (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil))) + (byte-compile-log-lap " not %s\t-->\t%s" + lap1 + (cons + (if (eq (car lap1) 'byte-goto-if-nil) + 'byte-goto-if-not-nil + 'byte-goto-if-nil) + (cdr lap1))) + (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil) + 'byte-goto-if-not-nil + 'byte-goto-if-nil)) + (setq lap (delq lap0 lap)) + (setq keep-going t)) + ;; + ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: + ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: + ;; + ;; it is wrong to do the same thing for the -else-pop variants. + ;; + ((and (memq (car lap0) + '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX + (eq 'byte-goto (car lap1)) ; gotoY + (eq (cdr lap0) lap2)) ; TAG X + (let ((inverse (if (eq 'byte-goto-if-nil (car lap0)) + 'byte-goto-if-not-nil 'byte-goto-if-nil))) + (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:" + lap0 lap1 lap2 + (cons inverse (cdr lap1)) lap2) + (setq lap (delq lap0 lap)) + (setcar lap1 inverse) + (setq keep-going t))) + ;; + ;; const goto-if-* --> whatever + ;; + ((and (eq 'byte-constant (car lap0)) + (memq (car lap1) byte-conditional-ops) + ;; If the `byte-constant's cdr is not a cons cell, it has + ;; to be an index into the constant pool); even though + ;; it'll be a constant, that constant is not known yet + ;; (it's typically a free variable of a closure, so will + ;; only be known when the closure will be built at + ;; run-time). + (consp (cdr lap0))) + (cond ((if (memq (car lap1) '(byte-goto-if-nil + byte-goto-if-nil-else-pop)) + (car (cdr lap0)) + (not (car (cdr lap0)))) + (byte-compile-log-lap " %s %s\t-->\t" + lap0 lap1) + (setq rest (cdr rest) + lap (delq lap0 (delq lap1 lap)))) + (t + (byte-compile-log-lap " %s %s\t-->\t%s" + lap0 lap1 + (cons 'byte-goto (cdr lap1))) + (when (memq (car lap1) byte-goto-always-pop-ops) + (setq lap (delq lap0 lap))) + (setcar lap1 'byte-goto))) + (setq keep-going t)) + ;; + ;; varref-X varref-X --> varref-X dup + ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup + ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup + ;; We don't optimize the const-X variations on this here, + ;; because that would inhibit some goto optimizations; we + ;; optimize the const-X case after all other optimizations. + ;; + ((and (memq (car lap0) '(byte-varref byte-stack-ref)) + (progn + (setq tmp (cdr rest)) + (setq tmp2 0) + (while (eq (car (car tmp)) 'byte-dup) + (setq tmp2 (1+ tmp2)) + (setq tmp (cdr tmp))) + t) + (eq (if (eq 'byte-stack-ref (car lap0)) + (+ tmp2 1 (cdr lap0)) + (cdr lap0)) + (cdr (car tmp))) + (eq (car lap0) (car (car tmp)))) + (if (memq byte-optimize-log '(t byte)) + (let ((str "")) + (setq tmp2 (cdr rest)) + (while (not (eq tmp tmp2)) + (setq tmp2 (cdr tmp2) + str (concat str " dup"))) + (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup" + lap0 str lap0 lap0 str))) + (setq keep-going t) + (setcar (car tmp) 'byte-dup) + (setcdr (car tmp) 0) + (setq rest tmp)) + ;; + ;; TAG1: TAG2: --> TAG1: + ;; (and other references to TAG2 are replaced with TAG1) + ;; + ((and (eq (car lap0) 'TAG) + (eq (car lap1) 'TAG)) + (and (memq byte-optimize-log '(t byte)) + (byte-compile-log " adjacent tags %d and %d merged" + (nth 1 lap1) (nth 1 lap0))) + (setq tmp3 lap) + (while (setq tmp2 (rassq lap0 tmp3)) + (setcdr tmp2 lap1) + (setq tmp3 (cdr (memq tmp2 tmp3)))) + (setq lap (delq lap0 lap) + keep-going t) + ;; replace references to tag in jump tables, if any + (dolist (table byte-compile-jump-tables) + (maphash #'(lambda (value tag) + (when (equal tag lap0) + (puthash value lap1 table))) + table))) + ;; + ;; unused-TAG: --> + ;; + ((and (eq 'TAG (car lap0)) + (not (rassq lap0 lap)) + ;; make sure this tag isn't used in a jump-table + (cl-loop for table in byte-compile-jump-tables + when (member lap0 (hash-table-values table)) + return nil finally return t)) + (and (memq byte-optimize-log '(t byte)) + (byte-compile-log " unused tag %d removed" (nth 1 lap0))) + (setq lap (delq lap0 lap) + keep-going t)) + ;; + ;; goto ... --> goto + ;; return ... --> return + ;; (unless a jump-table is being used, where deleting may affect + ;; other valid case bodies) + ;; + ((and (memq (car lap0) '(byte-goto byte-return)) + (not (memq (car lap1) '(TAG nil))) + ;; FIXME: Instead of deferring simply when jump-tables are + ;; being used, keep a list of tags used for switch tags and + ;; use them instead (see `byte-compile-inline-lapcode'). + (not byte-compile-jump-tables)) + (setq tmp rest) + (let ((i 0) + (opt-p (memq byte-optimize-log '(t lap))) + str deleted) + (while (and (setq tmp (cdr tmp)) + (not (eq 'TAG (car (car tmp))))) + (if opt-p (setq deleted (cons (car tmp) deleted) + str (concat str " %s") + i (1+ i)))) + (if opt-p + (let ((tagstr + (if (eq 'TAG (car (car tmp))) + (format "%d:" (car (cdr (car tmp)))) + (or (car tmp) "")))) + (if (< i 6) + (apply 'byte-compile-log-lap-1 + (concat " %s" str + " %s\t-->\t%s %s") + lap0 + (nconc (nreverse deleted) + (list tagstr lap0 tagstr))) + (byte-compile-log-lap + " %s <%d unreachable op%s> %s\t-->\t%s %s" + lap0 i (if (= i 1) "" "s") + tagstr lap0 tagstr)))) + (rplacd rest tmp)) + (setq keep-going t)) + ;; + ;; unbind --> unbind + ;; (this may enable other optimizations.) + ;; + ((and (eq 'byte-unbind (car lap1)) + (memq (car lap0) byte-after-unbind-ops)) + (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0) + (setcar rest lap1) + (setcar (cdr rest) lap0) + (setq keep-going t)) + ;; + ;; varbind-X unbind-N --> discard unbind-(N-1) + ;; save-excursion unbind-N --> unbind-(N-1) + ;; save-restriction unbind-N --> unbind-(N-1) + ;; + ((and (eq 'byte-unbind (car lap1)) + (memq (car lap0) '(byte-varbind byte-save-excursion + byte-save-restriction)) + (< 0 (cdr lap1))) + (if (zerop (setcdr lap1 (1- (cdr lap1)))) + (delq lap1 rest)) + (if (eq (car lap0) 'byte-varbind) + (setcar rest (cons 'byte-discard 0)) + (setq lap (delq lap0 lap))) + (byte-compile-log-lap " %s %s\t-->\t%s %s" + lap0 (cons (car lap1) (1+ (cdr lap1))) + (if (eq (car lap0) 'byte-varbind) + (car rest) + (car (cdr rest))) + (if (and (/= 0 (cdr lap1)) + (eq (car lap0) 'byte-varbind)) + (car (cdr rest)) + "")) + (setq keep-going t)) + ;; + ;; goto*-X ... X: goto-Y --> goto*-Y + ;; goto-X ... X: return --> return + ;; + ((and (memq (car lap0) byte-goto-ops) + (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap)))) + '(byte-goto byte-return))) + (cond ((and (not (eq tmp lap0)) + (or (eq (car lap0) 'byte-goto) + (eq (car tmp) 'byte-goto))) + (byte-compile-log-lap " %s [%s]\t-->\t%s" + (car lap0) tmp tmp) + (if (eq (car tmp) 'byte-return) + (setcar lap0 'byte-return)) + (setcdr lap0 (cdr tmp)) + (setq keep-going t)))) + ;; + ;; goto-*-else-pop X ... X: goto-if-* --> whatever + ;; goto-*-else-pop X ... X: discard --> whatever + ;; + ((and (memq (car lap0) '(byte-goto-if-nil-else-pop + byte-goto-if-not-nil-else-pop)) + (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap))))) + (eval-when-compile + (cons 'byte-discard byte-conditional-ops))) + (not (eq lap0 (car tmp)))) + (setq tmp2 (car tmp)) + (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop + byte-goto-if-nil) + (byte-goto-if-not-nil-else-pop + byte-goto-if-not-nil)))) + (if (memq (car tmp2) tmp3) + (progn (setcar lap0 (car tmp2)) + (setcdr lap0 (cdr tmp2)) + (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s" + (car lap0) tmp2 lap0)) + ;; Get rid of the -else-pop's and jump one step further. + (or (eq 'TAG (car (nth 1 tmp))) + (setcdr tmp (cons (byte-compile-make-tag) + (cdr tmp)))) + (byte-compile-log-lap " %s [%s]\t-->\t%s " + (car lap0) tmp2 (nth 1 tmp3)) + (setcar lap0 (nth 1 tmp3)) + (setcdr lap0 (nth 1 tmp))) + (setq keep-going t)) + ;; + ;; const goto-X ... X: goto-if-* --> whatever + ;; const goto-X ... X: discard --> whatever + ;; + ((and (eq (car lap0) 'byte-constant) + (eq (car lap1) 'byte-goto) + (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap))))) + (eval-when-compile + (cons 'byte-discard byte-conditional-ops))) + (not (eq lap1 (car tmp)))) + (setq tmp2 (car tmp)) + (cond ((when (consp (cdr lap0)) + (memq (car tmp2) + (if (null (car (cdr lap0))) + '(byte-goto-if-nil byte-goto-if-nil-else-pop) + '(byte-goto-if-not-nil + byte-goto-if-not-nil-else-pop)))) + (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s" + lap0 tmp2 lap0 tmp2) + (setcar lap1 (car tmp2)) + (setcdr lap1 (cdr tmp2)) + ;; Let next step fix the (const,goto-if*) sequence. + (setq rest (cons nil rest)) + (setq keep-going t)) + ((or (consp (cdr lap0)) + (eq (car tmp2) 'byte-discard)) + ;; Jump one step further + (byte-compile-log-lap + " %s goto [%s]\t-->\t goto " + lap0 tmp2) (or (eq 'TAG (car (nth 1 tmp))) (setcdr tmp (cons (byte-compile-make-tag) (cdr tmp)))) - (byte-compile-log-lap " %s [%s]\t-->\t%s " - (car lap0) tmp2 (nth 1 tmp3)) - (setcar lap0 (nth 1 tmp3)) - (setcdr lap0 (nth 1 tmp))) - (setq keep-going t)) - ;; - ;; const goto-X ... X: goto-if-* --> whatever - ;; const goto-X ... X: discard --> whatever - ;; - ((and (eq (car lap0) 'byte-constant) - (eq (car lap1) 'byte-goto) - (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap))))) - (eval-when-compile - (cons 'byte-discard byte-conditional-ops))) - (not (eq lap1 (car tmp)))) - (setq tmp2 (car tmp)) - (cond ((when (consp (cdr lap0)) - (memq (car tmp2) - (if (null (car (cdr lap0))) - '(byte-goto-if-nil byte-goto-if-nil-else-pop) - '(byte-goto-if-not-nil - byte-goto-if-not-nil-else-pop)))) - (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s" - lap0 tmp2 lap0 tmp2) - (setcar lap1 (car tmp2)) - (setcdr lap1 (cdr tmp2)) - ;; Let next step fix the (const,goto-if*) sequence. - (setq rest (cons nil rest)) - (setq keep-going t)) - ((or (consp (cdr lap0)) - (eq (car tmp2) 'byte-discard)) - ;; Jump one step further - (byte-compile-log-lap - " %s goto [%s]\t-->\t goto " - lap0 tmp2) - (or (eq 'TAG (car (nth 1 tmp))) - (setcdr tmp (cons (byte-compile-make-tag) - (cdr tmp)))) - (setcdr lap1 (car (cdr tmp))) - (setq lap (delq lap0 lap)) - (setq keep-going t)))) - ;; - ;; X: varref-Y ... varset-Y goto-X --> - ;; X: varref-Y Z: ... dup varset-Y goto-Z - ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) - ;; (This is so usual for while loops that it is worth handling). - ;; - ;; Here again, we could do it for stack-ref/stack-set, but - ;; that's replacing a stack-ref-Y with a stack-ref-0, which - ;; is a very minor improvement (if any), at the cost of - ;; more stack use and more byte-code. Let's not do it. - ;; - ((and (eq (car lap1) 'byte-varset) - (eq (car lap2) 'byte-goto) - (not (memq (cdr lap2) rest)) ;Backwards jump - (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap))))) - 'byte-varref) - (eq (cdr (car tmp)) (cdr lap1)) - (not (memq (car (cdr lap1)) byte-boolean-vars))) - ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp)) - (let ((newtag (byte-compile-make-tag))) - (byte-compile-log-lap - " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s" - (nth 1 (cdr lap2)) (car tmp) - lap1 lap2 - (nth 1 (cdr lap2)) (car tmp) - (nth 1 newtag) 'byte-dup lap1 - (cons 'byte-goto newtag) - ) - (setcdr rest (cons (cons 'byte-dup 0) (cdr rest))) - (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp)))) - (setq add-depth 1) - (setq keep-going t)) - ;; - ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y: - ;; (This can pull the loop test to the end of the loop) - ;; - ((and (eq (car lap0) 'byte-goto) - (eq (car lap1) 'TAG) - (eq lap1 - (cdr (car (setq tmp (cdr (memq (cdr lap0) lap)))))) - (memq (car (car tmp)) - '(byte-goto byte-goto-if-nil byte-goto-if-not-nil - byte-goto-if-nil-else-pop))) -;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional" -;; lap0 lap1 (cdr lap0) (car tmp)) - (let ((newtag (byte-compile-make-tag))) - (byte-compile-log-lap - "%s %s: ... %s: %s\t-->\t%s ... %s:" - lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp) - (cons (cdr (assq (car (car tmp)) - '((byte-goto-if-nil . byte-goto-if-not-nil) - (byte-goto-if-not-nil . byte-goto-if-nil) - (byte-goto-if-nil-else-pop . - byte-goto-if-not-nil-else-pop) - (byte-goto-if-not-nil-else-pop . - byte-goto-if-nil-else-pop)))) - newtag) + (setcdr lap1 (car (cdr tmp))) + (setq lap (delq lap0 lap)) + (setq keep-going t)))) + ;; + ;; X: varref-Y ... varset-Y goto-X --> + ;; X: varref-Y Z: ... dup varset-Y goto-Z + ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) + ;; (This is so usual for while loops that it is worth handling). + ;; + ;; Here again, we could do it for stack-ref/stack-set, but + ;; that's replacing a stack-ref-Y with a stack-ref-0, which + ;; is a very minor improvement (if any), at the cost of + ;; more stack use and more byte-code. Let's not do it. + ;; + ((and (eq (car lap1) 'byte-varset) + (eq (car lap2) 'byte-goto) + (not (memq (cdr lap2) rest)) ;Backwards jump + (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap))))) + 'byte-varref) + (eq (cdr (car tmp)) (cdr lap1)) + (not (memq (car (cdr lap1)) byte-boolean-vars))) + ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp)) + (let ((newtag (byte-compile-make-tag))) + (byte-compile-log-lap + " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s" + (nth 1 (cdr lap2)) (car tmp) + lap1 lap2 + (nth 1 (cdr lap2)) (car tmp) + (nth 1 newtag) 'byte-dup lap1 + (cons 'byte-goto newtag) + ) + (setcdr rest (cons (cons 'byte-dup 0) (cdr rest))) + (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp)))) + (setq add-depth 1) + (setq keep-going t)) + ;; + ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y: + ;; (This can pull the loop test to the end of the loop) + ;; + ((and (eq (car lap0) 'byte-goto) + (eq (car lap1) 'TAG) + (eq lap1 + (cdr (car (setq tmp (cdr (memq (cdr lap0) lap)))))) + (memq (car (car tmp)) + '(byte-goto byte-goto-if-nil byte-goto-if-not-nil + byte-goto-if-nil-else-pop))) + ;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional" + ;; lap0 lap1 (cdr lap0) (car tmp)) + (let ((newtag (byte-compile-make-tag))) + (byte-compile-log-lap + "%s %s: ... %s: %s\t-->\t%s ... %s:" + lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp) + (cons (cdr (assq (car (car tmp)) + '((byte-goto-if-nil . byte-goto-if-not-nil) + (byte-goto-if-not-nil . byte-goto-if-nil) + (byte-goto-if-nil-else-pop . + byte-goto-if-not-nil-else-pop) + (byte-goto-if-not-nil-else-pop . + byte-goto-if-nil-else-pop)))) + newtag) - (nth 1 newtag) - ) - (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp))) - (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop) - ;; We can handle this case but not the -if-not-nil case, - ;; because we won't know which non-nil constant to push. - (setcdr rest (cons (cons 'byte-constant - (byte-compile-get-constant nil)) - (cdr rest)))) - (setcar lap0 (nth 1 (memq (car (car tmp)) - '(byte-goto-if-nil-else-pop - byte-goto-if-not-nil - byte-goto-if-nil - byte-goto-if-not-nil - byte-goto byte-goto)))) - ) - (setq keep-going t)) - ) + (nth 1 newtag) + ) + (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp))) + (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop) + ;; We can handle this case but not the -if-not-nil case, + ;; because we won't know which non-nil constant to push. + (setcdr rest (cons (cons 'byte-constant + (byte-compile-get-constant nil)) + (cdr rest)))) + (setcar lap0 (nth 1 (memq (car (car tmp)) + '(byte-goto-if-nil-else-pop + byte-goto-if-not-nil + byte-goto-if-nil + byte-goto-if-not-nil + byte-goto byte-goto)))) + ) + (setq keep-going t)) + ) (setq rest (cdr rest))) ) ;; Cleanup stage: From 4dfebf25c743d4ba4506919b58591f74debfb334 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 20 Jan 2021 13:59:58 -0500 Subject: [PATCH 073/133] * lisp/emacs-lisp/byte-opt.el (byte-optimize-lapcode): Move some opts. This moves two optimizations from the final pass to the main loop. Both may enable further optimizations (and the second can be applied repeatedly but "from the end", so the loop in the final pass only gets to apply it once). --- lisp/emacs-lisp/byte-opt.el | 99 +++++++++++++++++++------------------ 1 file changed, 50 insertions(+), 49 deletions(-) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 6d1f4179ce1..620bd91b646 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -2021,6 +2021,56 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." byte-goto byte-goto)))) ) (setq keep-going t)) + + ;; + ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos + ;; stack-set-M [discard/discardN ...] --> discardN + ;; + ((and (eq (car lap0) 'byte-stack-set) + (memq (car lap1) '(byte-discard byte-discardN)) + (progn + ;; See if enough discard operations follow to expose or + ;; destroy the value stored by the stack-set. + (setq tmp (cdr rest)) + (setq tmp2 (1- (cdr lap0))) + (setq tmp3 0) + (while (memq (car (car tmp)) '(byte-discard byte-discardN)) + (setq tmp3 + (+ tmp3 (if (eq (car (car tmp)) 'byte-discard) + 1 + (cdr (car tmp))))) + (setq tmp (cdr tmp))) + (>= tmp3 tmp2))) + ;; Do the optimization. + (setq lap (delq lap0 lap)) + (setcar lap1 + (if (= tmp2 tmp3) + ;; The value stored is the new TOS, so pop one more + ;; value (to get rid of the old value) using the + ;; TOS-preserving discard operator. + 'byte-discardN-preserve-tos + ;; Otherwise, the value stored is lost, so just use a + ;; normal discard. + 'byte-discardN)) + (setcdr lap1 (1+ tmp3)) + (setcdr (cdr rest) tmp) + (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s" + lap0 lap1)) + ;; + ;; discardN-preserve-tos return --> return + ;; dup return --> return + ;; stack-set-N return --> return ; where N is TOS-1 + ;; + ((and (eq (car lap1) 'byte-return) + (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup)) + (and (eq (car lap0) 'byte-stack-set) + (= (cdr lap0) 1)))) + (setq keep-going t) + ;; The byte-code interpreter will pop the stack for us, so + ;; we can just leave stuff on it. + (setq lap (delq lap0 lap)) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1)) + ) (setq rest (cdr rest))) ) @@ -2084,41 +2134,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (setq lap (delq lap0 lap)) (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) - ;; - ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos - ;; stack-set-M [discard/discardN ...] --> discardN - ;; - ((and (eq (car lap0) 'byte-stack-set) - (memq (car lap1) '(byte-discard byte-discardN)) - (progn - ;; See if enough discard operations follow to expose or - ;; destroy the value stored by the stack-set. - (setq tmp (cdr rest)) - (setq tmp2 (1- (cdr lap0))) - (setq tmp3 0) - (while (memq (car (car tmp)) '(byte-discard byte-discardN)) - (setq tmp3 - (+ tmp3 (if (eq (car (car tmp)) 'byte-discard) - 1 - (cdr (car tmp))))) - (setq tmp (cdr tmp))) - (>= tmp3 tmp2))) - ;; Do the optimization. - (setq lap (delq lap0 lap)) - (setcar lap1 - (if (= tmp2 tmp3) - ;; The value stored is the new TOS, so pop one more - ;; value (to get rid of the old value) using the - ;; TOS-preserving discard operator. - 'byte-discardN-preserve-tos - ;; Otherwise, the value stored is lost, so just use a - ;; normal discard. - 'byte-discardN)) - (setcdr lap1 (1+ tmp3)) - (setcdr (cdr rest) tmp) - (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s" - lap0 lap1)) - ;; ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y --> ;; discardN-(X+Y) @@ -2146,20 +2161,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (setq lap (delq lap0 lap)) (setcdr lap1 (+ (cdr lap0) (cdr lap1))) (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest))) - - ;; - ;; discardN-preserve-tos return --> return - ;; dup return --> return - ;; stack-set-N return --> return ; where N is TOS-1 - ;; - ((and (eq (car lap1) 'byte-return) - (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup)) - (and (eq (car lap0) 'byte-stack-set) - (= (cdr lap0) 1)))) - ;; The byte-code interpreter will pop the stack for us, so - ;; we can just leave stuff on it. - (setq lap (delq lap0 lap)) - (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1)) ) (setq rest (cdr rest))) (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))) From 66439d31ad2a63753d29e4582b76b36b9363d96b Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 20 Jan 2021 14:08:35 -0500 Subject: [PATCH 074/133] * lisp/emacs-lisp/byte-opt.el (byte-optimize-lapcode): Add 2 new opts This introduces two new optimizations. They're designed for code like (while (let (...) (if ... (progn blabla t) (progn blabla nil))) ...) and they allow the elimination of the test internal to `while` since we can immediately know when we return `t` or `nil` what the result of the test will be. `cl-labels` tends to generate this kind of code when it applies the tail-call optimization. --- lisp/emacs-lisp/byte-opt.el | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 620bd91b646..cfa407019a7 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -2056,6 +2056,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (setcdr (cdr rest) tmp) (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s" lap0 lap1)) + ;; ;; discardN-preserve-tos return --> return ;; dup return --> return @@ -2071,6 +2072,36 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (setq lap (delq lap0 lap)) (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1)) + ;; + ;; goto-X ... X: discard ==> discard goto-Y ... X: discard Y: + ;; + ((and (eq (car lap0) 'byte-goto) + (setq tmp (cdr (memq (cdr lap0) lap))) + (memq (caar tmp) '(byte-discard byte-discardN + byte-discardN-preserve-tos))) + (byte-compile-log-lap + " goto-X .. X: \t-->\t%s goto-X.. X: %s Y:" + (car tmp) (car tmp)) + (setq keep-going t) + (let* ((newtag (byte-compile-make-tag)) + ;; Make a copy, since we sometimes modify insts in-place! + (newdiscard (cons (caar tmp) (cdar tmp))) + (newjmp (cons (car lap0) newtag))) + (push newtag (cdr tmp)) ;Push new tag after the discard. + (setcar rest newdiscard) + (push newjmp (cdr rest)))) + + ;; + ;; const discardN-preserve-tos ==> discardN const + ;; + ((and (eq (car lap0) 'byte-constant) + (eq (car lap1) 'byte-discardN-preserve-tos)) + (setq keep-going t) + (let ((newdiscard (cons 'byte-discardN (cdr lap1)))) + (byte-compile-log-lap + " %s %s\t-->\t%s %s" lap0 lap1 newdiscard lap0) + (setf (car rest) newdiscard) + (setf (cadr rest) lap0))) ) (setq rest (cdr rest))) ) From 0d3635536d4ed8ada6946e98e7d9f03fa443bc36 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 20 Jan 2021 14:12:50 -0500 Subject: [PATCH 075/133] * lisp/emacs-lisp/subr-x.el (named-let): New macro --- etc/NEWS | 12 +++++++----- lisp/emacs-lisp/subr-x.el | 22 ++++++++++++++++++++++ 2 files changed, 29 insertions(+), 5 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index c8cbce1882a..59b13998cfa 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1554,6 +1554,13 @@ buttons in it. This function takes a string and returns a string propertized in a way that makes it a valid button. +** subr-x ++++ +*** A number of new string manipulation functions have been added. +'string-clean-whitespace', 'string-fill', 'string-limit', +'string-lines', 'string-pad' and 'string-chop-newline'. + +*** New macro `named-let` that provides Scheme's "named let" looping construct ** Miscellaneous @@ -1593,11 +1600,6 @@ length to a number). *** New user option 'authinfo-hide-elements'. This can be set to nil to inhibit hiding passwords in ".authinfo" files. -+++ -*** A number of new string manipulation functions have been added. -'string-clean-whitespace', 'string-fill', 'string-limit', -'string-lines', 'string-pad' and 'string-chop-newline'. - +++ *** New variable 'current-minibuffer-command'. This is like 'this-command', but it is bound recursively when entering diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index b90227da42f..a4514454c0b 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -389,6 +389,28 @@ it makes no sense to convert it to a string using (set-buffer source-buffer) (replace-buffer-contents tmp-buffer max-secs max-costs))))))))) +(defmacro named-let (name bindings &rest body) + "Looping construct taken from Scheme. +Like `let', bind variables in BINDINGS and then evaluate BODY, +but with the twist that BODY can evaluate itself recursively by +calling NAME, where the arguments passed to NAME are used +as the new values of the bound variables in the recursive invocation." + (declare (indent 2) (debug (symbolp (&rest (symbolp form)) body))) + (require 'cl-lib) + (let ((fargs (mapcar (lambda (b) (if (consp b) (car b) b)) bindings)) + (aargs (mapcar (lambda (b) (if (consp b) (cadr b))) bindings))) + ;; According to the Scheme semantics of named let, `name' is not in scope + ;; while evaluating the expressions in `bindings', and for this reason, the + ;; "initial" function call below needs to be outside of the `cl-labels'. + ;; When the "self-tco" eliminates all recursive calls, the `cl-labels' + ;; expands to a lambda which the byte-compiler then combines with the + ;; funcall to make a `let' so we end up with a plain `while' loop and no + ;; remaining `lambda' at all. + `(funcall + (cl-labels ((,name ,fargs . ,body)) #',name) + . ,aargs))) + + (provide 'subr-x) ;;; subr-x.el ends here From 5065698c81dcf241fc234c78bffea54af4203892 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Wed, 20 Jan 2021 21:19:23 +0200 Subject: [PATCH 076/133] =?UTF-8?q?Move=20the=20=E2=80=98declare=E2=80=99?= =?UTF-8?q?=20form=20before=20the=20interactive=20spec=20in=2010=20functio?= =?UTF-8?q?ns.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * lisp/emacs-lisp/package.el (package-menu-hide-package): * lisp/font-lock.el (font-lock-debug-fontify): * lisp/image.el (image-jpeg-p): * lisp/mail/flow-fill.el (fill-flowed-test): * lisp/mh-e/mh-speed.el (mh-speed-toggle, mh-speed-view): * lisp/progmodes/project.el (project-async-shell-command) (project-shell-command, project-compile): * lisp/progmodes/sh-script.el (sh-assignment): Fix special forms to follow in this order: docstring, declare, interactive. --- lisp/emacs-lisp/package.el | 2 +- lisp/font-lock.el | 2 +- lisp/image.el | 2 +- lisp/mail/flow-fill.el | 2 +- lisp/mh-e/mh-speed.el | 4 ++-- lisp/progmodes/project.el | 6 +++--- lisp/progmodes/sh-script.el | 2 +- 7 files changed, 10 insertions(+), 10 deletions(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 453e86c7831..90b7b88d58a 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -3260,9 +3260,9 @@ To unhide a package, type `\\[customize-variable] RET package-hidden-regexps'. Type \\[package-menu-toggle-hiding] to toggle package hiding." + (declare (interactive-only "change `package-hidden-regexps' instead.")) (interactive) (package--ensure-package-menu-mode) - (declare (interactive-only "change `package-hidden-regexps' instead.")) (let* ((name (when (derived-mode-p 'package-menu-mode) (concat "\\`" (regexp-quote (symbol-name (package-desc-name (tabulated-list-get-id)))) diff --git a/lisp/font-lock.el b/lisp/font-lock.el index a51434c38c9..a9fc69d419a 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -1104,8 +1104,8 @@ Called with two arguments BEG and END.") "Reinitialize the font-lock machinery and (re-)fontify the buffer. This functions is a convenience functions when developing font locking for a mode, and is not meant to be called from lisp functions." - (interactive) (declare (interactive-only t)) + (interactive) ;; Make font-lock recalculate all the mode-specific data. (setq font-lock-major-mode nil) ;; Make the syntax machinery discard all information. diff --git a/lisp/image.el b/lisp/image.el index 814035594b6..6955a90de77 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -264,9 +264,9 @@ compatibility with versions of Emacs that lack the variable ;; Used to be in image-type-header-regexps, but now not used anywhere ;; (since 2009-08-28). (defun image-jpeg-p (data) - (declare (obsolete "It is unused inside Emacs and will be removed." "27.1")) "Value is non-nil if DATA, a string, consists of JFIF image data. We accept the tag Exif because that is the same format." + (declare (obsolete "It is unused inside Emacs and will be removed." "27.1")) (setq data (ignore-errors (string-to-unibyte data))) (when (and data (string-match-p "\\`\xff\xd8" data)) (catch 'jfif diff --git a/lisp/mail/flow-fill.el b/lisp/mail/flow-fill.el index e93ba547a89..0fab1b21b47 100644 --- a/lisp/mail/flow-fill.el +++ b/lisp/mail/flow-fill.el @@ -174,8 +174,8 @@ lines." (defvar fill-flowed-encode-tests) (defun fill-flowed-test () - (interactive "") (declare (obsolete nil "27.1")) + (interactive "") (user-error (concat "This function is obsolete. Please see " "test/lisp/mail/flow-fill-tests.el " "in the Emacs source tree"))) diff --git a/lisp/mh-e/mh-speed.el b/lisp/mh-e/mh-speed.el index 35d5884b16c..00b96804174 100644 --- a/lisp/mh-e/mh-speed.el +++ b/lisp/mh-e/mh-speed.el @@ -128,8 +128,8 @@ With non-nil FORCE, the update is always carried out." (defun mh-speed-toggle (&rest ignored) "Toggle the display of child folders in the speedbar. The optional arguments from speedbar are IGNORED." - (interactive) (declare (ignore args)) + (interactive) (beginning-of-line) (let ((parent (get-text-property (point) 'mh-folder)) (kids-p (get-text-property (point) 'mh-children-p)) @@ -167,8 +167,8 @@ The optional arguments from speedbar are IGNORED." (defun mh-speed-view (&rest ignored) "Visits the selected folder just as if you had used \\\\[mh-visit-folder]. The optional arguments from speedbar are IGNORED." - (interactive) (declare (ignore args)) + (interactive) (let* ((folder (get-text-property (mh-line-beginning-position) 'mh-folder)) (range (and (stringp folder) (mh-read-range "Scan" folder t nil nil diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 18124227d1b..768cd58ae44 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -928,16 +928,16 @@ if one already exists." ;;;###autoload (defun project-async-shell-command () "Run `async-shell-command' in the current project's root directory." - (interactive) (declare (interactive-only async-shell-command)) + (interactive) (let ((default-directory (project-root (project-current t)))) (call-interactively #'async-shell-command))) ;;;###autoload (defun project-shell-command () "Run `shell-command' in the current project's root directory." - (interactive) (declare (interactive-only shell-command)) + (interactive) (let ((default-directory (project-root (project-current t)))) (call-interactively #'shell-command))) @@ -974,8 +974,8 @@ loop using the command \\[fileloop-continue]." ;;;###autoload (defun project-compile () "Run `compile' in the project root." - (interactive) (declare (interactive-only compile)) + (interactive) (let ((default-directory (project-root (project-current t)))) (call-interactively #'compile))) diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index d3692d47205..cc045a1b2d1 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -2927,8 +2927,8 @@ option followed by a colon `:' if the option accepts an argument." (put 'sh-assignment 'delete-selection t) (defun sh-assignment (arg) "Remember preceding identifier for future completion and do self-insert." - (interactive "p") (declare (obsolete nil "27.1")) + (interactive "p") (self-insert-command arg) (sh--assignment-collect)) From 93141d581330d94e7eec9f114def2bec15f87866 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 20 Jan 2021 21:46:30 +0100 Subject: [PATCH 077/133] Always send Lisp words to checkdoc-ispell-init * lisp/emacs-lisp/checkdoc.el (checkdoc-ispell-init): Always send the Lisp words to the process (bug#6221). This allows an existing ispell process to be correctly initialised. --- lisp/emacs-lisp/checkdoc.el | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 2e204ff7aea..aae807b8c18 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -2106,12 +2106,14 @@ nil." (unless ispell-process (condition-case nil (progn - (ispell-set-spellchecker-params) ; Initialize variables and dict alists. - (ispell-accept-buffer-local-defs) ; Use the correct dictionary. - ;; This code copied in part from ispell.el Emacs 19.34 - (dolist (w checkdoc-ispell-lisp-words) - (process-send-string ispell-process (concat "@" w "\n")))) - (error (setq checkdoc-spellcheck-documentation-flag nil))))) + ;; Initialize variables and dict alists. + (ispell-set-spellchecker-params) + ;; Use the correct dictionary. + (ispell-accept-buffer-local-defs)) + (error (setq checkdoc-spellcheck-documentation-flag nil)))) + ;; This code copied in part from ispell.el Emacs 19.34 + (dolist (w checkdoc-ispell-lisp-words) + (process-send-string ispell-process (concat "@" w "\n")))) (defun checkdoc-ispell-docstring-engine (end &optional take-notes) "Run the Ispell tools on the doc string between point and END. From 1a6ed932d9d9779419f403e32e911f86657cb9f7 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 20 Jan 2021 22:11:38 +0100 Subject: [PATCH 078/133] Revert "Always send Lisp words to checkdoc-ispell-init" This reverts commit 93141d581330d94e7eec9f114def2bec15f87866. This would make checkdoc words be used in other flyspell buffers. --- lisp/emacs-lisp/checkdoc.el | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index aae807b8c18..2e204ff7aea 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -2106,14 +2106,12 @@ nil." (unless ispell-process (condition-case nil (progn - ;; Initialize variables and dict alists. - (ispell-set-spellchecker-params) - ;; Use the correct dictionary. - (ispell-accept-buffer-local-defs)) - (error (setq checkdoc-spellcheck-documentation-flag nil)))) - ;; This code copied in part from ispell.el Emacs 19.34 - (dolist (w checkdoc-ispell-lisp-words) - (process-send-string ispell-process (concat "@" w "\n")))) + (ispell-set-spellchecker-params) ; Initialize variables and dict alists. + (ispell-accept-buffer-local-defs) ; Use the correct dictionary. + ;; This code copied in part from ispell.el Emacs 19.34 + (dolist (w checkdoc-ispell-lisp-words) + (process-send-string ispell-process (concat "@" w "\n")))) + (error (setq checkdoc-spellcheck-documentation-flag nil))))) (defun checkdoc-ispell-docstring-engine (end &optional take-notes) "Run the Ispell tools on the doc string between point and END. From 61b716bd3034ac50829ef66399c14113a903f82a Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 20 Jan 2021 22:15:38 +0100 Subject: [PATCH 079/133] checkdoc-spellcheck-documentation-flag doc string improvement * lisp/emacs-lisp/checkdoc.el (checkdoc-spellcheck-documentation-flag): Mention `ispell-kill-ispell' (bug#6221). --- lisp/emacs-lisp/checkdoc.el | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 2e204ff7aea..76638ec13b1 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -241,7 +241,12 @@ system. Possible values are: defun - Spell-check when style checking a single defun. buffer - Spell-check when style checking the whole buffer. interactive - Spell-check during any interactive check. - t - Always spell-check." + t - Always spell-check. + +There is a list of Lisp-specific words which checkdoc will +install into Ispell on the fly, but only if Ispell is not already +running. Use `ispell-kill-ispell' to make checkdoc restart it +with these words enabled." :type '(choice (const nil) (const defun) (const buffer) From 0df23b73e4718937bcaddf9008ad8ef9ca3a2413 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 20 Jan 2021 23:30:53 +0100 Subject: [PATCH 080/133] Fix recent remember-diary-extract-entries change * lisp/textmodes/remember.el (remember-diary-extract-entries): Use `remember-diary-file' over `diary-file'. --- lisp/textmodes/remember.el | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el index 7f107977d53..811a265118c 100644 --- a/lisp/textmodes/remember.el +++ b/lisp/textmodes/remember.el @@ -549,6 +549,8 @@ If this is nil, then `diary-file' will be used instead." :type 'regexp :version "28.1") +(defvar diary-file) + ;;;###autoload (defun remember-diary-extract-entries () "Extract diary entries from the region based on `remember-diary-regexp'." @@ -561,7 +563,8 @@ If this is nil, then `diary-file' will be used instead." (diary-make-entry (mapconcat 'identity list "\n") nil remember-diary-file) (when remember-save-after-remembering - (with-current-buffer (find-buffer-visiting diary-file) + (with-current-buffer (find-buffer-visiting (or remember-diary-file + diary-file)) (save-buffer)))) nil))) ;; Continue processing From b9511362f5fe4dc772cb2b65afeb051a7443f2a4 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 20 Jan 2021 20:17:11 -0500 Subject: [PATCH 081/133] * lisp/emacs-lisp/bytecomp.el (byte-compile--declare-var): Fix warning Make sure the "declared after first use" is under the control of the `lexical` option. --- lisp/emacs-lisp/bytecomp.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 360da6b6ba6..9429d6a0d5d 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2505,7 +2505,8 @@ list that represents a doc string reference. (when (memq sym byte-compile-lexical-variables) (setq byte-compile-lexical-variables (delq sym byte-compile-lexical-variables)) - (byte-compile-warn "Variable `%S' declared after its first use" sym)) + (when (byte-compile-warning-enabled-p 'lexical sym) + (byte-compile-warn "Variable `%S' declared after its first use" sym))) (push sym byte-compile-bound-variables) (push sym byte-compile--seen-defvars)) From d8a9828b3b7c5d80ecc57089e0c93c4dfa6837b7 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 20 Jan 2021 23:00:57 -0500 Subject: [PATCH 082/133] * lisp/calendar/calendar.el (calendar-read-sexp): New function (calendar-read): Mark as obsolete. (calendar-read-date): Use it. Add `default-date` argument. Provide defaults for the month and day (fixes bug#32105). --- lisp/calendar/calendar.el | 57 ++++++++++++++++++++++++++++----------- 1 file changed, 41 insertions(+), 16 deletions(-) diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el index 21cea212e18..3f9fe1c9d8f 100644 --- a/lisp/calendar/calendar.el +++ b/lisp/calendar/calendar.el @@ -112,6 +112,8 @@ ;;; Code: +(eval-when-compile (require 'subr-x)) + (load "cal-loaddefs" nil t) ;; Calendar has historically relied heavily on dynamic scoping. @@ -1459,7 +1461,7 @@ Optional integers MON and YR are used instead of today's date." Inserts STRING so that it ends at INDENT. STRING is either a literal string, or a sexp to evaluate to return such. Truncates STRING to length TRUNCATE, and ensures a trailing space." - (if (not (ignore-errors (stringp (setq string (eval string))))) + (if (not (ignore-errors (stringp (setq string (eval string t))))) (calendar-move-to-column indent) (if (> (string-width string) truncate) (setq string (truncate-string-to-width string truncate))) @@ -1526,7 +1528,7 @@ first INDENT characters on the line." (format (format "%%%dd" calendar-day-digit-width) day) 'mouse-face 'highlight 'help-echo (calendar-dlet* ((day day) (month month) (year year)) - (eval calendar-date-echo-text)) + (eval calendar-date-echo-text t)) ;; 'date property prevents intermonth text confusing re-searches. ;; (Tried intangible, it did not really work.) 'date t) @@ -2054,23 +2056,40 @@ With argument ARG, jump to mark, pop it, and put point at end of ring." (error "%s not available in the calendar" (global-key-binding (this-command-keys)))) +(defun calendar-read-sexp (prompt predicate &optional default &rest args) + "Return an object read from the minibuffer. +Passes PROMPT, DEFAULT, and ARGS to `format-prompt' to build +the actual prompt. PREDICATE is called with a single value (the object +the user entered) and it should return non-nil if that value is a valid choice. +DEFAULT is the default value to use." + (unless (stringp default) (setq default (format "%S" default))) + (named-let query () + ;; The call to `read-from-minibuffer' is copied from `read-minibuffer', + ;; except it's changed to use the DEFAULT arg instead of INITIAL-CONTENTS. + (let ((value (read-from-minibuffer + (apply #'format-prompt prompt default args) + nil minibuffer-local-map t 'minibuffer-history default))) + (if (funcall predicate value) + value + (query))))) + (defun calendar-read (prompt acceptable &optional initial-contents) "Return an object read from the minibuffer. Prompt with the string PROMPT and use the function ACCEPTABLE to decide if entered item is acceptable. If non-nil, optional third arg INITIAL-CONTENTS is a string to insert in the minibuffer before reading." + (declare (obsolete calendar-read-sexp "28.1")) (let ((value (read-minibuffer prompt initial-contents))) (while (not (funcall acceptable value)) (setq value (read-minibuffer prompt initial-contents))) value)) - (defun calendar-customized-p (symbol) "Return non-nil if SYMBOL has been customized." (and (default-boundp symbol) (let ((standard (get symbol 'standard-value))) (and standard - (not (equal (eval (car standard)) (default-value symbol))))))) + (not (equal (eval (car standard) t) (default-value symbol))))))) (defun calendar-abbrev-construct (full &optional maxlen) "From sequence FULL, return a vector of abbreviations. @@ -2284,32 +2303,38 @@ arguments SEQUENCES." (append (list sequence) sequences)) (reverse alist))) -(defun calendar-read-date (&optional noday) +(defun calendar-read-date (&optional noday default-date) "Prompt for Gregorian date. Return a list (month day year). If optional NODAY is t, does not ask for day, but just returns \(month 1 year); if NODAY is any other non-nil value the value returned is (month year)." - (let* ((year (calendar-read - "Year (>0): " - (lambda (x) (> x 0)) - (number-to-string (calendar-extract-year - (calendar-current-date))))) + (unless default-date (setq default-date (calendar-current-date))) + (let* ((defyear (calendar-extract-year default-date)) + (year (calendar-read-sexp "Year (>0)" + (lambda (x) (> x 0)) + defyear)) (month-array calendar-month-name-array) + (defmon (aref month-array (1- (calendar-extract-month default-date)))) (completion-ignore-case t) (month (cdr (assoc-string - (completing-read - "Month name: " - (mapcar #'list (append month-array nil)) - nil t) + (completing-read + (format-prompt "Month name" defmon) + (append month-array nil) + nil t nil nil defmon) (calendar-make-alist month-array 1) t))) + (defday (calendar-extract-day default-date)) (last (calendar-last-day-of-month month year))) (if noday (if (eq noday t) (list month 1 year) (list month year)) (list month - (calendar-read (format "Day (1-%d): " last) - (lambda (x) (and (< 0 x) (<= x last)))) + (calendar-read-sexp "Day (1-%d)" + (lambda (x) (and (< 0 x) (<= x last))) + ;; Don't offer today's day as default + ;; if it's not valid for the chosen + ;; month/year. + (if (<= defday last) defday) last) year)))) (defun calendar-interval (mon1 yr1 mon2 yr2) From 0f65baa03b54dc95b24b765bc91370354743a449 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 20 Jan 2021 23:08:25 -0500 Subject: [PATCH 083/133] * lisp/calendar/cal-french.el (calendar-french-accents-p): Obsolete function Always assume accented letters can be used (calendar-french-month-name-array) (calendar-french-special-days-array): Use the accented names. (calendar-french-multibyte-month-name-array) (calendar-french-multibyte-special-days-array): Make those vars obsolete aliases. (calendar-french-month-name-array, calendar-french-day-name-array) (calendar-french-special-days-array): Mark functions as obsolete. (calendar-french-date-string, calendar-french-goto-date): Always use the text with accents. --- lisp/calendar/cal-french.el | 59 ++++++++++++++----------------------- 1 file changed, 22 insertions(+), 37 deletions(-) diff --git a/lisp/calendar/cal-french.el b/lisp/calendar/cal-french.el index e759b5dad95..c8ab6c41d8b 100644 --- a/lisp/calendar/cal-french.el +++ b/lisp/calendar/cal-french.el @@ -35,54 +35,45 @@ (defconst calendar-french-epoch (calendar-absolute-from-gregorian '(9 22 1792)) "Absolute date of start of French Revolutionary calendar = Sept 22, 1792.") -(defconst calendar-french-month-name-array - ["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se" - "Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"] - "Array of month names in the French calendar.") +(define-obsolete-variable-alias 'calendar-french-multibyte-month-name-array + 'calendar-french-month-name-array "28.1") -(defconst calendar-french-multibyte-month-name-array +(defconst calendar-french-month-name-array ["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse" "Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"] - "Array of multibyte month names in the French calendar.") + "Array of month names in the French calendar.") (defconst calendar-french-day-name-array ["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi" "Octidi" "Nonidi" "Decadi"] "Array of day names in the French calendar.") -(defconst calendar-french-special-days-array - ["de la Vertu" "du Ge'nie" "du Travail" "de la Raison" "des Re'compenses" - "de la Re'volution"] - "Array of special day names in the French calendar.") +(define-obsolete-variable-alias 'calendar-french-multibyte-special-days-array + 'calendar-french-special-days-array "28.1") -(defconst calendar-french-multibyte-special-days-array +(defconst calendar-french-special-days-array ["de la Vertu" "du Génie" "du Travail" "de la Raison" "des Récompenses" "de la Révolution"] - "Array of multibyte special day names in the French calendar.") + "Array of special day names in the French calendar.") (defun calendar-french-accents-p () - "Return non-nil if diacritical marks are available." - (and (or window-system - (terminal-coding-system)) - (or enable-multibyte-characters - (and (char-table-p standard-display-table) - (equal (aref standard-display-table 161) [161]))))) + (declare (obsolete nil "28.1")) + t) (defun calendar-french-month-name-array () "Return the array of month names, depending on whether accents are available." - (if (calendar-french-accents-p) - calendar-french-multibyte-month-name-array - calendar-french-month-name-array)) + (declare (obsolete "use the variable of the same name instead" "28.1")) + calendar-french-month-name-array) (defun calendar-french-day-name-array () "Return the array of day names." + (declare (obsolete "use the variable of the same name instead" "28.1")) calendar-french-day-name-array) (defun calendar-french-special-days-array () "Return the special day names, depending on whether accents are available." - (if (calendar-french-accents-p) - calendar-french-multibyte-special-days-array - calendar-french-special-days-array)) + (declare (obsolete "use the variable of the same name instead" "28.1")) + calendar-french-special-days-array) (defun calendar-french-leap-year-p (year) "True if YEAR is a leap year on the French Revolutionary calendar. @@ -171,17 +162,13 @@ Defaults to today's date if DATE is not given." (d (calendar-extract-day french-date))) (cond ((< y 1) "") - ((= m 13) (format (if (calendar-french-accents-p) - "Jour %s de l'Année %d de la Révolution" - "Jour %s de l'Anne'e %d de la Re'volution") - (aref (calendar-french-special-days-array) (1- d)) + ((= m 13) (format "Jour %s de l'Année %d de la Révolution" + (aref calendar-french-special-days-array (1- d)) y)) (t (format - (if (calendar-french-accents-p) - "%d %s an %d de la Révolution" - "%d %s an %d de la Re'volution") + "%d %s an %d de la Révolution" d - (aref (calendar-french-month-name-array) (1- m)) + (aref calendar-french-month-name-array (1- m)) y))))) ;;;###cal-autoload @@ -198,13 +185,11 @@ Defaults to today's date if DATE is not given." "Move cursor to French Revolutionary date DATE. Echo French Revolutionary date unless NOECHO is non-nil." (interactive - (let* ((months (calendar-french-month-name-array)) - (special-days (calendar-french-special-days-array)) + (let* ((months calendar-french-month-name-array) + (special-days calendar-french-special-days-array) (year (progn (calendar-read - (if (calendar-french-accents-p) - "Année de la Révolution (>0): " - "Anne'e de la Re'volution (>0): ") + "Année de la Révolution (>0): " (lambda (x) (> x 0)) (number-to-string (calendar-extract-year From 0c93d0d072d6030c57bb8ab9e7b90686ed79af15 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 20 Jan 2021 23:14:25 -0500 Subject: [PATCH 084/133] Use `calendar-read-sexp` instead of the now obsolete `calendar-read` * lisp/calendar/diary-lib.el (diary-insert-cyclic-entry): * lisp/calendar/cal-persia.el (calendar-persian-read-date): * lisp/calendar/cal-move.el (calendar-goto-day-of-year): * lisp/calendar/cal-mayan.el (calendar-mayan-read-haab-date) (calendar-mayan-read-tzolkin-date): * lisp/calendar/cal-julian.el (calendar-julian-goto-date) (calendar-astro-goto-day-number): * lisp/calendar/cal-iso.el (calendar-iso-read-date): * lisp/calendar/cal-islam.el (calendar-islamic-read-date): * lisp/calendar/cal-hebrew.el (calendar-hebrew-read-date) (calendar-hebrew-list-yahrzeits): * lisp/calendar/cal-french.el (calendar-french-goto-date): * lisp/calendar/cal-coptic.el (calendar-coptic-read-date): * lisp/calendar/cal-china.el (calendar-chinese-goto-date): * lisp/calendar/cal-bahai.el (calendar-bahai-read-date): * lisp/calendar/holidays.el (list-holidays): Use `calendar-read-sexp`. --- lisp/calendar/cal-bahai.el | 15 +++++------ lisp/calendar/cal-china.el | 20 ++++++++------- lisp/calendar/cal-coptic.el | 23 +++++++++-------- lisp/calendar/cal-french.el | 17 ++++++------- lisp/calendar/cal-hebrew.el | 51 ++++++++++++++++++++----------------- lisp/calendar/cal-islam.el | 19 +++++++------- lisp/calendar/cal-iso.el | 19 +++++++------- lisp/calendar/cal-julian.el | 26 +++++++++---------- lisp/calendar/cal-mayan.el | 8 +++--- lisp/calendar/cal-move.el | 15 ++++++----- lisp/calendar/cal-persia.el | 21 +++++++-------- lisp/calendar/diary-lib.el | 4 +-- lisp/calendar/holidays.el | 15 +++++------ 13 files changed, 131 insertions(+), 122 deletions(-) diff --git a/lisp/calendar/cal-bahai.el b/lisp/calendar/cal-bahai.el index 22e4cdbcd52..16176e37b4a 100644 --- a/lisp/calendar/cal-bahai.el +++ b/lisp/calendar/cal-bahai.el @@ -153,13 +153,12 @@ Defaults to today's date if DATE is not given." "Interactively read the arguments for a Bahá’í date command. Reads a year, month and day." (let* ((today (calendar-current-date)) - (year (calendar-read - "Bahá’í calendar year (not 0): " + (year (calendar-read-sexp + "Bahá’í calendar year (not 0)" (lambda (x) (not (zerop x))) - (number-to-string - (calendar-extract-year - (calendar-bahai-from-absolute - (calendar-absolute-from-gregorian today)))))) + (calendar-extract-year + (calendar-bahai-from-absolute + (calendar-absolute-from-gregorian today))))) (completion-ignore-case t) (month (cdr (assoc (completing-read @@ -169,8 +168,8 @@ Reads a year, month and day." nil t) (calendar-make-alist calendar-bahai-month-name-array 1)))) - (day (calendar-read "Bahá’í calendar day (1-19): " - (lambda (x) (and (< 0 x) (<= x 19)))))) + (day (calendar-read-sexp "Bahá’í calendar day (1-19)" + (lambda (x) (and (< 0 x) (<= x 19)))))) (list (list month day year)))) ;;;###cal-autoload diff --git a/lisp/calendar/cal-china.el b/lisp/calendar/cal-china.el index 7e5d0c46e11..dd69d849df1 100644 --- a/lisp/calendar/cal-china.el +++ b/lisp/calendar/cal-china.el @@ -602,14 +602,14 @@ Echo Chinese date unless NOECHO is non-nil." (interactive (let* ((c (calendar-chinese-from-absolute (calendar-absolute-from-gregorian (calendar-current-date)))) - (cycle (calendar-read - "Chinese calendar cycle number (>44): " + (cycle (calendar-read-sexp + "Chinese calendar cycle number (>44)" (lambda (x) (> x 44)) - (number-to-string (car c)))) - (year (calendar-read - "Year in Chinese cycle (1..60): " + (car c))) + (year (calendar-read-sexp + "Year in Chinese cycle (1..60)" (lambda (x) (and (<= 1 x) (<= x 60))) - (number-to-string (cadr c)))) + (cadr c))) (month-list (calendar-chinese-months-to-alist (calendar-chinese-months cycle year))) (month (cdr (assoc @@ -624,9 +624,11 @@ Echo Chinese date unless NOECHO is non-nil." (list cycle year month 1)))))) 30 29)) - (day (calendar-read - (format "Chinese calendar day (1-%d): " last) - (lambda (x) (and (<= 1 x) (<= x last)))))) + (day (calendar-read-sexp + "Chinese calendar day (1-%d)" + (lambda (x) (and (<= 1 x) (<= x last))) + nil + last))) (list (list cycle year month day)))) (calendar-goto-date (calendar-gregorian-from-absolute (calendar-chinese-to-absolute date))) diff --git a/lisp/calendar/cal-coptic.el b/lisp/calendar/cal-coptic.el index 3461f3259b9..2a0e7d81e0c 100644 --- a/lisp/calendar/cal-coptic.el +++ b/lisp/calendar/cal-coptic.el @@ -136,13 +136,13 @@ Defaults to today's date if DATE is not given." "Interactively read the arguments for a Coptic date command. Reads a year, month, and day." (let* ((today (calendar-current-date)) - (year (calendar-read - (format "%s calendar year (>0): " calendar-coptic-name) + (year (calendar-read-sexp + "%s calendar year (>0)" (lambda (x) (> x 0)) - (number-to-string - (calendar-extract-year - (calendar-coptic-from-absolute - (calendar-absolute-from-gregorian today)))))) + (calendar-extract-year + (calendar-coptic-from-absolute + (calendar-absolute-from-gregorian today))) + calendar-coptic-name)) (completion-ignore-case t) (month (cdr (assoc-string (completing-read @@ -151,11 +151,14 @@ Reads a year, month, and day." (append calendar-coptic-month-name-array nil)) nil t) (calendar-make-alist calendar-coptic-month-name-array - 1) t))) + 1) + t))) (last (calendar-coptic-last-day-of-month month year)) - (day (calendar-read - (format "%s calendar day (1-%d): " calendar-coptic-name last) - (lambda (x) (and (< 0 x) (<= x last)))))) + (day (calendar-read-sexp + "%s calendar day (1-%d)" + (lambda (x) (and (< 0 x) (<= x last))) + nil + calendar-coptic-name last))) (list (list month day year)))) ;;;###cal-autoload diff --git a/lisp/calendar/cal-french.el b/lisp/calendar/cal-french.el index c8ab6c41d8b..07c41c00bfe 100644 --- a/lisp/calendar/cal-french.el +++ b/lisp/calendar/cal-french.el @@ -188,14 +188,13 @@ Echo French Revolutionary date unless NOECHO is non-nil." (let* ((months calendar-french-month-name-array) (special-days calendar-french-special-days-array) (year (progn - (calendar-read - "Année de la Révolution (>0): " + (calendar-read-sexp + "Année de la Révolution (>0)" (lambda (x) (> x 0)) - (number-to-string - (calendar-extract-year - (calendar-french-from-absolute - (calendar-absolute-from-gregorian - (calendar-current-date)))))))) + (calendar-extract-year + (calendar-french-from-absolute + (calendar-absolute-from-gregorian + (calendar-current-date))))))) (month-list (mapcar 'list (append months @@ -219,8 +218,8 @@ Echo French Revolutionary date unless NOECHO is non-nil." (calendar-make-alist month-list 1 'car) t))) (day (if (> month 12) (- month 12) - (calendar-read - "Jour (1-30): " + (calendar-read-sexp + "Jour (1-30)" (lambda (x) (and (<= 1 x) (<= x 30)))))) (month (if (> month 12) 13 month))) (list (list month day year)))) diff --git a/lisp/calendar/cal-hebrew.el b/lisp/calendar/cal-hebrew.el index bcc80f0877b..a835f9b430e 100644 --- a/lisp/calendar/cal-hebrew.el +++ b/lisp/calendar/cal-hebrew.el @@ -225,13 +225,12 @@ Driven by the variable `calendar-date-display-form'." "Interactively read the arguments for a Hebrew date command. Reads a year, month, and day." (let* ((today (calendar-current-date)) - (year (calendar-read - "Hebrew calendar year (>3760): " + (year (calendar-read-sexp + "Hebrew calendar year (>3760)" (lambda (x) (> x 3760)) - (number-to-string - (calendar-extract-year - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian today)))))) + (calendar-extract-year + (calendar-hebrew-from-absolute + (calendar-absolute-from-gregorian today))))) (month-array (if (calendar-hebrew-leap-year-p year) calendar-hebrew-month-name-array-leap-year calendar-hebrew-month-name-array-common-year)) @@ -258,10 +257,11 @@ Reads a year, month, and day." (last (calendar-hebrew-last-day-of-month month year)) (first (if (and (= year 3761) (= month 10)) 18 1)) - (day (calendar-read - (format "Hebrew calendar day (%d-%d): " - first last) - (lambda (x) (and (<= first x) (<= x last)))))) + (day (calendar-read-sexp + "Hebrew calendar day (%d-%d)" + (lambda (x) (and (<= first x) (<= x last))) + nil + first last))) (list (list month day year)))) ;;;###cal-autoload @@ -681,10 +681,10 @@ from the cursor position." (if (equal (current-buffer) (get-buffer calendar-buffer)) (calendar-cursor-to-date t) (let* ((today (calendar-current-date)) - (year (calendar-read - "Year of death (>0): " + (year (calendar-read-sexp + "Year of death (>0)" (lambda (x) (> x 0)) - (number-to-string (calendar-extract-year today)))) + (calendar-extract-year today))) (month-array calendar-month-name-array) (completion-ignore-case t) (month (cdr (assoc-string @@ -694,20 +694,23 @@ from the cursor position." nil t) (calendar-make-alist month-array 1) t))) (last (calendar-last-day-of-month month year)) - (day (calendar-read - (format "Day of death (1-%d): " last) - (lambda (x) (and (< 0 x) (<= x last)))))) + (day (calendar-read-sexp + "Day of death (1-%d)" + (lambda (x) (and (< 0 x) (<= x last))) + nil + last))) (list month day year)))) (death-year (calendar-extract-year death-date)) - (start-year (calendar-read - (format "Starting year of Yahrzeit table (>%d): " - death-year) + (start-year (calendar-read-sexp + "Starting year of Yahrzeit table (>%d)" (lambda (x) (> x death-year)) - (number-to-string (1+ death-year)))) - (end-year (calendar-read - (format "Ending year of Yahrzeit table (>=%d): " - start-year) - (lambda (x) (>= x start-year))))) + (1+ death-year) + death-year)) + (end-year (calendar-read-sexp + "Ending year of Yahrzeit table (>=%d)" + (lambda (x) (>= x start-year)) + nil + start-year))) (list death-date start-year end-year))) (message "Computing Yahrzeits...") (let* ((h-date (calendar-hebrew-from-absolute diff --git a/lisp/calendar/cal-islam.el b/lisp/calendar/cal-islam.el index d256310ba6c..4082ed43e5d 100644 --- a/lisp/calendar/cal-islam.el +++ b/lisp/calendar/cal-islam.el @@ -143,13 +143,12 @@ Driven by the variable `calendar-date-display-form'." "Interactively read the arguments for an Islamic date command. Reads a year, month, and day." (let* ((today (calendar-current-date)) - (year (calendar-read - "Islamic calendar year (>0): " + (year (calendar-read-sexp + "Islamic calendar year (>0)" (lambda (x) (> x 0)) - (number-to-string - (calendar-extract-year - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian today)))))) + (calendar-extract-year + (calendar-islamic-from-absolute + (calendar-absolute-from-gregorian today))))) (month-array calendar-islamic-month-name-array) (completion-ignore-case t) (month (cdr (assoc-string @@ -159,9 +158,11 @@ Reads a year, month, and day." nil t) (calendar-make-alist month-array 1) t))) (last (calendar-islamic-last-day-of-month month year)) - (day (calendar-read - (format "Islamic calendar day (1-%d): " last) - (lambda (x) (and (< 0 x) (<= x last)))))) + (day (calendar-read-sexp + "Islamic calendar day (1-%d)" + (lambda (x) (and (< 0 x) (<= x last))) + nil + last))) (list (list month day year)))) ;;;###cal-autoload diff --git a/lisp/calendar/cal-iso.el b/lisp/calendar/cal-iso.el index 956433e4a20..a247b2d15a9 100644 --- a/lisp/calendar/cal-iso.el +++ b/lisp/calendar/cal-iso.el @@ -92,22 +92,23 @@ date Sunday, December 31, 1 BC." "Interactively read the arguments for an ISO date command. Reads a year and week, and if DAYFLAG is non-nil a day (otherwise taken to be 1)." - (let* ((year (calendar-read - "ISO calendar year (>0): " + (let* ((year (calendar-read-sexp + "ISO calendar year (>0)" (lambda (x) (> x 0)) - (number-to-string (calendar-extract-year - (calendar-current-date))))) + (calendar-extract-year (calendar-current-date)))) (no-weeks (calendar-extract-month (calendar-iso-from-absolute (1- (calendar-dayname-on-or-before 1 (calendar-absolute-from-gregorian (list 1 4 (1+ year)))))))) - (week (calendar-read - (format "ISO calendar week (1-%d): " no-weeks) - (lambda (x) (and (> x 0) (<= x no-weeks))))) - (day (if dayflag (calendar-read - "ISO day (1-7): " + (week (calendar-read-sexp + "ISO calendar week (1-%d)" + (lambda (x) (and (> x 0) (<= x no-weeks))) + nil + no-weeks)) + (day (if dayflag (calendar-read-sexp + "ISO day (1-7)" (lambda (x) (and (<= 1 x) (<= x 7)))) 1))) (list (list week day year)))) diff --git a/lisp/calendar/cal-julian.el b/lisp/calendar/cal-julian.el index 235b4d00900..47880a4e974 100644 --- a/lisp/calendar/cal-julian.el +++ b/lisp/calendar/cal-julian.el @@ -95,14 +95,13 @@ Driven by the variable `calendar-date-display-form'." "Move cursor to Julian DATE; echo Julian date unless NOECHO is non-nil." (interactive (let* ((today (calendar-current-date)) - (year (calendar-read - "Julian calendar year (>0): " + (year (calendar-read-sexp + "Julian calendar year (>0)" (lambda (x) (> x 0)) - (number-to-string - (calendar-extract-year - (calendar-julian-from-absolute - (calendar-absolute-from-gregorian - today)))))) + (calendar-extract-year + (calendar-julian-from-absolute + (calendar-absolute-from-gregorian + today))))) (month-array calendar-month-name-array) (completion-ignore-case t) (month (cdr (assoc-string @@ -115,12 +114,13 @@ Driven by the variable `calendar-date-display-form'." (if (and (zerop (% year 4)) (= month 2)) 29 (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month)))) - (day (calendar-read - (format "Julian calendar day (%d-%d): " - (if (and (= year 1) (= month 1)) 3 1) last) + (day (calendar-read-sexp + "Julian calendar day (%d-%d)" (lambda (x) (and (< (if (and (= year 1) (= month 1)) 2 0) x) - (<= x last)))))) + (<= x last))) + nil + (if (and (= year 1) (= month 1)) 3 1) last))) (list (list month day year)))) (calendar-goto-date (calendar-gregorian-from-absolute (calendar-julian-to-absolute date))) @@ -173,8 +173,8 @@ Defaults to today's date if DATE is not given." (defun calendar-astro-goto-day-number (daynumber &optional noecho) "Move cursor to astronomical (Julian) DAYNUMBER. Echo astronomical (Julian) day number unless NOECHO is non-nil." - (interactive (list (calendar-read - "Astronomical (Julian) day number (>1721425): " + (interactive (list (calendar-read-sexp + "Astronomical (Julian) day number (>1721425)" (lambda (x) (> x 1721425))))) (calendar-goto-date (calendar-gregorian-from-absolute diff --git a/lisp/calendar/cal-mayan.el b/lisp/calendar/cal-mayan.el index 8d894ebd986..e3533e7b1d6 100644 --- a/lisp/calendar/cal-mayan.el +++ b/lisp/calendar/cal-mayan.el @@ -135,8 +135,8 @@ but some use 1137140. Using 1232041 gives you Spinden's correlation; using (defun calendar-mayan-read-haab-date () "Prompt for a Mayan haab date." (let* ((completion-ignore-case t) - (haab-day (calendar-read - "Haab kin (0-19): " + (haab-day (calendar-read-sexp + "Haab kin (0-19)" (lambda (x) (and (>= x 0) (< x 20))))) (haab-month-list (append calendar-mayan-haab-month-name-array (and (< haab-day 5) '("Uayeb")))) @@ -151,8 +151,8 @@ but some use 1137140. Using 1232041 gives you Spinden's correlation; using (defun calendar-mayan-read-tzolkin-date () "Prompt for a Mayan tzolkin date." (let* ((completion-ignore-case t) - (tzolkin-count (calendar-read - "Tzolkin kin (1-13): " + (tzolkin-count (calendar-read-sexp + "Tzolkin kin (1-13)" (lambda (x) (and (> x 0) (< x 14))))) (tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil)) (tzolkin-name (cdr diff --git a/lisp/calendar/cal-move.el b/lisp/calendar/cal-move.el index 710ce37ccbf..c2b5d618ea0 100644 --- a/lisp/calendar/cal-move.el +++ b/lisp/calendar/cal-move.el @@ -386,15 +386,16 @@ Moves forward if ARG is negative." "Move cursor to YEAR, DAY number; echo DAY/YEAR unless NOECHO is non-nil. Negative DAY counts backward from end of year." (interactive - (let* ((year (calendar-read - "Year (>0): " + (let* ((year (calendar-read-sexp + "Year (>0)" (lambda (x) (> x 0)) - (number-to-string (calendar-extract-year - (calendar-current-date))))) + (calendar-extract-year (calendar-current-date)))) (last (if (calendar-leap-year-p year) 366 365)) - (day (calendar-read - (format "Day number (+/- 1-%d): " last) - (lambda (x) (and (<= 1 (abs x)) (<= (abs x) last)))))) + (day (calendar-read-sexp + "Day number (+/- 1-%d)" + (lambda (x) (and (<= 1 (abs x)) (<= (abs x) last))) + nil + last))) (list year day))) (calendar-goto-date (calendar-gregorian-from-absolute diff --git a/lisp/calendar/cal-persia.el b/lisp/calendar/cal-persia.el index a9c99fedbdb..21085284ac8 100644 --- a/lisp/calendar/cal-persia.el +++ b/lisp/calendar/cal-persia.el @@ -157,14 +157,13 @@ Gregorian date Sunday, December 31, 1 BC." (defun calendar-persian-read-date () "Interactively read the arguments for a Persian date command. Reads a year, month, and day." - (let* ((year (calendar-read - "Persian calendar year (not 0): " + (let* ((year (calendar-read-sexp + "Persian calendar year (not 0)" (lambda (x) (not (zerop x))) - (number-to-string - (calendar-extract-year - (calendar-persian-from-absolute - (calendar-absolute-from-gregorian - (calendar-current-date))))))) + (calendar-extract-year + (calendar-persian-from-absolute + (calendar-absolute-from-gregorian + (calendar-current-date)))))) (completion-ignore-case t) (month (cdr (assoc (completing-read @@ -175,9 +174,11 @@ Reads a year, month, and day." (calendar-make-alist calendar-persian-month-name-array 1)))) (last (calendar-persian-last-day-of-month month year)) - (day (calendar-read - (format "Persian calendar day (1-%d): " last) - (lambda (x) (and (< 0 x) (<= x last)))))) + (day (calendar-read-sexp + "Persian calendar day (1-%d)" + (lambda (x) (and (< 0 x) (<= x last))) + nil + last))) (list (list month day year)))) ;;;###cal-autoload diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el index aad70161f9f..4efa3669967 100644 --- a/lisp/calendar/diary-lib.el +++ b/lisp/calendar/diary-lib.el @@ -2221,8 +2221,8 @@ Prefix argument ARG makes the entry nonmarking." (diary-make-entry (format "%s(diary-cyclic %d %s)" diary-sexp-entry-symbol - (calendar-read "Repeat every how many days: " - (lambda (x) (> x 0))) + (calendar-read-sexp "Repeat every how many days" + (lambda (x) (> x 0))) (calendar-date-string (calendar-cursor-to-date t) nil t)) arg))) diff --git a/lisp/calendar/holidays.el b/lisp/calendar/holidays.el index 932993beba0..4bc17de3067 100644 --- a/lisp/calendar/holidays.el +++ b/lisp/calendar/holidays.el @@ -423,16 +423,15 @@ of a holiday list. The optional LABEL is used to label the buffer created." (interactive - (let* ((start-year (calendar-read - "Starting year of holidays (>0): " + (let* ((start-year (calendar-read-sexp + "Starting year of holidays (>0)" (lambda (x) (> x 0)) - (number-to-string (calendar-extract-year - (calendar-current-date))))) - (end-year (calendar-read - (format "Ending year (inclusive) of holidays (>=%s): " - start-year) + (calendar-extract-year (calendar-current-date)))) + (end-year (calendar-read-sexp + "Ending year (inclusive) of holidays (>=%s)" (lambda (x) (>= x start-year)) - (number-to-string start-year))) + start-year + start-year)) (completion-ignore-case t) (lists (list From bacc24b5d0d708dd9ac34e314c2d3af25b311397 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 20 Jan 2021 23:45:18 -0500 Subject: [PATCH 085/133] Use `lexical-binding` in all the cal-*.el files * lisp/calendar/cal-bahai.el: Use lexical-binding. (calendar-bahai-date-string): Use `calendar-dlet*`. * lisp/calendar/cal-china.el: Use lexical-binding. (calendar-chinese-zodiac-sign-on-or-after) (calendar-chinese-new-moon-on-or-after): Declare `year`. (calendar-chinese-from-absolute-for-diary) (calendar-chinese-to-absolute-for-diary) (calendar-chinese-mark-date-pattern): Avoid dynbound var `date` as function argument. * lisp/calendar/cal-coptic.el: Use lexical-binding. (calendar-coptic-date-string): Use `calendar-dlet*`. (calendar-ethiopic-to-absolute, calendar-ethiopic-from-absolute) (calendar-ethiopic-date-string, calendar-ethiopic-goto-date): Avoid dynbound var `date` as function argument. * lisp/calendar/cal-french.el: Use lexical-binding. * lisp/calendar/cal-hebrew.el: Use lexical-binding. (holiday-hebrew-hanukkah): Don't use the third form in `dotimes`. * lisp/calendar/cal-islam.el: Use lexical-binding. (calendar-islamic-to-absolute): Comment out unused vars `month` and `day`. * lisp/calendar/cal-move.el: * lisp/calendar/cal-mayan.el: * lisp/calendar/cal-iso.el: Use lexical-binding. * lisp/calendar/cal-persia.el: Use lexical-binding. (calendar-persian-date-string): Use `calendar-dlet*`. * lisp/calendar/cal-html.el: Use lexical-binding. (cal-html-insert-minical): Comment out unused var `date`. (cal-html-cursor-month, cal-html-cursor-year): Mark `event` arg as unused. * lisp/calendar/cal-menu.el: Use lexical-binding. (diary-list-include-blanks): Declare var. * lisp/calendar/cal-x.el: Use lexical-binding. * lisp/calendar/cal-tex.el: Use lexical-binding. (diary-list-include-blanks): Declare var. (cal-tex-insert-days, cal-tex-cursor-week-iso, cal-tex-week-hours) (cal-tex-weekly-common, cal-tex-cursor-filofax-2week) (cal-tex-cursor-filofax-daily, cal-tex-daily-page): Declare `date` as dynbound for the benefit of `cal-tex-daily-string`. --- lisp/calendar/cal-bahai.el | 13 +++--- lisp/calendar/cal-china.el | 25 ++++++----- lisp/calendar/cal-coptic.el | 33 +++++++------- lisp/calendar/cal-french.el | 2 +- lisp/calendar/cal-hebrew.el | 17 ++++---- lisp/calendar/cal-html.el | 19 ++++----- lisp/calendar/cal-islam.el | 6 +-- lisp/calendar/cal-iso.el | 2 +- lisp/calendar/cal-mayan.el | 2 +- lisp/calendar/cal-menu.el | 4 +- lisp/calendar/cal-move.el | 2 +- lisp/calendar/cal-persia.el | 9 ++-- lisp/calendar/cal-tex.el | 85 +++++++++++++++++++++++-------------- lisp/calendar/cal-x.el | 2 +- 14 files changed, 125 insertions(+), 96 deletions(-) diff --git a/lisp/calendar/cal-bahai.el b/lisp/calendar/cal-bahai.el index 16176e37b4a..c2e4205c0bc 100644 --- a/lisp/calendar/cal-bahai.el +++ b/lisp/calendar/cal-bahai.el @@ -1,4 +1,4 @@ -;;; cal-bahai.el --- calendar functions for the Bahá’í calendar. +;;; cal-bahai.el --- calendar functions for the Bahá’í calendar. -*- lexical-binding: t; -*- ;; Copyright (C) 2001-2021 Free Software Foundation, Inc. @@ -124,9 +124,10 @@ Defaults to today's date if DATE is not given." (y (calendar-extract-year bahai-date))) (if (< y 1) "" ; pre-Bahai - (let* ((m (calendar-extract-month bahai-date)) - (d (calendar-extract-day bahai-date)) - (monthname (if (and (= m 19) + (let ((m (calendar-extract-month bahai-date)) + (d (calendar-extract-day bahai-date))) + (calendar-dlet* + ((monthname (if (and (= m 19) (<= d 0)) "Ayyám-i-Há" (aref calendar-bahai-month-name-array (1- m)))) @@ -137,8 +138,8 @@ Defaults to today's date if DATE is not given." (year (number-to-string y)) (month (number-to-string m)) dayname) - ;; Can't call calendar-date-string because of monthname oddity. - (mapconcat 'eval calendar-date-display-form ""))))) + ;; Can't call calendar-date-string because of monthname oddity. + (mapconcat #'eval calendar-date-display-form "")))))) ;;;###cal-autoload (defun calendar-bahai-print-date () diff --git a/lisp/calendar/cal-china.el b/lisp/calendar/cal-china.el index dd69d849df1..9a28984a7ab 100644 --- a/lisp/calendar/cal-china.el +++ b/lisp/calendar/cal-china.el @@ -1,4 +1,4 @@ -;;; cal-china.el --- calendar functions for the Chinese calendar +;;; cal-china.el --- calendar functions for the Chinese calendar -*- lexical-binding: t; -*- ;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc. @@ -185,7 +185,9 @@ N congruent to 1 gives the first name, N congruent to 2 gives the second name, (defun calendar-chinese-zodiac-sign-on-or-after (d) "Absolute date of first new Zodiac sign on or after absolute date D. The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees." - (let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d))) + (with-suppressed-warnings ((lexical year)) + (defvar year)) + (let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d))) (calendar-time-zone (eval calendar-chinese-time-zone)) ; uses year (calendar-daylight-time-offset calendar-chinese-daylight-time-offset) @@ -207,6 +209,8 @@ The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees." (defun calendar-chinese-new-moon-on-or-after (d) "Absolute date of first new moon on or after absolute date D." + (with-suppressed-warnings ((lexical year)) + (defvar year)) (let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d))) (calendar-time-zone (eval calendar-chinese-time-zone)) (calendar-daylight-time-offset @@ -665,17 +669,17 @@ Echo Chinese date unless NOECHO is non-nil." ["正月" "二月" "三月" "四月" "五月" "六月" "七月" "八月" "九月" "十月" "冬月" "臘月"]) -;;; NOTE: In the diary the cycle and year of a Chinese date is -;;; combined using this formula: (+ (* cycle 100) year). +;; NOTE: In the diary the cycle and year of a Chinese date is +;; combined using this formula: (+ (* cycle 100) year). ;;; -;;; These two functions convert to and back from this representation. -(defun calendar-chinese-from-absolute-for-diary (date) - (pcase-let ((`(,c ,y ,m ,d) (calendar-chinese-from-absolute date))) +;; These two functions convert to and back from this representation. +(defun calendar-chinese-from-absolute-for-diary (thedate) + (pcase-let ((`(,c ,y ,m ,d) (calendar-chinese-from-absolute thedate))) ;; Note: For leap months M is a float. (list (floor m) d (+ (* c 100) y)))) -(defun calendar-chinese-to-absolute-for-diary (date &optional prefer-leap) - (pcase-let* ((`(,m ,d ,y) date) +(defun calendar-chinese-to-absolute-for-diary (thedate &optional prefer-leap) + (pcase-let* ((`(,m ,d ,y) thedate) (cycle (floor y 100)) (year (mod y 100)) (months (calendar-chinese-months cycle year)) @@ -693,7 +697,8 @@ Echo Chinese date unless NOECHO is non-nil." (unless (zerop month) (calendar-mark-1 month day year #'calendar-chinese-from-absolute-for-diary - (lambda (date) (calendar-chinese-to-absolute-for-diary date t)) + (lambda (thedate) + (calendar-chinese-to-absolute-for-diary thedate t)) color))) ;;;###cal-autoload diff --git a/lisp/calendar/cal-coptic.el b/lisp/calendar/cal-coptic.el index 2a0e7d81e0c..346585e1817 100644 --- a/lisp/calendar/cal-coptic.el +++ b/lisp/calendar/cal-coptic.el @@ -1,4 +1,4 @@ -;;; cal-coptic.el --- calendar functions for the Coptic/Ethiopic calendars +;;; cal-coptic.el --- calendar functions for the Coptic/Ethiopic calendars -*- lexical-binding: t; -*- ;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc. @@ -116,12 +116,13 @@ Defaults to today's date if DATE is not given." (m (calendar-extract-month coptic-date))) (if (< y 1) "" - (let ((monthname (aref calendar-coptic-month-name-array (1- m))) - (day (number-to-string (calendar-extract-day coptic-date))) - (dayname nil) - (month (number-to-string m)) - (year (number-to-string y))) - (mapconcat 'eval calendar-date-display-form ""))))) + (calendar-dlet* + ((monthname (aref calendar-coptic-month-name-array (1- m))) + (day (number-to-string (calendar-extract-day coptic-date))) + (dayname nil) + (month (number-to-string m)) + (year (number-to-string y))) + (mapconcat #'eval calendar-date-display-form ""))))) ;;;###cal-autoload (defun calendar-coptic-print-date () @@ -197,30 +198,30 @@ Echo Coptic date unless NOECHO is t." (defconst calendar-ethiopic-name "Ethiopic" "Used in some message strings.") -(defun calendar-ethiopic-to-absolute (date) +(defun calendar-ethiopic-to-absolute (thedate) "Compute absolute date from Ethiopic date DATE. The absolute date is the number of days elapsed since the (imaginary) Gregorian date Sunday, December 31, 1 BC." (let ((calendar-coptic-epoch calendar-ethiopic-epoch)) - (calendar-coptic-to-absolute date))) + (calendar-coptic-to-absolute thedate))) -(defun calendar-ethiopic-from-absolute (date) +(defun calendar-ethiopic-from-absolute (thedate) "Compute the Ethiopic equivalent for absolute date DATE. The result is a list of the form (MONTH DAY YEAR). The absolute date is the number of days elapsed since the imaginary Gregorian date Sunday, December 31, 1 BC." (let ((calendar-coptic-epoch calendar-ethiopic-epoch)) - (calendar-coptic-from-absolute date))) + (calendar-coptic-from-absolute thedate))) ;;;###cal-autoload -(defun calendar-ethiopic-date-string (&optional date) +(defun calendar-ethiopic-date-string (&optional thedate) "String of Ethiopic date of Gregorian DATE. Returns the empty string if DATE is pre-Ethiopic calendar. Defaults to today's date if DATE is not given." (let ((calendar-coptic-epoch calendar-ethiopic-epoch) (calendar-coptic-name calendar-ethiopic-name) (calendar-coptic-month-name-array calendar-ethiopic-month-name-array)) - (calendar-coptic-date-string date))) + (calendar-coptic-date-string thedate))) ;;;###cal-autoload (defun calendar-ethiopic-print-date () @@ -232,8 +233,8 @@ Defaults to today's date if DATE is not given." (call-interactively 'calendar-coptic-print-date))) ;;;###cal-autoload -(defun calendar-ethiopic-goto-date (date &optional noecho) - "Move cursor to Ethiopic date DATE. +(defun calendar-ethiopic-goto-date (thedate &optional noecho) + "Move cursor to Ethiopic date THEDATE. Echo Ethiopic date unless NOECHO is t." (interactive (let ((calendar-coptic-epoch calendar-ethiopic-epoch) @@ -241,7 +242,7 @@ Echo Ethiopic date unless NOECHO is t." (calendar-coptic-month-name-array calendar-ethiopic-month-name-array)) (calendar-coptic-read-date))) (calendar-goto-date (calendar-gregorian-from-absolute - (calendar-ethiopic-to-absolute date))) + (calendar-ethiopic-to-absolute thedate))) (or noecho (calendar-ethiopic-print-date))) ;; To be called from diary-list-sexp-entries, where DATE is bound. diff --git a/lisp/calendar/cal-french.el b/lisp/calendar/cal-french.el index 07c41c00bfe..639bae700cc 100644 --- a/lisp/calendar/cal-french.el +++ b/lisp/calendar/cal-french.el @@ -1,4 +1,4 @@ -;;; cal-french.el --- calendar functions for the French Revolutionary calendar +;;; cal-french.el --- calendar functions for the French Revolutionary calendar -*- lexical-binding: t; -*- ;; Copyright (C) 1988-1989, 1992, 1994-1995, 1997, 2001-2021 Free ;; Software Foundation, Inc. diff --git a/lisp/calendar/cal-hebrew.el b/lisp/calendar/cal-hebrew.el index a835f9b430e..50b4fc363bb 100644 --- a/lisp/calendar/cal-hebrew.el +++ b/lisp/calendar/cal-hebrew.el @@ -1,4 +1,4 @@ -;;; cal-hebrew.el --- calendar functions for the Hebrew calendar +;;; cal-hebrew.el --- calendar functions for the Hebrew calendar -*- lexical-binding: t; -*- ;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc. @@ -399,19 +399,20 @@ is non-nil." (list m (calendar-last-day-of-month m y) y)))))) (abs-h (calendar-hebrew-to-absolute (list 9 25 h-y))) (ord ["first" "second" "third" "fourth" "fifth" "sixth" - "seventh" "eighth"]) - han) + "seventh" "eighth"])) (holiday-filter-visible-calendar (if (or all calendar-hebrew-all-holidays-flag) (append (list (list (calendar-gregorian-from-absolute (1- abs-h)) "Erev Hanukkah")) - (dotimes (i 8 (nreverse han)) - (push (list - (calendar-gregorian-from-absolute (+ abs-h i)) - (format "Hanukkah (%s day)" (aref ord i))) - han))) + (let (han) + (dotimes (i 8) + (push (list + (calendar-gregorian-from-absolute (+ abs-h i)) + (format "Hanukkah (%s day)" (aref ord i))) + han)) + (nreverse han))) (list (list (calendar-gregorian-from-absolute abs-h) "Hanukkah"))))))) ;;;###holiday-autoload diff --git a/lisp/calendar/cal-html.el b/lisp/calendar/cal-html.el index 3d7cc938437..e5810c3f027 100644 --- a/lisp/calendar/cal-html.el +++ b/lisp/calendar/cal-html.el @@ -1,4 +1,4 @@ -;;; cal-html.el --- functions for printing HTML calendars +;;; cal-html.el --- functions for printing HTML calendars -*- lexical-binding: t; -*- ;; Copyright (C) 2002-2021 Free Software Foundation, Inc. @@ -250,7 +250,7 @@ Contains links to previous and next month and year, and current minical." calendar-week-start-day)) 7)) (monthpage-name (cal-html-monthpage-name month year)) - date) + ) ;; date ;; Start writing table. (insert (cal-html-comment "MINICAL") (cal-html-b-table "class=minical border=1 align=center")) @@ -276,7 +276,7 @@ Contains links to previous and next month and year, and current minical." (insert cal-html-e-tablerow-string cal-html-b-tablerow-string))) ;; End empty slots (for some browsers like konqueror). - (dotimes (i end-blank-days) + (dotimes (_ end-blank-days) (insert cal-html-b-tabledata-string cal-html-e-tabledata-string))) @@ -431,12 +431,11 @@ holidays in HOLIDAY-LIST." ;;; User commands. ;;;###cal-autoload -(defun cal-html-cursor-month (month year dir &optional event) +(defun cal-html-cursor-month (month year dir &optional _event) "Write an HTML calendar file for numeric MONTH of four-digit YEAR. The output directory DIR is created if necessary. Interactively, -MONTH and YEAR are taken from the calendar cursor position, or from -the position specified by EVENT. Note that any existing output files -are overwritten." +MONTH and YEAR are taken from the calendar cursor position. +Note that any existing output files are overwritten." (interactive (let* ((event last-nonmenu-event) (date (calendar-cursor-to-date t event)) (month (calendar-extract-month date)) @@ -446,11 +445,11 @@ are overwritten." (cal-html-one-month month year dir)) ;;;###cal-autoload -(defun cal-html-cursor-year (year dir &optional event) +(defun cal-html-cursor-year (year dir &optional _event) "Write HTML calendar files (index and monthly pages) for four-digit YEAR. The output directory DIR is created if necessary. Interactively, -YEAR is taken from the calendar cursor position, or from the position -specified by EVENT. Note that any existing output files are overwritten." +YEAR is taken from the calendar cursor position. +Note that any existing output files are overwritten." (interactive (let* ((event last-nonmenu-event) (year (calendar-extract-year (calendar-cursor-to-date t event)))) diff --git a/lisp/calendar/cal-islam.el b/lisp/calendar/cal-islam.el index 4082ed43e5d..45c6ffa7bd7 100644 --- a/lisp/calendar/cal-islam.el +++ b/lisp/calendar/cal-islam.el @@ -1,4 +1,4 @@ -;;; cal-islam.el --- calendar functions for the Islamic calendar +;;; cal-islam.el --- calendar functions for the Islamic calendar -*- lexical-binding: t; -*- ;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc. @@ -67,8 +67,8 @@ "Absolute date of Islamic DATE. The absolute date is the number of days elapsed since the (imaginary) Gregorian date Sunday, December 31, 1 BC." - (let* ((month (calendar-extract-month date)) - (day (calendar-extract-day date)) + (let* (;;(month (calendar-extract-month date)) + ;;(day (calendar-extract-day date)) (year (calendar-extract-year date)) (y (% year 30)) (leap-years-in-cycle (cond ((< y 3) 0) diff --git a/lisp/calendar/cal-iso.el b/lisp/calendar/cal-iso.el index a247b2d15a9..90f57c25e9d 100644 --- a/lisp/calendar/cal-iso.el +++ b/lisp/calendar/cal-iso.el @@ -1,4 +1,4 @@ -;;; cal-iso.el --- calendar functions for the ISO calendar +;;; cal-iso.el --- calendar functions for the ISO calendar -*- lexical-binding: t; -*- ;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc. diff --git a/lisp/calendar/cal-mayan.el b/lisp/calendar/cal-mayan.el index e3533e7b1d6..9a221921130 100644 --- a/lisp/calendar/cal-mayan.el +++ b/lisp/calendar/cal-mayan.el @@ -1,4 +1,4 @@ -;;; cal-mayan.el --- calendar functions for the Mayan calendars +;;; cal-mayan.el --- calendar functions for the Mayan calendars -*- lexical-binding: t; -*- ;; Copyright (C) 1992-1993, 1995, 1997, 2001-2021 Free Software ;; Foundation, Inc. diff --git a/lisp/calendar/cal-menu.el b/lisp/calendar/cal-menu.el index a30c681a897..497f3329055 100644 --- a/lisp/calendar/cal-menu.el +++ b/lisp/calendar/cal-menu.el @@ -1,4 +1,4 @@ -;;; cal-menu.el --- calendar functions for menu bar and popup menu support +;;; cal-menu.el --- calendar functions for menu bar and popup menu support -*- lexical-binding: t; -*- ;; Copyright (C) 1994-1995, 2001-2021 Free Software Foundation, Inc. @@ -183,6 +183,8 @@ Signals an error if popups are unavailable." ;; Autoloaded in diary-lib. (declare-function calendar-check-holidays "holidays" (date)) +(defvar diary-list-include-blanks) + (defun calendar-mouse-view-diary-entries (&optional date diary event) "Pop up menu of diary entries for mouse-selected date. Use optional DATE and alternative file DIARY. EVENT is the event diff --git a/lisp/calendar/cal-move.el b/lisp/calendar/cal-move.el index c2b5d618ea0..9294362cb43 100644 --- a/lisp/calendar/cal-move.el +++ b/lisp/calendar/cal-move.el @@ -1,4 +1,4 @@ -;;; cal-move.el --- calendar functions for movement in the calendar +;;; cal-move.el --- calendar functions for movement in the calendar -*- lexical-binding: t; -*- ;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc. diff --git a/lisp/calendar/cal-persia.el b/lisp/calendar/cal-persia.el index 21085284ac8..ca37d803224 100644 --- a/lisp/calendar/cal-persia.el +++ b/lisp/calendar/cal-persia.el @@ -1,4 +1,4 @@ -;;; cal-persia.el --- calendar functions for the Persian calendar +;;; cal-persia.el --- calendar functions for the Persian calendar -*- lexical-binding: t; -*- ;; Copyright (C) 1996-1997, 2001-2021 Free Software Foundation, Inc. @@ -139,13 +139,14 @@ Gregorian date Sunday, December 31, 1 BC." (calendar-absolute-from-gregorian (or date (calendar-current-date))))) (y (calendar-extract-year persian-date)) - (m (calendar-extract-month persian-date)) - (monthname (aref calendar-persian-month-name-array (1- m))) + (m (calendar-extract-month persian-date))) + (calendar-dlet* + ((monthname (aref calendar-persian-month-name-array (1- m))) (day (number-to-string (calendar-extract-day persian-date))) (year (number-to-string y)) (month (number-to-string m)) dayname) - (mapconcat 'eval calendar-date-display-form ""))) + (mapconcat #'eval calendar-date-display-form "")))) ;;;###cal-autoload (defun calendar-persian-print-date () diff --git a/lisp/calendar/cal-tex.el b/lisp/calendar/cal-tex.el index 9df9f4cbedf..f5932014dd9 100644 --- a/lisp/calendar/cal-tex.el +++ b/lisp/calendar/cal-tex.el @@ -1,4 +1,4 @@ -;;; cal-tex.el --- calendar functions for printing calendars with LaTeX +;;; cal-tex.el --- calendar functions for printing calendars with LaTeX -*- lexical-binding: t; -*- ;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc. @@ -248,6 +248,8 @@ This definition is the heart of the calendar!") (autoload 'diary-list-entries "diary-lib") +(defvar diary-list-include-blanks) + (defun cal-tex-list-diary-entries (d1 d2) "Generate a list of all diary-entries from absolute date D1 to D2." (let (diary-list-include-blanks) @@ -591,6 +593,8 @@ indicates a buffer position to use instead of point." LaTeX commands are inserted for the days of the MONTH in YEAR. Diary entries on DIARY-LIST are included. Holidays on HOLIDAYS are included. Each day is formatted using format DAY-FORMAT." + (with-suppressed-warnings ((lexical date)) + (defvar date)) ;For `cal-tex-daily-string'. (let ((blank-days ; at start of month (mod (- (calendar-day-of-week (list month 1 year)) @@ -605,7 +609,7 @@ are included. Each day is formatted using format DAY-FORMAT." (insert (format day-format (cal-tex-month-name month) j)) (cal-tex-arg (cal-tex-latexify-list diary-list date)) (cal-tex-arg (cal-tex-latexify-list holidays date)) - (cal-tex-arg (eval cal-tex-daily-string)) + (cal-tex-arg (eval cal-tex-daily-string t)) (cal-tex-arg) (cal-tex-comment)) (when (and (zerop (mod (+ j blank-days) 7)) @@ -885,13 +889,15 @@ argument EVENT specifies a different buffer position." (interactive (list (prefix-numeric-value current-prefix-arg) last-nonmenu-event)) (or n (setq n 1)) + (with-suppressed-warnings ((lexical date)) + (defvar date)) ;For `cal-tex-daily-string'. (let* ((date (calendar-gregorian-from-absolute (calendar-dayname-on-or-before 1 (calendar-absolute-from-gregorian (calendar-cursor-to-date t event))))) (month (calendar-extract-month date)) - (year (calendar-extract-year date)) + ;; (year (calendar-extract-year date)) (day (calendar-extract-day date)) (d1 (calendar-absolute-from-gregorian date)) (d2 (+ (* 7 n) d1)) @@ -932,7 +938,7 @@ argument EVENT specifies a different buffer position." (insert ": ") (cal-tex-large-bf s)) (cal-tex-hfill) - (insert " " (eval cal-tex-daily-string)) + (insert " " (eval cal-tex-daily-string t)) (cal-tex-e-parbox) (cal-tex-nl) (cal-tex-noindent) @@ -951,7 +957,8 @@ argument EVENT specifies a different buffer position." (cal-tex-e-parbox "2cm") (cal-tex-nl) (setq month (calendar-extract-month date) - year (calendar-extract-year date))) + ;; year (calendar-extract-year date) + )) (cal-tex-e-parbox) (unless (= i (1- n)) (run-hooks 'cal-tex-week-hook) @@ -961,13 +968,16 @@ argument EVENT specifies a different buffer position." ;; TODO respect cal-tex-daily-start,end? ;; Using different numbers of hours will probably break some layouts. -(defun cal-tex-week-hours (date holidays height) - "Insert hourly entries for DATE with HOLIDAYS, with line height HEIGHT. +(defun cal-tex-week-hours (thedate holidays height) + "Insert hourly entries for THEDATE with HOLIDAYS, with line height HEIGHT. Uses the 24-hour clock if `cal-tex-24' is non-nil. Note that the hours shown are hard-coded to 8-12, 13-17." - (let ((month (calendar-extract-month date)) + (with-suppressed-warnings ((lexical date)) + (defvar date)) ;For `cal-tex-daily-string'. + (let ((date thedate) + (month (calendar-extract-month date)) (day (calendar-extract-day date)) - (year (calendar-extract-year date)) + ;; (year (calendar-extract-year date)) morning afternoon s) (cal-tex-comment "begin cal-tex-week-hours") (cal-tex-cmd "\\ \\\\[-.2cm]") @@ -983,7 +993,7 @@ shown are hard-coded to 8-12, 13-17." (insert ": ") (cal-tex-large-bf s)) (cal-tex-hfill) - (insert " " (eval cal-tex-daily-string)) + (insert " " (eval cal-tex-daily-string t)) (cal-tex-e-parbox) (cal-tex-nl "-.3cm") (cal-tex-rule "0pt" "6.8in" ".2mm") @@ -1088,14 +1098,16 @@ shown are hard-coded to 8-12, 13-17." (defun cal-tex-weekly-common (n event &optional filofax) "Common code for weekly calendars." (or n (setq n 1)) + (with-suppressed-warnings ((lexical date)) + (defvar date)) ;For `cal-tex-daily-string'. (let* ((date (calendar-gregorian-from-absolute (calendar-dayname-on-or-before 1 (calendar-absolute-from-gregorian (calendar-cursor-to-date t event))))) - (month (calendar-extract-month date)) - (year (calendar-extract-year date)) - (day (calendar-extract-day date)) + ;; (month (calendar-extract-month date)) + ;; (year (calendar-extract-year date)) + ;; (day (calendar-extract-day date)) (d1 (calendar-absolute-from-gregorian date)) (d2 (+ (* 7 n) d1)) (holidays (if cal-tex-holidays @@ -1161,7 +1173,7 @@ shown are hard-coded to 8-12, 13-17." (cal-tex-arg (number-to-string (calendar-extract-day date))) (cal-tex-arg (cal-tex-latexify-list diary-list date)) (cal-tex-arg (cal-tex-latexify-list holidays date)) - (cal-tex-arg (eval cal-tex-daily-string)) + (cal-tex-arg (eval cal-tex-daily-string t)) (insert "%\n") (setq date (cal-tex-incr-date date))) (insert "\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n") @@ -1258,14 +1270,16 @@ Optional EVENT indicates a buffer position to use instead of point." (interactive (list (prefix-numeric-value current-prefix-arg) last-nonmenu-event)) (or n (setq n 1)) + (with-suppressed-warnings ((lexical date)) + (defvar date)) ;For `cal-tex-daily-string'. (let* ((date (calendar-gregorian-from-absolute (calendar-dayname-on-or-before calendar-week-start-day (calendar-absolute-from-gregorian (calendar-cursor-to-date t event))))) - (month (calendar-extract-month date)) - (year (calendar-extract-year date)) - (day (calendar-extract-day date)) + ;; (month (calendar-extract-month date)) + ;; (year (calendar-extract-year date)) + ;; (day (calendar-extract-day date)) (d1 (calendar-absolute-from-gregorian date)) (d2 (+ (* 7 n) d1)) (holidays (if cal-tex-holidays @@ -1311,7 +1325,7 @@ Optional EVENT indicates a buffer position to use instead of point." (cal-tex-arg (number-to-string (calendar-extract-day date))) (cal-tex-arg (cal-tex-latexify-list diary-list date)) (cal-tex-arg (cal-tex-latexify-list holidays date)) - (cal-tex-arg (eval cal-tex-daily-string)) + (cal-tex-arg (eval cal-tex-daily-string t)) (insert "%\n") (setq date (cal-tex-incr-date date))) (unless (= i (1- n)) @@ -1342,14 +1356,16 @@ Optional EVENT indicates a buffer position to use instead of point." (interactive (list (prefix-numeric-value current-prefix-arg) last-nonmenu-event)) (or n (setq n 1)) + (with-suppressed-warnings ((lexical date)) + (defvar date)) ;For `cal-tex-daily-string'. (let* ((date (calendar-gregorian-from-absolute (calendar-dayname-on-or-before 1 (calendar-absolute-from-gregorian (calendar-cursor-to-date t event))))) - (month (calendar-extract-month date)) - (year (calendar-extract-year date)) - (day (calendar-extract-day date)) + ;; (month (calendar-extract-month date)) + ;; (year (calendar-extract-year date)) + ;; (day (calendar-extract-day date)) (d1 (calendar-absolute-from-gregorian date)) (d2 (+ (* 7 n) d1)) (holidays (if cal-tex-holidays @@ -1383,11 +1399,11 @@ Optional EVENT indicates a buffer position to use instead of point." "\\leftday"))) (cal-tex-arg (cal-tex-latexify-list diary-list date)) (cal-tex-arg (cal-tex-latexify-list holidays date "\\\\" t)) - (cal-tex-arg (eval cal-tex-daily-string)) + (cal-tex-arg (eval cal-tex-daily-string t)) (insert "%\n") - (if cal-tex-rules - (insert "\\linesfill\n") - (insert "\\vfill\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n")) + (insert (if cal-tex-rules + "\\linesfill\n" + "\\vfill\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n")) (cal-tex-newpage) (setq date (cal-tex-incr-date date))) (insert "%\n") @@ -1397,11 +1413,11 @@ Optional EVENT indicates a buffer position to use instead of point." (insert "\\weekend") (cal-tex-arg (cal-tex-latexify-list diary-list date)) (cal-tex-arg (cal-tex-latexify-list holidays date "\\\\" t)) - (cal-tex-arg (eval cal-tex-daily-string)) + (cal-tex-arg (eval cal-tex-daily-string t)) (insert "%\n") - (if cal-tex-rules - (insert "\\linesfill\n") - (insert "\\vfill")) + (insert (if cal-tex-rules + "\\linesfill\n" + "\\vfill")) (setq date (cal-tex-incr-date date))) (or cal-tex-rules (insert "\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n")) @@ -1442,12 +1458,15 @@ a buffer position to use instead of point." (cal-tex-end-document) (run-hooks 'cal-tex-hook))) -(defun cal-tex-daily-page (date) - "Make a calendar page for Gregorian DATE on 8.5 by 11 paper. +(defun cal-tex-daily-page (thedate) + "Make a calendar page for Gregorian THEDATE on 8.5 by 11 paper. Uses the 24-hour clock if `cal-tex-24' is non-nil. Produces hourly sections for the period specified by `cal-tex-daily-start' and `cal-tex-daily-end'." - (let ((month-name (cal-tex-month-name (calendar-extract-month date))) + (with-suppressed-warnings ((lexical date)) + (defvar date)) ;For `cal-tex-daily-string'. + (let ((date thedate) + (month-name (cal-tex-month-name (calendar-extract-month date))) (i (1- cal-tex-daily-start)) hour) (cal-tex-banner "cal-tex-daily-page") @@ -1459,7 +1478,7 @@ and `cal-tex-daily-end'." (cal-tex-bf month-name ) (cal-tex-e-parbox) (cal-tex-hspace "1cm") - (cal-tex-scriptsize (eval cal-tex-daily-string)) + (cal-tex-scriptsize (eval cal-tex-daily-string t)) (cal-tex-hspace "3.5cm") (cal-tex-e-makebox) (cal-tex-hfill) diff --git a/lisp/calendar/cal-x.el b/lisp/calendar/cal-x.el index 1c19a60db10..ca303ce39ae 100644 --- a/lisp/calendar/cal-x.el +++ b/lisp/calendar/cal-x.el @@ -1,4 +1,4 @@ -;;; cal-x.el --- calendar windows in dedicated frames +;;; cal-x.el --- calendar windows in dedicated frames -*- lexical-binding: t; -*- ;; Copyright (C) 1994-1995, 2001-2021 Free Software Foundation, Inc. From 8e7728a5bfaf99efd3fb9ea7dd42dabd11a00b5c Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 21 Jan 2021 12:45:24 +0100 Subject: [PATCH 086/133] Fix thinko in previous footnote.el change * lisp/mail/footnote.el (footnote--regenerate-alist): Don't error out when there's no footnotes. --- lisp/mail/footnote.el | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/lisp/mail/footnote.el b/lisp/mail/footnote.el index 9c1a738035e..995ae5f9160 100644 --- a/lisp/mail/footnote.el +++ b/lisp/mail/footnote.el @@ -916,8 +916,7 @@ play around with the following keys: (defun footnote--regenerate-alist () (save-excursion (goto-char (point-min)) - (if (not (re-search-forward footnote-section-tag-regexp nil t)) - (error "No footnote section in this buffer") + (when (re-search-forward footnote-section-tag-regexp nil t) (setq footnote--markers-alist (cl-loop with start-of-footnotes = (match-beginning 0) From b2d30fd6303a2461c591f0ace7eb2a43638bba21 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Thu, 21 Jan 2021 16:21:45 +0200 Subject: [PATCH 087/133] A better fix for 'kill-visual-line' * lisp/simple.el (kill-visual-line): Use the 6th element of the return value of 'posn-at-point', which provides the coordinates in terms or row and column, and is thus more reliable for deciding whether we moved to the next screen line. (Bug#45837) --- lisp/simple.el | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/lisp/simple.el b/lisp/simple.el index 37c0885dcc5..2c6e3916cd4 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -7338,10 +7338,7 @@ even beep.)" ;; of the kill before killing. (let ((opoint (point)) (kill-whole-line (and kill-whole-line (bolp))) - (orig-y (cdr (nth 2 (posn-at-point)))) - ;; FIXME: This tolerance should be zero! It isn't due to a - ;; bug in posn-at-point, see bug#45837. - (tol (/ (line-pixel-height) 2))) + (orig-vlnum (cdr (nth 6 (posn-at-point))))) (if arg (vertical-motion (prefix-numeric-value arg)) (end-of-visual-line 1) @@ -7352,8 +7349,8 @@ even beep.)" ;; end-of-visual-line didn't overshoot due to complications ;; like display or overlay strings, intangible text, etc.: ;; otherwise, we don't want to kill a character that's - ;; unrelated to the place where the visual line wrapped. - (and (< (abs (- (cdr (nth 2 (posn-at-point))) orig-y)) tol) + ;; unrelated to the place where the visual line wraps. + (and (= (cdr (nth 6 (posn-at-point))) orig-vlnum) ;; Make sure we delete the character where the line wraps ;; under visual-line-mode, be it whitespace or a ;; character whose category set allows to wrap at it. From a7fb4ab826669443e204458ecbe5e4074ca1329a Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 21 Jan 2021 16:44:53 +0100 Subject: [PATCH 088/133] Make Message respect header removal instructions more * doc/misc/message.texi (Forwarding): Document it. * lisp/gnus/message.el (message-forward-ignored-headers): Improve documentation. (message-forward-included-headers): Ditto. (message-forward-included-mime-headers): New user option. (message-remove-ignored-headers): Use it to preserve the necessary MIME headers. (message-forward-make-body): Remove headers when forwarding as MIME, too. --- doc/misc/message.texi | 6 +++++ etc/NEWS | 8 +++--- lisp/gnus/message.el | 63 +++++++++++++++++++++++++++++++++++-------- 3 files changed, 63 insertions(+), 14 deletions(-) diff --git a/doc/misc/message.texi b/doc/misc/message.texi index f2680b4a797..be6c9a419b2 100644 --- a/doc/misc/message.texi +++ b/doc/misc/message.texi @@ -317,6 +317,12 @@ when forwarding a message. In non-@code{nil}, only headers that match this regexp will be kept when forwarding a message. This can also be a list of regexps. +@item message-forward-included-mime-headers +@vindex message-forward-included-mime-headers +In non-@code{nil}, headers that match this regexp will be kept when +forwarding a message as @acronym{MIME}, but @acronym{MML} isn't used. +This can also be a list of regexps. + @item message-make-forward-subject-function @vindex message-make-forward-subject-function A list of functions that are called to generate a subject header for diff --git a/etc/NEWS b/etc/NEWS index 59b13998cfa..357c75b7e96 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -721,9 +721,11 @@ not. --- *** Respect 'message-forward-ignored-headers' more. Previously, this variable would not be consulted if -'message-forward-show-mml' was nil. It's now always used, except if -'message-forward-show-mml' is 'best', and we're forwarding an -encrypted/signed message. +'message-forward-show-mml' was nil and forwarding as MIME. + ++++ +*** New user option 'message-forward-included-mime-headers'. +This is used when forwarding messages as MIME, but not using MML. +++ *** Message now supports the OpenPGP header. diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index b22b4543e71..2bcd367638f 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -620,8 +620,8 @@ Done before generating the new subject of a forward." (defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus" "All headers that match this regexp will be deleted when forwarding a message. -This variable is not consulted when forwarding encrypted messages -and `message-forward-show-mml' is `best'. +Also see `message-forward-included-headers' -- both variables are applied. +In addition, see `message-forward-included-mime-headers'. This may also be a list of regexps." :version "21.1" @@ -637,7 +637,14 @@ This may also be a list of regexps." '("^From:" "^Subject:" "^Date:" "^To:" "^Cc:") "If non-nil, delete non-matching headers when forwarding a message. Only headers that match this regexp will be included. This -variable should be a regexp or a list of regexps." +variable should be a regexp or a list of regexps. + +Also see `message-forward-ignored-headers' -- both variables are applied. +In addition, see `message-forward-included-mime-headers'. + +When forwarding messages as MIME, but when +`message-forward-show-mml' results in MML not being used, +`message-forward-included-mime-headers' take precedence." :version "27.1" :group 'message-forwarding :type '(repeat :value-to-internal (lambda (widget value) @@ -647,6 +654,24 @@ variable should be a regexp or a list of regexps." (widget-editable-list-match widget value))) regexp)) +(defcustom message-forward-included-mime-headers + '("^Content-Type:" "^MIME-Version:" "^Content-Transfer-Encoding:") + "When forwarding as MIME, but not using MML, don't delete these headers. +Also see `message-forward-ignored-headers' and +`message-forward-ignored-headers'. + +When forwarding messages as MIME, but when +`message-forward-show-mml' results in MML not being used, +`message-forward-included-mime-headers' take precedence." + :version "28.1" + :group 'message-forwarding + :type '(repeat :value-to-internal (lambda (widget value) + (custom-split-regexp-maybe value)) + :match (lambda (widget value) + (or (stringp value) + (widget-editable-list-match widget value))) + regexp)) + (defcustom message-ignored-cited-headers "." "Delete these headers from the messages you yank." :group 'message-insertion @@ -7617,14 +7642,28 @@ Optional DIGEST will use digest to forward." "-------------------- End of forwarded message --------------------\n") (message-remove-ignored-headers b e))) -(defun message-remove-ignored-headers (b e) +(defun message-remove-ignored-headers (b e &optional preserve-mime) (when (or message-forward-ignored-headers message-forward-included-headers) + (let ((saved-headers nil)) (save-restriction (narrow-to-region b e) (goto-char b) (narrow-to-region (point) (or (search-forward "\n\n" nil t) (point))) + ;; When forwarding as MIME, preserve some MIME headers. + (when preserve-mime + (let ((headers (buffer-string))) + (with-temp-buffer + (insert headers) + (message-remove-header + (if (listp message-forward-included-mime-headers) + (mapconcat + #'identity (cons "^$" message-forward-included-mime-headers) + "\\|") + message-forward-included-mime-headers) + t nil t) + (setq saved-headers (string-lines (buffer-string) t))))) (when message-forward-ignored-headers (let ((ignored (if (stringp message-forward-ignored-headers) (list message-forward-ignored-headers) @@ -7637,10 +7676,14 @@ Optional DIGEST will use digest to forward." (mapconcat #'identity (cons "^$" message-forward-included-headers) "\\|") message-forward-included-headers) - t nil t))))) + t nil t)) + ;; Insert the MIME headers, if any. + (goto-char (point-max)) + (forward-line -1) + (dolist (header saved-headers) + (insert header "\n")))))) -(defun message-forward-make-body-mime (forward-buffer &optional beg end - remove-headers) +(defun message-forward-make-body-mime (forward-buffer &optional beg end) (let ((b (point))) (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n") (save-restriction @@ -7650,8 +7693,7 @@ Optional DIGEST will use digest to forward." (goto-char (point-min)) (when (looking-at "From ") (replace-match "X-From-Line: ")) - (when remove-headers - (message-remove-ignored-headers (point-min) (point-max))) + (message-remove-ignored-headers (point-min) (point-max) t) (goto-char (point-max))) (insert "<#/part>\n") ;; Consider there is no illegible text. @@ -7790,8 +7832,7 @@ is for the internal use." (message-signed-or-encrypted-p) (error t)))))) (message-forward-make-body-mml forward-buffer) - (message-forward-make-body-mime - forward-buffer nil nil (not (eq message-forward-show-mml 'best)))) + (message-forward-make-body-mime forward-buffer)) (message-forward-make-body-plain forward-buffer))) (message-position-point)) From 7d122cf9a3c5e02d1fab625a1c81791806f80c40 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 21 Jan 2021 16:48:01 +0100 Subject: [PATCH 089/133] Tweak previous message-forward-included-mime-headers change * lisp/gnus/message.el (message-forward-included-mime-headers): Should probably not include Content-Transfer-Encoding, because we will reencode anyway. --- lisp/gnus/message.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 2bcd367638f..7d1eb970c6b 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -655,7 +655,7 @@ When forwarding messages as MIME, but when regexp)) (defcustom message-forward-included-mime-headers - '("^Content-Type:" "^MIME-Version:" "^Content-Transfer-Encoding:") + '("^Content-Type:" "^MIME-Version:") "When forwarding as MIME, but not using MML, don't delete these headers. Also see `message-forward-ignored-headers' and `message-forward-ignored-headers'. From de761b58f091b11221469b796394e23b34685991 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 21 Jan 2021 17:08:28 +0100 Subject: [PATCH 090/133] Add dired support for compressing .pax files * lisp/dired-aux.el (dired-compress-files-alist): Add support for compressing .pax files (bug#40135). --- lisp/dired-aux.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 5a96742fda9..f860743a066 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1168,7 +1168,8 @@ ARGS are command switches passed to PROGRAM.") ("\\.tar\\.bz2\\'" . "tar -cf - %i | bzip2 -c9 > %o") ("\\.tar\\.xz\\'" . "tar -cf - %i | xz -c9 > %o") ("\\.tar\\.zst\\'" . "tar -cf - %i | zstd -19 -o %o") - ("\\.zip\\'" . "zip %o -r --filesync %i")) + ("\\.zip\\'" . "zip %o -r --filesync %i") + ("\\.pax\\'" . "pax -wf %o %i")) "Control the compression shell command for `dired-do-compress-to'. Each element is (REGEXP . CMD), where REGEXP is the name of the From 5d2ebcd8962b79898d5cdb80cffb6235a033d3d2 Mon Sep 17 00:00:00 2001 From: Ted Zlatanov Date: Thu, 21 Jan 2021 16:02:28 +0000 Subject: [PATCH 091/133] * test/infra/gitlab-ci.yml: Revert to always building. --- test/infra/gitlab-ci.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index ddabacfe010..e5413ad9380 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -104,8 +104,6 @@ default: .build-template: rules: - - if: '$CI_PIPELINE_SOURCE == "web"' - when: always - changes: - "**/Makefile.in" - .gitlab-ci.yml @@ -113,9 +111,11 @@ default: - autogen.sh - configure.ac - lib/*.{h,c} - - lisp/emacs-lisp/*.el + - lisp/**/*.el - src/*.{h,c} - test/infra/* + - test/lisp/**/*.el + - test/src/*.el - changes: # gfilemonitor, kqueue - src/gfilenotify.c From a6f030fc7bb3eae2a93dc4d944b6d7d313bd0bce Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 21 Jan 2021 17:10:02 +0100 Subject: [PATCH 092/133] Fix message.el build warning from previous change * lisp/gnus/message.el (subr-x): Fix build warning from previous commit. --- lisp/gnus/message.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 7d1eb970c6b..1409a4384ab 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -47,7 +47,7 @@ (require 'rfc2047) (require 'puny) (require 'rmc) ; read-multiple-choice -(eval-when-compile (require 'subr-x)) +(require 'subr-x) (autoload 'mailclient-send-it "mailclient") From 2cf347a0a87bf490391a26fc26b29ca40a0fda93 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 21 Jan 2021 18:10:16 +0100 Subject: [PATCH 093/133] Don't have type-break-mode signal errors on corrupted files * lisp/type-break.el (type-break-get-previous-time): (type-break-get-previous-count): Signal a warning instead of an error (bug#38246). type-break will still continue to work even if the database can't be loaded after a restart, but this allows Emacs to be started. --- lisp/type-break.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lisp/type-break.el b/lisp/type-break.el index 84c240c9f8c..a6d5cd01702 100644 --- a/lisp/type-break.el +++ b/lisp/type-break.el @@ -487,7 +487,7 @@ Return nil if the file is missing or if the time is not a Lisp time value." (goto-char (point-min)) (read (current-buffer))) (end-of-file - (error "End of file in `%s'" file)))))))) + (warn "End of file in `%s'" file)))))))) (defun type-break-get-previous-count () "Get previous keystroke count from `type-break-file-name'. @@ -505,7 +505,7 @@ integer." (forward-line 1) (read (current-buffer))) (end-of-file - (error "End of file in `%s'" file))))))) + (warn "End of file in `%s'" file))))))) file 0))) From 931be5ee7d618904361ab2d434d3901cbd9abc9a Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Thu, 21 Jan 2021 18:52:48 +0100 Subject: [PATCH 094/133] * lisp/net/webjump.el: Add Maintainer: emacs-devel. Ref: https://lists.gnu.org/r/emacs-devel/2021-01/msg01019.html --- lisp/net/webjump.el | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/lisp/net/webjump.el b/lisp/net/webjump.el index 9bcf1d37345..e5941ae652e 100644 --- a/lisp/net/webjump.el +++ b/lisp/net/webjump.el @@ -2,9 +2,10 @@ ;; Copyright (C) 1996-1997, 2001-2021 Free Software Foundation, Inc. -;; Author: Neil W. Van Dyke -;; Created: 09-Aug-1996 -;; Keywords: comm www +;; Author: Neil W. Van Dyke +;; Maintainer: emacs-devel@gnu.org +;; Created: 09-Aug-1996 +;; Keywords: comm www ;; This file is part of GNU Emacs. From b41b4add7bc2485fadc6ff3a890efbd1307b2351 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 21 Jan 2021 13:15:05 -0500 Subject: [PATCH 095/133] Fix spurious "Lexical argument shadows the dynamic variable" due to inlining Before this patch doing: rm lisp/calendar/calendar.elc make lisp/calendar/cal-hebrew.elc would spew out lots of spurious such warnings about a `date` argument, pointing to code which has no `date` argument in sight. This was because that code had calls to inlinable functions (taking a `date` argument) defined in `calendar.el`, and while `date` is a normal lexical var at the site of those functions' definitions, it was declared as dynbound at the call site. * lisp/emacs-lisp/byte-opt.el (byte-compile-inline-expand): Don't impose our local context onto the inlined function. * test/lisp/emacs-lisp/bytecomp-tests.el: Add matching test. --- lisp/emacs-lisp/byte-opt.el | 6 ++++-- .../bytecomp-resources/foo-inlinable.el | 6 ++++++ .../nowarn-inline-after-defvar.el | 17 +++++++++++++++++ test/lisp/emacs-lisp/bytecomp-tests.el | 4 ++++ 4 files changed, 31 insertions(+), 2 deletions(-) create mode 100644 test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el create mode 100644 test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index cfa407019a7..66a117fccc8 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -284,8 +284,10 @@ ;; If `fn' is from the same file, it has already ;; been preprocessed! `(function ,fn) - (byte-compile-preprocess - (byte-compile--reify-function fn))))) + ;; Try and process it "in its original environment". + (let ((byte-compile-bound-variables nil)) + (byte-compile-preprocess + (byte-compile--reify-function fn)))))) (if (eq (car-safe newfn) 'function) (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form))) ;; This can happen because of macroexp-warn-and-return &co. diff --git a/test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el b/test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el new file mode 100644 index 00000000000..47481574ea8 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el @@ -0,0 +1,6 @@ +;; -*- lexical-binding: t; -*- + +(defsubst foo-inlineable (foo-var) + (+ foo-var 2)) + +(provide 'foo-inlinable) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el b/test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el new file mode 100644 index 00000000000..5582b2ab0ea --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el @@ -0,0 +1,17 @@ +;; -*- lexical-binding: t; -*- + +;; In this test, we try and make sure that inlined functions's code isn't +;; mistakenly re-interpreted in the caller's context: we import an +;; inlinable function from another file where `foo-var' is a normal +;; lexical variable, and then call(inline) it in a function where +;; `foo-var' is a dynamically-scoped variable. + +(require 'foo-inlinable + (expand-file-name "foo-inlinable.el" + (file-name-directory + (or byte-compile-current-file load-file-name)))) + +(defvar foo-var) + +(defun foo-fun () + (+ (foo-inlineable 5) 1)) diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index 263736af4ed..980b402ca2d 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -713,6 +713,10 @@ Subtests signal errors if something goes wrong." "warn-wide-docstring-multiline.el" "defvar.*foo.*wider than.*characters") +(bytecomp--define-warning-file-test + "nowarn-inline-after-defvar.el" + "Lexical argument shadows" 'reverse) + ;;;; Macro expansion. From 90bd6d8ba66bde8d9626f3dd05d14372734e6ce5 Mon Sep 17 00:00:00 2001 From: Ted Zlatanov Date: Thu, 21 Jan 2021 19:34:03 +0000 Subject: [PATCH 096/133] * test/infra/gitlab-ci.yml: Copy newer files to image to build less often. --- test/infra/gitlab-ci.yml | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index e5413ad9380..2f71d12bdb3 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -100,10 +100,13 @@ default: script: - docker pull ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} # TODO: with make -j4 several of the tests were failing, for example shadowfile-tests, but passed without it - - docker run -i --rm -e EMACS_EMBA_CI=${EMACS_EMBA_CI} ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} make ${make_params} + - 'export PWD=$(pwd)' + - 'docker run -i --rm -e EMACS_EMBA_CI=${EMACS_EMBA_CI} --volumes-from $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):ro ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} /bin/bash -c "git fetch ${PWD} HEAD && echo checking out these updated files && git diff --name-only FETCH_HEAD && ( git diff --name-only FETCH_HEAD | xargs git checkout -f FETCH_HEAD ) && make -j4 && make ${make_params}"' .build-template: rules: + - if: '$CI_PIPELINE_SOURCE == "web"' + when: always - changes: - "**/Makefile.in" - .gitlab-ci.yml @@ -111,11 +114,9 @@ default: - autogen.sh - configure.ac - lib/*.{h,c} - - lisp/**/*.el + - lisp/emacs-lisp/*.el - src/*.{h,c} - test/infra/* - - test/lisp/**/*.el - - test/src/*.el - changes: # gfilemonitor, kqueue - src/gfilenotify.c From 6bfc672bc7f467edf39cfba262c5c4f11897d4e0 Mon Sep 17 00:00:00 2001 From: Glenn Morris Date: Fri, 22 Jan 2021 08:52:12 +0000 Subject: [PATCH 097/133] * lisp/textmodes/remember.el (remember-text-format-function): Fix type. --- lisp/textmodes/remember.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el index 811a265118c..820ee38d101 100644 --- a/lisp/textmodes/remember.el +++ b/lisp/textmodes/remember.el @@ -415,7 +415,7 @@ The default emulates `current-time-string' for backward compatibility." "The function to format the remembered text. The function receives the remembered text as argument and should return the text to be remembered." - :type 'function + :type '(choice (const nil) function) :group 'remember :version "28.1") From 463300d431a56c58ca7f1db9615046143f354a81 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jo=C3=A3o=20T=C3=A1vora?= Date: Sat, 16 Jan 2021 14:17:58 -0800 Subject: [PATCH 098/133] Enable TTY mouse-face support when built without GPM support * src/term.c (tty_write_glyphs_with_face): Move definition out of ifdef block. * src/xdisp.c (draw_row_with_mouse_face): Now called unconditionally on all platforms. --- src/term.c | 35 ++++++++++++++++------------------- src/xdisp.c | 3 +-- 2 files changed, 17 insertions(+), 21 deletions(-) diff --git a/src/term.c b/src/term.c index 2e2ab2bf438..37c06a560dd 100644 --- a/src/term.c +++ b/src/term.c @@ -790,8 +790,6 @@ tty_write_glyphs (struct frame *f, struct glyph *string, int len) cmcheckmagic (tty); } -#ifdef HAVE_GPM /* Only used by GPM code. */ - static void tty_write_glyphs_with_face (register struct frame *f, register struct glyph *string, register int len, register int face_id) @@ -847,7 +845,6 @@ tty_write_glyphs_with_face (register struct frame *f, register struct glyph *str cmcheckmagic (tty); } -#endif /* An implementation of insert_glyphs for termcap frames. */ @@ -2380,22 +2377,6 @@ frame's terminal). */) Mouse ***********************************************************************/ -#ifdef HAVE_GPM - -void -term_mouse_moveto (int x, int y) -{ - /* TODO: how to set mouse position? - const char *name; - int fd; - name = (const char *) ttyname (0); - fd = emacs_open (name, O_WRONLY, 0); - SOME_FUNCTION (x, y, fd); - emacs_close (fd); - last_mouse_x = x; - last_mouse_y = y; */ -} - /* Implementation of draw_row_with_mouse_face for TTY/GPM. */ void tty_draw_row_with_mouse_face (struct window *w, struct glyph_row *row, @@ -2428,6 +2409,22 @@ tty_draw_row_with_mouse_face (struct window *w, struct glyph_row *row, cursor_to (f, save_y, save_x); } +#ifdef HAVE_GPM + +void +term_mouse_moveto (int x, int y) +{ + /* TODO: how to set mouse position? + const char *name; + int fd; + name = (const char *) ttyname (0); + fd = emacs_open (name, O_WRONLY, 0); + SOME_FUNCTION (x, y, fd); + emacs_close (fd); + last_mouse_x = x; + last_mouse_y = y; */ +} + /* Return the current time, as a Time value. Wrap around on overflow. */ static Time current_Time (void) diff --git a/src/xdisp.c b/src/xdisp.c index 32e9773b54e..e1e4ff41365 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -31927,9 +31927,8 @@ draw_row_with_mouse_face (struct window *w, int start_x, struct glyph_row *row, return; } #endif -#if defined (HAVE_GPM) || defined (MSDOS) || defined (WINDOWSNT) + tty_draw_row_with_mouse_face (w, row, start_hpos, end_hpos, draw); -#endif } /* Display the active region described by mouse_face_* according to DRAW. */ From 561197e519c5adc33622c2e5519693d270f6262b Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Fri, 22 Jan 2021 14:16:51 +0200 Subject: [PATCH 099/133] Fix last change for DOS_NT systems * src/term.c (tty_draw_row_with_mouse_face) (tty_write_glyphs_with_face): Don't define on MSDOS and WINDOWSNT, as those have their own implementations of that. --- src/term.c | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/term.c b/src/term.c index 37c06a560dd..1059b0669a7 100644 --- a/src/term.c +++ b/src/term.c @@ -790,6 +790,8 @@ tty_write_glyphs (struct frame *f, struct glyph *string, int len) cmcheckmagic (tty); } +#ifndef DOS_NT + static void tty_write_glyphs_with_face (register struct frame *f, register struct glyph *string, register int len, register int face_id) @@ -846,6 +848,8 @@ tty_write_glyphs_with_face (register struct frame *f, register struct glyph *str cmcheckmagic (tty); } +#endif + /* An implementation of insert_glyphs for termcap frames. */ static void @@ -2377,7 +2381,9 @@ frame's terminal). */) Mouse ***********************************************************************/ -/* Implementation of draw_row_with_mouse_face for TTY/GPM. */ +#ifndef DOS_NT + +/* Implementation of draw_row_with_mouse_face for TTY/GPM and macOS. */ void tty_draw_row_with_mouse_face (struct window *w, struct glyph_row *row, int start_hpos, int end_hpos, @@ -2409,6 +2415,8 @@ tty_draw_row_with_mouse_face (struct window *w, struct glyph_row *row, cursor_to (f, save_y, save_x); } +#endif + #ifdef HAVE_GPM void From 4c0dce4b66c41a12a4cf7439b036962e9525eeaa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Fri, 22 Jan 2021 15:47:48 +0100 Subject: [PATCH 100/133] Calc: use big brackets around function arguments * lisp/calc/calccomp.el (math-compose-expr): Use big brackets around arguments in Big mode, so that expressions like sin(a/b) look a bit better. --- lisp/calc/calccomp.el | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/lisp/calc/calccomp.el b/lisp/calc/calccomp.el index 5f38ee71c78..bd81d7fe406 100644 --- a/lisp/calc/calccomp.el +++ b/lisp/calc/calccomp.el @@ -822,9 +822,16 @@ (if (setq spfn (get calc-language 'math-func-formatter)) (funcall spfn func a) - (list 'horiz func calc-function-open - (math-compose-vector (cdr a) ", " 0) - calc-function-close)))))))))) + (let ((args (math-compose-vector (cdr a) ", " 0))) + (if (and (member calc-function-open '("(" "[" "{")) + (member calc-function-close '(")" "]" "}"))) + (list 'horiz func + (math--comp-bracket + (string-to-char calc-function-open) + (string-to-char calc-function-close) + args)) + (list 'horiz func calc-function-open + args calc-function-close)))))))))))) (defun math-prod-first-term (x) From b2b26bd4d66d25f2456baa4e9eb9516c122a30e0 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Fri, 22 Jan 2021 17:39:52 +0100 Subject: [PATCH 101/133] Use RemoteCommand option for Tramp's sshx and scpx methods * doc/misc/tramp.texi (Inline methods) : (External methods) : Adapt call sequence. (Remote shell setup): Mention, that sshx and scpx overwrite RemoteCommand. (Remote processes): Restriction: direct asynchronous processes cannot be used when RemoteCommand is in use. `tramp-remote-process-environment' is not ignored any longer. * lisp/net/tramp-sh.el (tramp-methods) : Handle login shell via RemoteCommand. Remove `tramp-direct-async' parameter. (tramp-maybe-open-connection): Add "-i" to login. * lisp/net/tramp-smb.el (tramp-smb-errors): Add "NT_STATUS_NOT_SUPPORTED". (tramp-smb-handle-insert-directory): Fix point moving error. * test/lisp/net/tramp-tests.el (tramp-test34-explicit-shell-file-name): Use `get-buffer-process' where appropriate. --- doc/misc/tramp.texi | 27 +++++++++++++++++---------- lisp/net/tramp-sh.el | 12 +++++------- lisp/net/tramp-smb.el | 24 ++++++++++++------------ test/lisp/net/tramp-tests.el | 2 +- 4 files changed, 35 insertions(+), 30 deletions(-) diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index e9ffd6a8c43..5d89b065882 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -810,9 +810,10 @@ behavior. @cindex @option{sshx} method Works like @option{ssh} but without the extra authentication prompts. -@option{sshx} uses @samp{ssh -t -t @var{host} -l @var{user} /bin/sh} -to open a connection with a ``standard'' login shell. It supports -changing the remote login shell @command{/bin/sh}. +@option{sshx} uses @samp{ssh -t -t -l @var{user} -o +RemoteCommand='/bin/sh -i' @var{host}} to open a connection with a +``standard'' login shell. It supports changing the remote login shell +@command{/bin/sh}. @strong{Note} that @option{sshx} does not bypass authentication questions. For example, if the host key of the remote host is not @@ -935,9 +936,10 @@ This method supports the @samp{-p} argument. @cindex @command{ssh} (with @option{scpx} method) @option{scpx} is useful to avoid login shell questions. It is similar -in performance to @option{scp}. @option{scpx} uses @samp{ssh -t -t -@var{host} -l @var{user} /bin/sh} to open a connection. It supports -changing the remote login shell @command{/bin/sh}. +in performance to @option{scp}. @option{scpx} uses @samp{ssh -t -t -l +@var{user} -o RemoteCommand='/bin/sh -i' @var{host}} to open a +connection. It supports changing the remote login shell +@command{/bin/sh}. @option{scpx} is useful for MS Windows users when @command{ssh} triggers an error about allocating a pseudo tty. This happens due to @@ -2220,7 +2222,10 @@ This uses also the settings in @code{tramp-sh-extra-args}. @vindex RemoteCommand@r{, ssh option} @strong{Note}: If you use an @option{ssh}-based method for connection, do @emph{not} set the @option{RemoteCommand} option in your -@command{ssh} configuration, for example to @command{screen}. +@command{ssh} configuration, for example to @command{screen}. On the +other hand, some @option{ssh}-based methods, like @option{sshx} or +@option{scpx}, silently overwrite a @option{RemoteCommand} option of +the configuration file. @subsection Other remote shell setup hints @@ -3580,13 +3585,16 @@ Furthermore, this approach has the following limitations: It works only for connection methods defined in @file{tramp-sh.el} and @file{tramp-adb.el}. -@vindex ControlMaster@r{, ssh option} @item It does not support interactive user authentication. With @option{ssh}-based methods, this can be avoided by using a password agent like @command{ssh-agent}, using public key authentication, or using @option{ControlMaster} options. +@item +It cannot be applied for @option{ssh}-based methods, which use the +@option{RemoteCommand} option. + @item It cannot be killed via @code{interrupt-process}. @@ -3597,8 +3605,7 @@ It does not report the remote terminal name via @code{process-tty-name}. It does not set process property @code{remote-pid}. @item -It does not use @code{tramp-remote-path} and -@code{tramp-remote-process-environment}. +It does not use @code{tramp-remote-path}. @end itemize In order to gain even more performance, it is recommended to bind diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 618a9fb9d02..d7ca7c9780c 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -181,10 +181,9 @@ The string is used in `tramp-methods'.") `("scpx" (tramp-login-program "ssh") (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") - ("-e" "none") ("-t" "-t") ("%h") - ("%l"))) + ("-e" "none") ("-t" "-t") + ("-o" "RemoteCommand='%l'") ("%h"))) (tramp-async-args (("-q"))) - (tramp-direct-async t) (tramp-remote-shell ,tramp-default-remote-shell) (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) @@ -238,10 +237,9 @@ The string is used in `tramp-methods'.") `("sshx" (tramp-login-program "ssh") (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") - ("-e" "none") ("-t" "-t") ("%h") - ("%l"))) + ("-e" "none") ("-t" "-t") + ("-o" "RemoteCommand='%l'") ("%h"))) (tramp-async-args (("-q"))) - (tramp-direct-async t) (tramp-remote-shell ,tramp-default-remote-shell) (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")))) @@ -5124,7 +5122,7 @@ connection if a previous connection has died for some reason." options (format-spec options spec) spec (format-spec-make ?h l-host ?u l-user ?p l-port ?c options - ?l (concat remote-shell " " extra-args)) + ?l (concat remote-shell " " extra-args " -i")) command (concat ;; We do not want to see the trailing local diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 1604e8962c0..c5a74a5c653 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -156,6 +156,7 @@ this variable (\"client min protocol=NT1\") ." "NT_STATUS_NO_SUCH_FILE" "NT_STATUS_NO_SUCH_USER" "NT_STATUS_NOT_A_DIRECTORY" + "NT_STATUS_NOT_SUPPORTED" "NT_STATUS_OBJECT_NAME_COLLISION" "NT_STATUS_OBJECT_NAME_INVALID" "NT_STATUS_OBJECT_NAME_NOT_FOUND" @@ -371,17 +372,17 @@ pass to the OPERATION." (tramp-error v2 'file-error "add-name-to-file: %s must not be a directory" filename)) - ;; Do the 'confirm if exists' thing. - (when (file-exists-p newname) - ;; What to do? - (if (or (null ok-if-already-exists) ; not allowed to exist - (and (numberp ok-if-already-exists) - (not (yes-or-no-p - (format - "File %s already exists; make it a link anyway? " - v2-localname))))) - (tramp-error v2 'file-already-exists newname) - (delete-file newname))) + ;; Do the 'confirm if exists' thing. + (when (file-exists-p newname) + ;; What to do? + (if (or (null ok-if-already-exists) ; not allowed to exist + (and (numberp ok-if-already-exists) + (not (yes-or-no-p + (format + "File %s already exists; make it a link anyway? " + v2-localname))))) + (tramp-error v2 'file-already-exists newname) + (delete-file newname))) ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. (tramp-flush-file-properties v2 v2-localname) @@ -1166,7 +1167,6 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (insert " -> " (tramp-compat-file-attribute-type attr)))) (insert "\n") - (forward-line) (beginning-of-line))) entries)))))) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 5deee658296..4c84507807b 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -5247,7 +5247,7 @@ Use direct async.") ;; order to avoid a question. `explicit-sh-args' echoes the ;; test data. (with-current-buffer (get-buffer-create "*shell*") - (ignore-errors (kill-process (current-buffer))) + (ignore-errors (kill-process (get-buffer-process (current-buffer)))) (should-not explicit-shell-file-name) (call-interactively #'shell) (with-timeout (10) From ef14acfb68bb5b0ce42221e9681b93562f8085eb Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 22 Jan 2021 19:07:52 +0100 Subject: [PATCH 102/133] Make nnml handle invalid non-ASCII headers more consistently * lisp/gnus/nnml.el (nnml--encode-headers): New function to RFC2047-encode invalid Subject/From headers (bug#45925). This will make them be displayed more consistently in the Summary buffer (but still "wrong" sometimes, since there's not that much we can guess at at this stage, charset wise). (nnml-parse-head): Use it. --- lisp/gnus/nnml.el | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el index ebececa3ce2..3cdfc749703 100644 --- a/lisp/gnus/nnml.el +++ b/lisp/gnus/nnml.el @@ -769,8 +769,24 @@ article number. This function is called narrowed to an article." (let ((headers (nnheader-parse-head t))) (setf (mail-header-chars headers) chars) (setf (mail-header-number headers) number) + ;; If there's non-ASCII raw characters in the data, + ;; RFC2047-encode them to avoid having arbitrary data in the + ;; .overview file. + (nnml--encode-headers headers) headers)))) +(defun nnml--encode-headers (headers) + (let ((subject (mail-header-subject headers)) + (rfc2047-encoding-type 'mime)) + (unless (string-match "\\`[[:ascii:]]*\\'" subject) + (setf (mail-header-subject headers) + (mail-encode-encoded-word-string subject t)))) + (let ((from (mail-header-from headers)) + (rfc2047-encoding-type 'address-mime)) + (unless (string-match "\\`[[:ascii:]]*\\'" from) + (setf (mail-header-from headers) + (rfc2047-encode-string from t))))) + (defun nnml-get-nov-buffer (group &optional incrementalp) (let ((buffer (gnus-get-buffer-create (format " *nnml %soverview %s*" From 2be55ad66910730d81f727d3bc4a25d196422d04 Mon Sep 17 00:00:00 2001 From: Keith David Bershatsky Date: Fri, 22 Jan 2021 19:18:41 +0100 Subject: [PATCH 103/133] Add more isearch-related bindings to ns-win.el * lisp/term/ns-win.el (minibuffer-local-isearch-map): Add more bindings to mirror bindings in isearch.el (bug#15667). --- lisp/term/ns-win.el | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/lisp/term/ns-win.el b/lisp/term/ns-win.el index 5f4dd9ef587..94e9d5c5828 100644 --- a/lisp/term/ns-win.el +++ b/lisp/term/ns-win.el @@ -120,6 +120,15 @@ The properties returned may include `top', `left', `height', and `width'." (define-key global-map [?\s-d] 'isearch-repeat-backward) (define-key global-map [?\s-e] 'isearch-yank-kill) (define-key global-map [?\s-f] 'isearch-forward) +(define-key esc-map [?\s-f] 'isearch-forward-regexp) +(define-key minibuffer-local-isearch-map [?\s-f] + 'isearch-forward-exit-minibuffer) +(define-key isearch-mode-map [?\s-f] 'isearch-repeat-forward) +(define-key global-map [?\s-F] 'isearch-backward) +(define-key esc-map [?\s-F] 'isearch-backward-regexp) +(define-key minibuffer-local-isearch-map [?\s-F] + 'isearch-reverse-exit-minibuffer) +(define-key isearch-mode-map [?\s-F] 'isearch-repeat-backward) (define-key global-map [?\s-g] 'isearch-repeat-forward) (define-key global-map [?\s-h] 'ns-do-hide-emacs) (define-key global-map [?\s-H] 'ns-do-hide-others) From b7f318aa9611f132ba93745f663573bd223a2641 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 22 Jan 2021 19:22:07 +0100 Subject: [PATCH 104/133] Fix up previous mh-speed.el ignored variable change * lisp/mh-e/mh-speed.el (mh-speed-toggle, mh-speed-view): Mark the ignored parameter with _ instead of using the Common Lispish (declare (ignore args)) (which Emacs Lisp doesn't really support), except by accident. --- lisp/mh-e/mh-speed.el | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/lisp/mh-e/mh-speed.el b/lisp/mh-e/mh-speed.el index 00b96804174..7cbd42c8ea2 100644 --- a/lisp/mh-e/mh-speed.el +++ b/lisp/mh-e/mh-speed.el @@ -125,10 +125,9 @@ With non-nil FORCE, the update is always carried out." ;; Otherwise on to your regular programming (t t))) -(defun mh-speed-toggle (&rest ignored) +(defun mh-speed-toggle (&rest _ignored) "Toggle the display of child folders in the speedbar. The optional arguments from speedbar are IGNORED." - (declare (ignore args)) (interactive) (beginning-of-line) (let ((parent (get-text-property (point) 'mh-folder)) @@ -164,10 +163,9 @@ The optional arguments from speedbar are IGNORED." (mh-line-beginning-position) (1+ (line-beginning-position)) '(mh-expanded t))))))) -(defun mh-speed-view (&rest ignored) +(defun mh-speed-view (&rest _ignored) "Visits the selected folder just as if you had used \\\\[mh-visit-folder]. The optional arguments from speedbar are IGNORED." - (declare (ignore args)) (interactive) (let* ((folder (get-text-property (mh-line-beginning-position) 'mh-folder)) (range (and (stringp folder) From 9143eba0c6861f467c18bc52d66e6f5c573be56b Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Fri, 22 Jan 2021 11:44:50 -0800 Subject: [PATCH 105/133] Prepare for update from Gnulib * configure.ac: Also create lib/malloc and lib/deps/malloc if the dynarray module is in use, as Gnulib regex will start needing it due to recent glibc changes. --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index bea28338090..08f3c0cd857 100644 --- a/configure.ac +++ b/configure.ac @@ -5898,7 +5898,7 @@ if test $AUTO_DEPEND = yes; then AS_MKDIR_P([$dir/deps]) done fi -if $gl_gnulib_enabled_scratch_buffer; then +if $gl_gnulib_enabled_dynarray || $gl_gnulib_enabled_scratch_buffer; then AS_MKDIR_P([lib/malloc]) if test $AUTO_DEPEND = yes; then AS_MKDIR_P([lib/deps/malloc]) From a900e641fa1fd765799f12a7f699f768ebfccfe8 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Fri, 22 Jan 2021 11:45:38 -0800 Subject: [PATCH 106/133] Update from Gnulib by running admin/merge-gnulib --- build-aux/config.guess | 8 +- build-aux/config.sub | 10 +- doc/misc/texinfo.tex | 163 +++---- lib/_Noreturn.h | 16 +- lib/canonicalize-lgpl.c | 25 +- lib/cdefs.h | 186 +++++--- lib/dirent.in.h | 3 +- lib/dynarray.h | 31 ++ lib/fchmodat.c | 17 + lib/free.c | 14 + lib/gnulib.mk.in | 27 ++ lib/libc-config.h | 171 +++---- lib/malloc/dynarray-skeleton.c | 525 +++++++++++++++++++++ lib/malloc/dynarray.h | 178 +++++++ lib/malloc/dynarray_at_failure.c | 35 ++ lib/malloc/dynarray_emplace_enlarge.c | 73 +++ lib/malloc/dynarray_finalize.c | 62 +++ lib/malloc/dynarray_resize.c | 64 +++ lib/malloc/dynarray_resize_clear.c | 35 ++ lib/malloc/scratch_buffer_grow.c | 2 +- lib/malloc/scratch_buffer_grow_preserve.c | 2 +- lib/malloc/scratch_buffer_set_array_size.c | 2 +- lib/mini-gmp.c | 2 +- lib/mktime-internal.h | 2 +- lib/nstrftime.c | 6 +- lib/regex.c | 2 +- lib/regex_internal.h | 26 +- lib/regexec.c | 117 ++--- lib/scratch_buffer.h | 1 + lib/stddef.in.h | 23 +- lib/string.in.h | 20 +- lib/sys_stat.in.h | 30 +- lib/tempname.c | 27 +- lib/time-internal.h | 2 +- lib/time.in.h | 19 + lib/time_rz.c | 16 +- lib/timegm.c | 2 +- lib/utimens.c | 19 +- lib/utimensat.c | 101 +++- lib/verify.h | 28 +- m4/canonicalize.m4 | 62 ++- m4/extensions.m4 | 14 +- m4/fchmodat.m4 | 48 +- m4/gnulib-common.m4 | 15 +- m4/gnulib-comp.m4 | 20 + m4/nstrftime.m4 | 4 +- m4/stddef_h.m4 | 16 +- m4/string_h.m4 | 3 +- m4/sys_stat_h.m4 | 4 +- m4/time_h.m4 | 20 +- m4/utimensat.m4 | 57 ++- 51 files changed, 1841 insertions(+), 514 deletions(-) create mode 100644 lib/dynarray.h create mode 100644 lib/malloc/dynarray-skeleton.c create mode 100644 lib/malloc/dynarray.h create mode 100644 lib/malloc/dynarray_at_failure.c create mode 100644 lib/malloc/dynarray_emplace_enlarge.c create mode 100644 lib/malloc/dynarray_finalize.c create mode 100644 lib/malloc/dynarray_resize.c create mode 100644 lib/malloc/dynarray_resize_clear.c diff --git a/build-aux/config.guess b/build-aux/config.guess index 7f748177972..f7727026b70 100755 --- a/build-aux/config.guess +++ b/build-aux/config.guess @@ -1,8 +1,8 @@ #! /bin/sh # Attempt to guess a canonical system name. -# Copyright 1992-2020 Free Software Foundation, Inc. +# Copyright 1992-2021 Free Software Foundation, Inc. -timestamp='2020-12-22' +timestamp='2021-01-01' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by @@ -50,7 +50,7 @@ version="\ GNU config.guess ($timestamp) Originally written by Per Bothner. -Copyright 1992-2020 Free Software Foundation, Inc. +Copyright 1992-2021 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." @@ -1087,7 +1087,7 @@ EOF ppcle:Linux:*:*) echo powerpcle-unknown-linux-"$LIBC" exit ;; - riscv32:Linux:*:* | riscv64:Linux:*:*) + riscv32:Linux:*:* | riscv32be:Linux:*:* | riscv64:Linux:*:* | riscv64be:Linux:*:*) echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; s390:Linux:*:* | s390x:Linux:*:*) diff --git a/build-aux/config.sub b/build-aux/config.sub index 90bb8aeda63..b0f8492348d 100755 --- a/build-aux/config.sub +++ b/build-aux/config.sub @@ -1,8 +1,8 @@ #! /bin/sh # Configuration validation subroutine script. -# Copyright 1992-2020 Free Software Foundation, Inc. +# Copyright 1992-2021 Free Software Foundation, Inc. -timestamp='2020-12-22' +timestamp='2021-01-07' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by @@ -67,7 +67,7 @@ Report bugs and patches to ." version="\ GNU config.sub ($timestamp) -Copyright 1992-2020 Free Software Foundation, Inc. +Copyright 1992-2021 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." @@ -1230,7 +1230,7 @@ case $cpu-$vendor in | powerpc | powerpc64 | powerpc64le | powerpcle | powerpcspe \ | pru \ | pyramid \ - | riscv | riscv32 | riscv64 \ + | riscv | riscv32 | riscv32be | riscv64 | riscv64be \ | rl78 | romp | rs6000 | rx \ | s390 | s390x \ | score \ @@ -1687,7 +1687,7 @@ case $os in musl* | newlib* | uclibc*) ;; # Likewise for "kernel-libc" - eabi | eabihf | gnueabi | gnueabihf) + eabi* | gnueabi*) ;; # Now accept the basic system types. # The portable systems comes first. diff --git a/doc/misc/texinfo.tex b/doc/misc/texinfo.tex index 3c7051d1c74..dac7ae3d199 100644 --- a/doc/misc/texinfo.tex +++ b/doc/misc/texinfo.tex @@ -3,7 +3,7 @@ % Load plain if necessary, i.e., if running under initex. \expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi % -\def\texinfoversion{2020-10-24.12} +\def\texinfoversion{2020-11-25.18} % % Copyright 1985, 1986, 1988, 1990-2020 Free Software Foundation, Inc. % @@ -572,10 +572,9 @@ \fi } -% @end foo executes the definition of \Efoo. -% But first, it executes a specialized version of \checkenv -% -\parseargdef\end{% + +% @end foo calls \checkenv and executes the definition of \Efoo. +\parseargdef\end{ \if 1\csname iscond.#1\endcsname \else % The general wording of \badenverr may not be ideal. @@ -2673,8 +2672,6 @@ \definetextfontsizexi -\message{markup,} - % Check if we are currently using a typewriter font. Since all the % Computer Modern typewriter fonts have zero interword stretch (and % shrink), and it is reasonable to expect all typewriter fonts to have @@ -2682,68 +2679,14 @@ % \def\ifmonospace{\ifdim\fontdimen3\font=0pt } -% Markup style infrastructure. \defmarkupstylesetup\INITMACRO will -% define and register \INITMACRO to be called on markup style changes. -% \INITMACRO can check \currentmarkupstyle for the innermost -% style. - -\let\currentmarkupstyle\empty - -\def\setupmarkupstyle#1{% - \def\currentmarkupstyle{#1}% - \markupstylesetup -} - -\let\markupstylesetup\empty - -\def\defmarkupstylesetup#1{% - \expandafter\def\expandafter\markupstylesetup - \expandafter{\markupstylesetup #1}% - \def#1% -} - -% Markup style setup for left and right quotes. -\defmarkupstylesetup\markupsetuplq{% - \expandafter\let\expandafter \temp - \csname markupsetuplq\currentmarkupstyle\endcsname - \ifx\temp\relax \markupsetuplqdefault \else \temp \fi -} - -\defmarkupstylesetup\markupsetuprq{% - \expandafter\let\expandafter \temp - \csname markupsetuprq\currentmarkupstyle\endcsname - \ifx\temp\relax \markupsetuprqdefault \else \temp \fi -} - { \catcode`\'=\active \catcode`\`=\active -\gdef\markupsetuplqdefault{\let`\lq} -\gdef\markupsetuprqdefault{\let'\rq} - -\gdef\markupsetcodequoteleft{\let`\codequoteleft} -\gdef\markupsetcodequoteright{\let'\codequoteright} +\gdef\setcodequotes{\let`\codequoteleft \let'\codequoteright} +\gdef\setregularquotes{\let`\lq \let'\rq} } -\let\markupsetuplqcode \markupsetcodequoteleft -\let\markupsetuprqcode \markupsetcodequoteright -% -\let\markupsetuplqexample \markupsetcodequoteleft -\let\markupsetuprqexample \markupsetcodequoteright -% -\let\markupsetuplqkbd \markupsetcodequoteleft -\let\markupsetuprqkbd \markupsetcodequoteright -% -\let\markupsetuplqsamp \markupsetcodequoteleft -\let\markupsetuprqsamp \markupsetcodequoteright -% -\let\markupsetuplqverb \markupsetcodequoteleft -\let\markupsetuprqverb \markupsetcodequoteright -% -\let\markupsetuplqverbatim \markupsetcodequoteleft -\let\markupsetuprqverbatim \markupsetcodequoteright - % Allow an option to not use regular directed right quote/apostrophe % (char 0x27), but instead the undirected quote from cmtt (char 0x0d). % The undirected quote is ugly, so don't make it the default, but it @@ -2906,7 +2849,7 @@ } % @samp. -\def\samp#1{{\setupmarkupstyle{samp}\lq\tclose{#1}\rq\null}} +\def\samp#1{{\setcodequotes\lq\tclose{#1}\rq\null}} % @indicateurl is \samp, that is, with quotes. \let\indicateurl=\samp @@ -2949,8 +2892,7 @@ \global\let'=\rq \global\let`=\lq % default definitions % \global\def\code{\begingroup - \setupmarkupstyle{code}% - % The following should really be moved into \setupmarkupstyle handlers. + \setcodequotes \catcode\dashChar=\active \catcode\underChar=\active \ifallowcodebreaks \let-\codedash @@ -3104,7 +3046,7 @@ \urefcatcodes % \global\def\urefcode{\begingroup - \setupmarkupstyle{code}% + \setcodequotes \urefcatcodes \let&\urefcodeamp \let.\urefcodedot @@ -3225,8 +3167,8 @@ \def\kbdsub#1#2#3\par{% \def\one{#1}\def\three{#3}\def\threex{??}% \ifx\one\xkey\ifx\threex\three \key{#2}% - \else{\tclose{\kbdfont\setupmarkupstyle{kbd}\look}}\fi - \else{\tclose{\kbdfont\setupmarkupstyle{kbd}\look}}\fi + \else{\tclose{\kbdfont\setcodequotes\look}}\fi + \else{\tclose{\kbdfont\setcodequotes\look}}\fi } % definition of @key that produces a lozenge. Doesn't adjust to text size. @@ -3243,7 +3185,7 @@ % monospace, don't change it; that way, we respect @kbdinputstyle. But % if it isn't monospace, then use \tt. % -\def\key#1{{\setupmarkupstyle{key}% +\def\key#1{{\setregularquotes \nohyphenation \ifmonospace\else\tt\fi #1}\null} @@ -3373,16 +3315,20 @@ {\obeylines \globaldefs=1 \envdef\displaymath{% -\tex +\tex% \def\thisenv{\displaymath}% +\begingroup\let\end\displaymathend% $$% } -\def\Edisplaymath{$$ +\def\displaymathend{$$\endgroup\end}% + +\def\Edisplaymath{% \def\thisenv{\tex}% \end tex }} + % @inlinefmt{FMTNAME,PROCESSED-TEXT} and @inlineraw{FMTNAME,RAW-TEXT}. % Ignore unless FMTNAME == tex; then it is like @iftex and @tex, % except specified as a normal braced arg, so no newlines to worry about. @@ -7144,7 +7090,7 @@ % But \@ or @@ will get a plain @ character. \envdef\tex{% - \setupmarkupstyle{tex}% + \setregularquotes \catcode `\\=0 \catcode `\{=1 \catcode `\}=2 \catcode `\$=3 \catcode `\&=4 \catcode `\#=6 \catcode `\^=7 \catcode `\_=8 \catcode `\~=\active \let~=\tie @@ -7370,7 +7316,7 @@ % If you want all examples etc. small: @set dispenvsize small. % If you want even small examples the full size: @set dispenvsize nosmall. % This affects the following displayed environments: -% @example, @display, @format, @lisp +% @example, @display, @format, @lisp, @verbatim % \def\smallword{small} \def\nosmallword{nosmall} @@ -7416,9 +7362,9 @@ % \maketwodispenvdef{lisp}{example}{% \nonfillstart - \tt\setupmarkupstyle{example}% + \tt\setcodequotes \let\kbdfont = \kbdexamplefont % Allow @kbd to do something special. - \gobble % eat return + \parsearg\gobble } % @display/@smalldisplay: same as @lisp except keep current font. % @@ -7576,7 +7522,7 @@ \def\setupverb{% \tt % easiest (and conventionally used) font for verbatim \def\par{\leavevmode\endgraf}% - \setupmarkupstyle{verb}% + \setcodequotes \tabeightspaces % Respect line breaks, % print special symbols as themselves, and @@ -7617,7 +7563,7 @@ \tt % easiest (and conventionally used) font for verbatim \def\par{\egroup\leavevmode\box\verbbox\endgraf\starttabbox}% \tabexpand - \setupmarkupstyle{verbatim}% + \setcodequotes % Respect line breaks, % print special symbols as themselves, and % make each space count. @@ -8036,7 +7982,7 @@ % leave the code in, but it's strange for @var to lead to typewriter. % Nowadays we recommend @code, since the difference between a ttsl hyphen % and a tt hyphen is pretty tiny. @code also disables ?` !`. - \def\var##1{{\setupmarkupstyle{var}\ttslanted{##1}}}% + \def\var##1{{\setregularquotes\ttslanted{##1}}}% #1% \sl\hyphenchar\font=45 } @@ -8145,11 +8091,18 @@ } \fi +\let\E=\expandafter + % Used at the time of macro expansion. % Argument is macro body with arguments substituted \def\scanmacro#1{% \newlinechar`\^^M - \def\xeatspaces{\eatspaces}% + % expand the expansion of \eatleadingcr twice to maybe remove a leading + % newline (and \else and \fi tokens), then call \eatspaces on the result. + \def\xeatspaces##1{% + \E\E\E\E\E\E\E\eatspaces\E\E\E\E\E\E\E{\eatleadingcr##1% + }}% + \def\xempty##1{}% % % Process the macro body under the current catcode regime. \scantokens{#1@comment}% @@ -8202,6 +8155,11 @@ \unbrace{\gdef\trim@@@ #1 } #2@{#1} } +{\catcode`\^^M=\other% +\gdef\eatleadingcr#1{\if\noexpand#1\noexpand^^M\else\E#1\fi}}% +% Warning: this won't work for a delimited argument +% or for an empty argument + % Trim a single trailing ^^M off a string. {\catcode`\^^M=\other \catcode`\Q=3% \gdef\eatcr #1{\eatcra #1Q^^MQ}% @@ -8368,6 +8326,7 @@ \let\hash\relax % \hash is redefined to `#' later to get it into definitions \let\xeatspaces\relax + \let\xempty\relax \parsemargdefxxx#1,;,% \ifnum\paramno<10\relax\else \paramno0\relax @@ -8379,9 +8338,11 @@ \else \let\next=\parsemargdefxxx \advance\paramno by 1 \expandafter\edef\csname macarg.\eatspaces{#1}\endcsname - {\xeatspaces{\hash\the\paramno}}% + {\xeatspaces{\hash\the\paramno\noexpand\xempty{}}}% \edef\paramlist{\paramlist\hash\the\paramno,}% \fi\next} +% the \xempty{} is to give \eatleadingcr an argument in the case of an +% empty macro argument. % \parsemacbody, \parsermacbody % @@ -9107,20 +9068,22 @@ % output the `[mynode]' via the macro below so it can be overridden. \xrefprintnodename\printedrefname % - % But we always want a comma and a space: - ,\space - % - % output the `page 3'. - \turnoffactive \putwordpage\tie\refx{#1-pg}{}% - % Add a , if xref followed by a space - \if\space\noexpand\tokenafterxref ,% - \else\ifx\ \tokenafterxref ,% @TAB - \else\ifx\*\tokenafterxref ,% @* - \else\ifx\ \tokenafterxref ,% @SPACE - \else\ifx\ - \tokenafterxref ,% @NL - \else\ifx\tie\tokenafterxref ,% @tie - \fi\fi\fi\fi\fi\fi + \expandafter\ifx\csname SETtxiomitxrefpg\endcsname\relax + % But we always want a comma and a space: + ,\space + % + % output the `page 3'. + \turnoffactive \putwordpage\tie\refx{#1-pg}{}% + % Add a , if xref followed by a space + \if\space\noexpand\tokenafterxref ,% + \else\ifx\ \tokenafterxref ,% @TAB + \else\ifx\*\tokenafterxref ,% @* + \else\ifx\ \tokenafterxref ,% @SPACE + \else\ifx\ + \tokenafterxref ,% @NL + \else\ifx\tie\tokenafterxref ,% @tie + \fi\fi\fi\fi\fi\fi + \fi \fi\fi \fi \endlink @@ -9550,7 +9513,7 @@ \def\imagexxx#1,#2,#3,#4,#5,#6\finish{\begingroup \catcode`\^^M = 5 % in case we're inside an example \normalturnoffactive % allow _ et al. in names - \def\xprocessmacroarg{\eatspaces}% in case we are being used via a macro + \makevalueexpandable % If the image is by itself, center it. \ifvmode \imagevmodetrue @@ -11603,7 +11566,7 @@ \let> = \activegtr \let~ = \activetilde \let^ = \activehat - \markupsetuplqdefault \markupsetuprqdefault + \setregularquotes \let\b = \strong \let\i = \smartitalic % in principle, all other definitions in \tex have to be undone too. @@ -11662,8 +11625,7 @@ @let|=@normalverticalbar @let~=@normaltilde @let\=@ttbackslash - @markupsetuplqdefault - @markupsetuprqdefault + @setregularquotes @unsepspaces } } @@ -11756,8 +11718,7 @@ @c Do this last of all since we use ` in the previous @catcode assignments. @catcode`@'=@active @catcode`@`=@active -@markupsetuplqdefault -@markupsetuprqdefault +@setregularquotes @c Local variables: @c eval: (add-hook 'before-save-hook 'time-stamp) diff --git a/lib/_Noreturn.h b/lib/_Noreturn.h index 38afe1d5672..fb718bc0691 100644 --- a/lib/_Noreturn.h +++ b/lib/_Noreturn.h @@ -26,14 +26,16 @@ AIX system header files and several gnulib header files use precisely this syntax with 'extern'. */ # define _Noreturn [[noreturn]] -# elif ((!defined __cplusplus || defined __clang__) \ - && (201112 <= (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) \ - || 4 < __GNUC__ + (7 <= __GNUC_MINOR__) \ - || (defined __apple_build_version__ \ - ? 6000000 <= __apple_build_version__ \ - : 3 < __clang_major__ + (5 <= __clang_minor__)))) +# elif ((!defined __cplusplus || defined __clang__) \ + && (201112 <= (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) \ + || (!defined __STRICT_ANSI__ \ + && (__4 < __GNUC__ + (7 <= __GNUC_MINOR__) \ + || (defined __apple_build_version__ \ + ? 6000000 <= __apple_build_version__ \ + : 3 < __clang_major__ + (5 <= __clang_minor__)))))) /* _Noreturn works as-is. */ -# elif 2 < __GNUC__ + (8 <= __GNUC_MINOR__) || 0x5110 <= __SUNPRO_C +# elif (2 < __GNUC__ + (8 <= __GNUC_MINOR__) || defined __clang__ \ + || 0x5110 <= __SUNPRO_C) # define _Noreturn __attribute__ ((__noreturn__)) # elif 1200 <= (defined _MSC_VER ? _MSC_VER : 0) # define _Noreturn __declspec (noreturn) diff --git a/lib/canonicalize-lgpl.c b/lib/canonicalize-lgpl.c index b6dc3a447ab..b7dba08994d 100644 --- a/lib/canonicalize-lgpl.c +++ b/lib/canonicalize-lgpl.c @@ -85,10 +85,6 @@ # define IF_LINT(Code) /* empty */ #endif -/* True if adding two valid object sizes might overflow idx_t. - As a practical matter, this cannot happen on 64-bit machines. */ -enum { NARROW_ADDRESSES = IDX_MAX >> 31 >> 31 == 0 }; - #ifndef DOUBLE_SLASH_IS_DISTINCT_ROOT # define DOUBLE_SLASH_IS_DISTINCT_ROOT false #endif @@ -145,11 +141,11 @@ suffix_requires_dir_check (char const *end) macOS 10.13 , and should also work on platforms like AIX 7.2 that need at least "/.". */ -#if defined _LIBC || defined LSTAT_FOLLOWS_SLASHED_SYMLINK +# if defined _LIBC || defined LSTAT_FOLLOWS_SLASHED_SYMLINK static char const dir_suffix[] = "/"; -#else +# else static char const dir_suffix[] = "/./"; -#endif +# endif /* Return true if DIR is a searchable dir, false (setting errno) otherwise. DIREND points to the NUL byte at the end of the DIR string. @@ -191,13 +187,13 @@ get_path_max (void) to pacify GCC is known; even an explicit #pragma does not pacify GCC. When the GCC bug is fixed this workaround should be limited to the broken GCC versions. */ -#if __GNUC_PREREQ (10, 1) -# if defined GCC_LINT || defined lint +# if __GNUC_PREREQ (10, 1) +# if defined GCC_LINT || defined lint __attribute__ ((__noinline__)) -# elif __OPTIMIZE__ && !__NO_INLINE__ -# define GCC_BOGUS_WRETURN_LOCAL_ADDR +# elif __OPTIMIZE__ && !__NO_INLINE__ +# define GCC_BOGUS_WRETURN_LOCAL_ADDR +# endif # endif -#endif static char * realpath_stk (const char *name, char *resolved, struct scratch_buffer *rname_buf) @@ -343,7 +339,7 @@ realpath_stk (const char *name, char *resolved, if (end_in_extra_buffer) end_idx = end - extra_buf; size_t len = strlen (end); - if (NARROW_ADDRESSES && INT_ADD_OVERFLOW (len, n)) + if (INT_ADD_OVERFLOW (len, n)) { __set_errno (ENOMEM); goto error_nomem; @@ -443,7 +439,8 @@ __realpath (const char *name, char *resolved) } libc_hidden_def (__realpath) versioned_symbol (libc, __realpath, realpath, GLIBC_2_3); -#endif /* !FUNC_REALPATH_WORKS || defined _LIBC */ + +#endif /* defined _LIBC || !FUNC_REALPATH_WORKS */ #if SHLIB_COMPAT(libc, GLIBC_2_0, GLIBC_2_3) diff --git a/lib/cdefs.h b/lib/cdefs.h index 2a3dc9666b9..de74f4211cf 100644 --- a/lib/cdefs.h +++ b/lib/cdefs.h @@ -25,7 +25,7 @@ /* The GNU libc does not support any K&R compilers or the traditional mode of ISO C compilers anymore. Check for some of the combinations not - anymore supported. */ + supported anymore. */ #if defined __GNUC__ && !defined __STDC__ # error "You need a ISO C conforming compiler to use the glibc headers" #endif @@ -34,31 +34,26 @@ #undef __P #undef __PMT -/* Compilers that are not clang may object to - #if defined __clang__ && __has_attribute(...) - even though they do not need to evaluate the right-hand side of the &&. */ -#if defined __clang__ && defined __has_attribute -# define __glibc_clang_has_attribute(name) __has_attribute (name) +/* Compilers that lack __has_attribute may object to + #if defined __has_attribute && __has_attribute (...) + even though they do not need to evaluate the right-hand side of the &&. + Similarly for __has_builtin, etc. */ +#if (defined __has_attribute \ + && (!defined __clang_minor__ \ + || 3 < __clang_major__ + (5 <= __clang_minor__))) +# define __glibc_has_attribute(attr) __has_attribute (attr) #else -# define __glibc_clang_has_attribute(name) 0 +# define __glibc_has_attribute(attr) 0 #endif - -/* Compilers that are not clang may object to - #if defined __clang__ && __has_builtin(...) - even though they do not need to evaluate the right-hand side of the &&. */ -#if defined __clang__ && defined __has_builtin -# define __glibc_clang_has_builtin(name) __has_builtin (name) +#ifdef __has_builtin +# define __glibc_has_builtin(name) __has_builtin (name) #else -# define __glibc_clang_has_builtin(name) 0 +# define __glibc_has_builtin(name) 0 #endif - -/* Compilers that are not clang may object to - #if defined __clang__ && __has_extension(...) - even though they do not need to evaluate the right-hand side of the &&. */ -#if defined __clang__ && defined __has_extension -# define __glibc_clang_has_extension(ext) __has_extension (ext) +#ifdef __has_extension +# define __glibc_has_extension(ext) __has_extension (ext) #else -# define __glibc_clang_has_extension(ext) 0 +# define __glibc_has_extension(ext) 0 #endif #if defined __GNUC__ || defined __clang__ @@ -74,22 +69,26 @@ # endif /* GCC can always grok prototypes. For C++ programs we add throw() - to help it optimize the function calls. But this works only with + to help it optimize the function calls. But this only works with gcc 2.8.x and egcs. For gcc 3.4 and up we even mark C functions as non-throwing using a function attribute since programs can use the -fexceptions options for C code as well. */ # if !defined __cplusplus \ - && (__GNUC_PREREQ (3, 4) || __glibc_clang_has_attribute (__nothrow__)) + && (__GNUC_PREREQ (3, 4) || __glibc_has_attribute (__nothrow__)) # define __THROW __attribute__ ((__nothrow__ __LEAF)) # define __THROWNL __attribute__ ((__nothrow__)) # define __NTH(fct) __attribute__ ((__nothrow__ __LEAF)) fct # define __NTHNL(fct) __attribute__ ((__nothrow__)) fct # else # if defined __cplusplus && (__GNUC_PREREQ (2,8) || __clang_major >= 4) -# define __THROW throw () -# define __THROWNL throw () -# define __NTH(fct) __LEAF_ATTR fct throw () -# define __NTHNL(fct) fct throw () +# if __cplusplus >= 201103L +# define __THROW noexcept (true) +# else +# define __THROW throw () +# endif +# define __THROWNL __THROW +# define __NTH(fct) __LEAF_ATTR fct __THROW +# define __NTHNL(fct) fct __THROW # else # define __THROW # define __THROWNL @@ -142,24 +141,20 @@ #define __bos(ptr) __builtin_object_size (ptr, __USE_FORTIFY_LEVEL > 1) #define __bos0(ptr) __builtin_object_size (ptr, 0) +/* Use __builtin_dynamic_object_size at _FORTIFY_SOURCE=3 when available. */ +#if __USE_FORTIFY_LEVEL == 3 && __glibc_clang_prereq (9, 0) +# define __glibc_objsize0(__o) __builtin_dynamic_object_size (__o, 0) +# define __glibc_objsize(__o) __builtin_dynamic_object_size (__o, 1) +#else +# define __glibc_objsize0(__o) __bos0 (__o) +# define __glibc_objsize(__o) __bos (__o) +#endif + #if __GNUC_PREREQ (4,3) -# define __warndecl(name, msg) \ - extern void name (void) __attribute__((__warning__ (msg))) # define __warnattr(msg) __attribute__((__warning__ (msg))) # define __errordecl(name, msg) \ extern void name (void) __attribute__((__error__ (msg))) -#elif __glibc_clang_has_attribute (__diagnose_if__) && 0 -/* These definitions are not enabled, because they produce bogus warnings - in the glibc Fortify functions. These functions are written in a style - that works with GCC. In order to work with clang, these functions would - need to be modified. */ -# define __warndecl(name, msg) \ - extern void name (void) __attribute__((__diagnose_if__ (1, msg, "warning"))) -# define __warnattr(msg) __attribute__((__diagnose_if__ (1, msg, "warning"))) -# define __errordecl(name, msg) \ - extern void name (void) __attribute__((__diagnose_if__ (1, msg, "error"))) #else -# define __warndecl(name, msg) extern void name (void) # define __warnattr(msg) # define __errordecl(name, msg) extern void name (void) #endif @@ -233,7 +228,7 @@ /* At some point during the gcc 2.96 development the `malloc' attribute for functions was introduced. We don't want to use it unconditionally (although this would be possible) since it generates warnings. */ -#if __GNUC_PREREQ (2,96) || __glibc_clang_has_attribute (__malloc__) +#if __GNUC_PREREQ (2,96) || __glibc_has_attribute (__malloc__) # define __attribute_malloc__ __attribute__ ((__malloc__)) #else # define __attribute_malloc__ /* Ignore */ @@ -251,23 +246,31 @@ /* At some point during the gcc 2.96 development the `pure' attribute for functions was introduced. We don't want to use it unconditionally (although this would be possible) since it generates warnings. */ -#if __GNUC_PREREQ (2,96) || __glibc_clang_has_attribute (__pure__) +#if __GNUC_PREREQ (2,96) || __glibc_has_attribute (__pure__) # define __attribute_pure__ __attribute__ ((__pure__)) #else # define __attribute_pure__ /* Ignore */ #endif /* This declaration tells the compiler that the value is constant. */ -#if __GNUC_PREREQ (2,5) || __glibc_clang_has_attribute (__const__) +#if __GNUC_PREREQ (2,5) || __glibc_has_attribute (__const__) # define __attribute_const__ __attribute__ ((__const__)) #else # define __attribute_const__ /* Ignore */ #endif +#if defined __STDC_VERSION__ && 201710L < __STDC_VERSION__ +# define __attribute_maybe_unused__ [[__maybe_unused__]] +#elif __GNUC_PREREQ (2,7) || __glibc_has_attribute (__unused__) +# define __attribute_maybe_unused__ __attribute__ ((__unused__)) +#else +# define __attribute_maybe_unused__ /* Ignore */ +#endif + /* At some point during the gcc 3.1 development the `used' attribute for functions was introduced. We don't want to use it unconditionally (although this would be possible) since it generates warnings. */ -#if __GNUC_PREREQ (3,1) || __glibc_clang_has_attribute (__used__) +#if __GNUC_PREREQ (3,1) || __glibc_has_attribute (__used__) # define __attribute_used__ __attribute__ ((__used__)) # define __attribute_noinline__ __attribute__ ((__noinline__)) #else @@ -276,7 +279,7 @@ #endif /* Since version 3.2, gcc allows marking deprecated functions. */ -#if __GNUC_PREREQ (3,2) || __glibc_clang_has_attribute (__deprecated__) +#if __GNUC_PREREQ (3,2) || __glibc_has_attribute (__deprecated__) # define __attribute_deprecated__ __attribute__ ((__deprecated__)) #else # define __attribute_deprecated__ /* Ignore */ @@ -285,8 +288,8 @@ /* Since version 4.5, gcc also allows one to specify the message printed when a deprecated function is used. clang claims to be gcc 4.2, but may also support this feature. */ -#if __GNUC_PREREQ (4,5) || \ - __glibc_clang_has_extension (__attribute_deprecated_with_message__) +#if __GNUC_PREREQ (4,5) \ + || __glibc_has_extension (__attribute_deprecated_with_message__) # define __attribute_deprecated_msg__(msg) \ __attribute__ ((__deprecated__ (msg))) #else @@ -299,7 +302,7 @@ If several `format_arg' attributes are given for the same function, in gcc-3.0 and older, all but the last one are ignored. In newer gccs, all designated arguments are considered. */ -#if __GNUC_PREREQ (2,8) || __glibc_clang_has_attribute (__format_arg__) +#if __GNUC_PREREQ (2,8) || __glibc_has_attribute (__format_arg__) # define __attribute_format_arg__(x) __attribute__ ((__format_arg__ (x))) #else # define __attribute_format_arg__(x) /* Ignore */ @@ -309,7 +312,7 @@ attribute for functions was introduced. We don't want to use it unconditionally (although this would be possible) since it generates warnings. */ -#if __GNUC_PREREQ (2,97) || __glibc_clang_has_attribute (__format__) +#if __GNUC_PREREQ (2,97) || __glibc_has_attribute (__format__) # define __attribute_format_strfmon__(a,b) \ __attribute__ ((__format__ (__strfmon__, a, b))) #else @@ -320,7 +323,7 @@ must not be NULL. Do not define __nonnull if it is already defined, for portability when this file is used in Gnulib. */ #ifndef __nonnull -# if __GNUC_PREREQ (3,3) || __glibc_clang_has_attribute (__nonnull__) +# if __GNUC_PREREQ (3,3) || __glibc_has_attribute (__nonnull__) # define __nonnull(params) __attribute__ ((__nonnull__ params)) # else # define __nonnull(params) @@ -329,7 +332,7 @@ /* If fortification mode, we warn about unused results of certain function calls which can lead to problems. */ -#if __GNUC_PREREQ (3,4) || __glibc_clang_has_attribute (__warn_unused_result__) +#if __GNUC_PREREQ (3,4) || __glibc_has_attribute (__warn_unused_result__) # define __attribute_warn_unused_result__ \ __attribute__ ((__warn_unused_result__)) # if defined __USE_FORTIFY_LEVEL && __USE_FORTIFY_LEVEL > 0 @@ -343,7 +346,7 @@ #endif /* Forces a function to be always inlined. */ -#if __GNUC_PREREQ (3,2) || __glibc_clang_has_attribute (__always_inline__) +#if __GNUC_PREREQ (3,2) || __glibc_has_attribute (__always_inline__) /* The Linux kernel defines __always_inline in stddef.h (283d7573), and it conflicts with this definition. Therefore undefine it first to allow either header to be included first. */ @@ -356,7 +359,7 @@ /* Associate error messages with the source location of the call site rather than with the source location inside the function. */ -#if __GNUC_PREREQ (4,3) || __glibc_clang_has_attribute (__artificial__) +#if __GNUC_PREREQ (4,3) || __glibc_has_attribute (__artificial__) # define __attribute_artificial__ __attribute__ ((__artificial__)) #else # define __attribute_artificial__ /* Ignore */ @@ -433,7 +436,7 @@ # endif #endif -#if (__GNUC__ >= 3) || __glibc_clang_has_builtin (__builtin_expect) +#if (__GNUC__ >= 3) || __glibc_has_builtin (__builtin_expect) # define __glibc_unlikely(cond) __builtin_expect ((cond), 0) # define __glibc_likely(cond) __builtin_expect ((cond), 1) #else @@ -441,12 +444,6 @@ # define __glibc_likely(cond) (cond) #endif -#ifdef __has_attribute -# define __glibc_has_attribute(attr) __has_attribute (attr) -#else -# define __glibc_has_attribute(attr) 0 -#endif - #if (!defined _Noreturn \ && (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) < 201112 \ && !(__GNUC_PREREQ (4,7) \ @@ -467,6 +464,16 @@ # define __attribute_nonstring__ #endif +/* Undefine (also defined in libc-symbols.h). */ +#undef __attribute_copy__ +#if __GNUC_PREREQ (9, 0) +/* Copies attributes from the declaration or type referenced by + the argument. */ +# define __attribute_copy__(arg) __attribute__ ((__copy__ (arg))) +#else +# define __attribute_copy__(arg) +#endif + #if (!defined _Static_assert && !defined __cplusplus \ && (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) < 201112 \ && (!(__GNUC_PREREQ (4, 6) || __clang_major__ >= 4) \ @@ -483,7 +490,37 @@ # include #endif -#if defined __LONG_DOUBLE_MATH_OPTIONAL && defined __NO_LONG_DOUBLE_MATH +#if __LDOUBLE_REDIRECTS_TO_FLOAT128_ABI == 1 +# ifdef __REDIRECT + +/* Alias name defined automatically. */ +# define __LDBL_REDIR(name, proto) ... unused__ldbl_redir +# define __LDBL_REDIR_DECL(name) \ + extern __typeof (name) name __asm (__ASMNAME ("__" #name "ieee128")); + +/* Alias name defined automatically, with leading underscores. */ +# define __LDBL_REDIR2_DECL(name) \ + extern __typeof (__##name) __##name \ + __asm (__ASMNAME ("__" #name "ieee128")); + +/* Alias name defined manually. */ +# define __LDBL_REDIR1(name, proto, alias) ... unused__ldbl_redir1 +# define __LDBL_REDIR1_DECL(name, alias) \ + extern __typeof (name) name __asm (__ASMNAME (#alias)); + +# define __LDBL_REDIR1_NTH(name, proto, alias) \ + __REDIRECT_NTH (name, proto, alias) +# define __REDIRECT_NTH_LDBL(name, proto, alias) \ + __LDBL_REDIR1_NTH (name, proto, __##alias##ieee128) + +/* Unused. */ +# define __REDIRECT_LDBL(name, proto, alias) ... unused__redirect_ldbl +# define __LDBL_REDIR_NTH(name, proto) ... unused__ldbl_redir_nth + +# else +_Static_assert (0, "IEEE 128-bits long double requires redirection on this platform"); +# endif +#elif defined __LONG_DOUBLE_MATH_OPTIONAL && defined __NO_LONG_DOUBLE_MATH # define __LDBL_COMPAT 1 # ifdef __REDIRECT # define __LDBL_REDIR1(name, proto, alias) __REDIRECT (name, proto, alias) @@ -492,6 +529,8 @@ # define __LDBL_REDIR1_NTH(name, proto, alias) __REDIRECT_NTH (name, proto, alias) # define __LDBL_REDIR_NTH(name, proto) \ __LDBL_REDIR1_NTH (name, proto, __nldbl_##name) +# define __LDBL_REDIR2_DECL(name) \ + extern __typeof (__##name) __##name __asm (__ASMNAME ("__nldbl___" #name)); # define __LDBL_REDIR1_DECL(name, alias) \ extern __typeof (name) name __asm (__ASMNAME (#alias)); # define __LDBL_REDIR_DECL(name) \ @@ -502,11 +541,13 @@ __LDBL_REDIR1_NTH (name, proto, __nldbl_##alias) # endif #endif -#if !defined __LDBL_COMPAT || !defined __REDIRECT +#if (!defined __LDBL_COMPAT && __LDOUBLE_REDIRECTS_TO_FLOAT128_ABI == 0) \ + || !defined __REDIRECT # define __LDBL_REDIR1(name, proto, alias) name proto # define __LDBL_REDIR(name, proto) name proto # define __LDBL_REDIR1_NTH(name, proto, alias) name proto __THROW # define __LDBL_REDIR_NTH(name, proto) name proto __THROW +# define __LDBL_REDIR2_DECL(name) # define __LDBL_REDIR_DECL(name) # ifdef __REDIRECT # define __REDIRECT_LDBL(name, proto, alias) __REDIRECT (name, proto, alias) @@ -537,7 +578,7 @@ check is required to enable the use of generic selection. */ #if !defined __cplusplus \ && (__GNUC_PREREQ (4, 9) \ - || __glibc_clang_has_extension (c_generic_selections) \ + || __glibc_has_extension (c_generic_selections) \ || (!defined __GNUC__ && defined __STDC_VERSION__ \ && __STDC_VERSION__ >= 201112L)) # define __HAVE_GENERIC_SELECTION 1 @@ -545,4 +586,23 @@ # define __HAVE_GENERIC_SELECTION 0 #endif +#if __GNUC_PREREQ (10, 0) +/* Designates a 1-based positional argument ref-index of pointer type + that can be used to access size-index elements of the pointed-to + array according to access mode, or at least one element when + size-index is not provided: + access (access-mode, [, ]) */ +#define __attr_access(x) __attribute__ ((__access__ x)) +#else +# define __attr_access(x) +#endif + +/* Specify that a function such as setjmp or vfork may return + twice. */ +#if __GNUC_PREREQ (4, 1) +# define __attribute_returns_twice__ __attribute__ ((__returns_twice__)) +#else +# define __attribute_returns_twice__ /* Ignore. */ +#endif + #endif /* sys/cdefs.h */ diff --git a/lib/dirent.in.h b/lib/dirent.in.h index 2e2c5119a11..4666972b150 100644 --- a/lib/dirent.in.h +++ b/lib/dirent.in.h @@ -154,7 +154,8 @@ _GL_WARN_ON_USE (closedir, "closedir is not portable - " /* Return the file descriptor associated with the given directory stream, or -1 if none exists. */ # if @REPLACE_DIRFD@ -# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +/* On kLIBC, dirfd() is a macro that does not work. Undefine it. */ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) || defined dirfd # undef dirfd # define dirfd rpl_dirfd # endif diff --git a/lib/dynarray.h b/lib/dynarray.h new file mode 100644 index 00000000000..6da3e87e55f --- /dev/null +++ b/lib/dynarray.h @@ -0,0 +1,31 @@ +/* Type-safe arrays which grow dynamically. + Copyright 2021 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +/* Written by Paul Eggert, 2021. */ + +#ifndef _GL_DYNARRAY_H +#define _GL_DYNARRAY_H + +#include + +#define __libc_dynarray_at_failure gl_dynarray_at_failure +#define __libc_dynarray_emplace_enlarge gl_dynarray_emplace_enlarge +#define __libc_dynarray_finalize gl_dynarray_finalize +#define __libc_dynarray_resize_clear gl_dynarray_resize_clear +#define __libc_dynarray_resize gl_dynarray_resize +#include + +#endif /* _GL_DYNARRAY_H */ diff --git a/lib/fchmodat.c b/lib/fchmodat.c index d27c0d7734a..eb6e2242fdd 100644 --- a/lib/fchmodat.c +++ b/lib/fchmodat.c @@ -38,6 +38,7 @@ orig_fchmodat (int dir, char const *file, mode_t mode, int flags) #include #include #include +#include #include #ifdef __osf__ @@ -63,6 +64,22 @@ orig_fchmodat (int dir, char const *file, mode_t mode, int flags) int fchmodat (int dir, char const *file, mode_t mode, int flags) { +# if HAVE_NEARLY_WORKING_FCHMODAT + /* Correct the trailing slash handling. */ + size_t len = strlen (file); + if (len && file[len - 1] == '/') + { + struct stat st; + if (fstatat (dir, file, &st, flags & AT_SYMLINK_NOFOLLOW) < 0) + return -1; + if (!S_ISDIR (st.st_mode)) + { + errno = ENOTDIR; + return -1; + } + } +# endif + # if NEED_FCHMODAT_NONSYMLINK_FIX if (flags == AT_SYMLINK_NOFOLLOW) { diff --git a/lib/free.c b/lib/free.c index 135c3eb16bc..5c89787aba1 100644 --- a/lib/free.c +++ b/lib/free.c @@ -27,7 +27,21 @@ void rpl_free (void *p) #undef free { +#if defined __GNUC__ && !defined __clang__ + /* An invalid GCC optimization + + would optimize away the assignments in the code below, when link-time + optimization (LTO) is enabled. Make the code more complicated, so that + GCC does not grok how to optimize it. */ + int err[2]; + err[0] = errno; + err[1] = errno; + errno = 0; + free (p); + errno = err[errno == 0]; +#else int err = errno; free (p); errno = err; +#endif } diff --git a/lib/gnulib.mk.in b/lib/gnulib.mk.in index c457ac61209..07736f9b8bc 100644 --- a/lib/gnulib.mk.in +++ b/lib/gnulib.mk.in @@ -516,6 +516,7 @@ GNULIB_SYMLINK = @GNULIB_SYMLINK@ GNULIB_SYMLINKAT = @GNULIB_SYMLINKAT@ GNULIB_SYSTEM_POSIX = @GNULIB_SYSTEM_POSIX@ GNULIB_TIMEGM = @GNULIB_TIMEGM@ +GNULIB_TIMESPEC_GET = @GNULIB_TIMESPEC_GET@ GNULIB_TIME_R = @GNULIB_TIME_R@ GNULIB_TIME_RZ = @GNULIB_TIME_RZ@ GNULIB_TMPFILE = @GNULIB_TMPFILE@ @@ -746,6 +747,7 @@ HAVE_SYS_SELECT_H = @HAVE_SYS_SELECT_H@ HAVE_SYS_TIME_H = @HAVE_SYS_TIME_H@ HAVE_SYS_TYPES_H = @HAVE_SYS_TYPES_H@ HAVE_TIMEGM = @HAVE_TIMEGM@ +HAVE_TIMESPEC_GET = @HAVE_TIMESPEC_GET@ HAVE_TIMEZONE_T = @HAVE_TIMEZONE_T@ HAVE_TYPE_VOLATILE_SIG_ATOMIC_T = @HAVE_TYPE_VOLATILE_SIG_ATOMIC_T@ HAVE_UNISTD_H = @HAVE_UNISTD_H@ @@ -949,6 +951,7 @@ REPLACE_FCNTL = @REPLACE_FCNTL@ REPLACE_FDOPEN = @REPLACE_FDOPEN@ REPLACE_FDOPENDIR = @REPLACE_FDOPENDIR@ REPLACE_FFLUSH = @REPLACE_FFLUSH@ +REPLACE_FFSLL = @REPLACE_FFSLL@ REPLACE_FOPEN = @REPLACE_FOPEN@ REPLACE_FPRINTF = @REPLACE_FPRINTF@ REPLACE_FPURGE = @REPLACE_FPURGE@ @@ -989,7 +992,9 @@ REPLACE_MEMCHR = @REPLACE_MEMCHR@ REPLACE_MEMMEM = @REPLACE_MEMMEM@ REPLACE_MKDIR = @REPLACE_MKDIR@ REPLACE_MKFIFO = @REPLACE_MKFIFO@ +REPLACE_MKFIFOAT = @REPLACE_MKFIFOAT@ REPLACE_MKNOD = @REPLACE_MKNOD@ +REPLACE_MKNODAT = @REPLACE_MKNODAT@ REPLACE_MKSTEMP = @REPLACE_MKSTEMP@ REPLACE_MKTIME = @REPLACE_MKTIME@ REPLACE_NANOSLEEP = @REPLACE_NANOSLEEP@ @@ -1087,6 +1092,7 @@ SYSTEM_TYPE = @SYSTEM_TYPE@ SYS_TIME_H_DEFINES_STRUCT_TIMESPEC = @SYS_TIME_H_DEFINES_STRUCT_TIMESPEC@ TERMCAP_OBJ = @TERMCAP_OBJ@ TIME_H_DEFINES_STRUCT_TIMESPEC = @TIME_H_DEFINES_STRUCT_TIMESPEC@ +TIME_H_DEFINES_TIME_UTC = @TIME_H_DEFINES_TIME_UTC@ TOOLKIT_LIBW = @TOOLKIT_LIBW@ UINT32_MAX_LT_UINTMAX_MAX = @UINT32_MAX_LT_UINTMAX_MAX@ UINT64_MAX_EQ_ULONG_MAX = @UINT64_MAX_EQ_ULONG_MAX@ @@ -1171,6 +1177,7 @@ gl_GNULIB_ENABLED_a9786850e999ae65a836a6041e8e5ed1 = @gl_GNULIB_ENABLED_a9786850 gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36 = @gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36@ gl_GNULIB_ENABLED_cloexec = @gl_GNULIB_ENABLED_cloexec@ gl_GNULIB_ENABLED_dirfd = @gl_GNULIB_ENABLED_dirfd@ +gl_GNULIB_ENABLED_dynarray = @gl_GNULIB_ENABLED_dynarray@ gl_GNULIB_ENABLED_euidaccess = @gl_GNULIB_ENABLED_euidaccess@ gl_GNULIB_ENABLED_getdtablesize = @gl_GNULIB_ENABLED_getdtablesize@ gl_GNULIB_ENABLED_getgroups = @gl_GNULIB_ENABLED_getgroups@ @@ -1584,6 +1591,20 @@ EXTRA_libgnu_a_SOURCES += dup2.c endif ## end gnulib module dup2 +## begin gnulib module dynarray +ifeq (,$(OMIT_GNULIB_MODULE_dynarray)) + +ifneq (,$(gl_GNULIB_ENABLED_dynarray)) +libgnu_a_SOURCES += malloc/dynarray_at_failure.c malloc/dynarray_emplace_enlarge.c malloc/dynarray_finalize.c malloc/dynarray_resize.c malloc/dynarray_resize_clear.c + +endif +EXTRA_DIST += dynarray.h malloc/dynarray-skeleton.c malloc/dynarray.h + +EXTRA_libgnu_a_SOURCES += malloc/dynarray-skeleton.c + +endif +## end gnulib module dynarray + ## begin gnulib module eloop-threshold ifeq (,$(OMIT_GNULIB_MODULE_eloop-threshold)) @@ -3036,6 +3057,7 @@ string.h: string.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H -e 's|@''HAVE_SIGDESCR_NP''@|$(HAVE_SIGDESCR_NP)|g' \ -e 's|@''HAVE_DECL_STRSIGNAL''@|$(HAVE_DECL_STRSIGNAL)|g' \ -e 's|@''HAVE_STRVERSCMP''@|$(HAVE_STRVERSCMP)|g' \ + -e 's|@''REPLACE_FFSLL''@|$(REPLACE_FFSLL)|g' \ -e 's|@''REPLACE_MEMCHR''@|$(REPLACE_MEMCHR)|g' \ -e 's|@''REPLACE_MEMMEM''@|$(REPLACE_MEMMEM)|g' \ -e 's|@''REPLACE_STPNCPY''@|$(REPLACE_STPNCPY)|g' \ @@ -3237,7 +3259,9 @@ sys/stat.h: sys_stat.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNU -e 's|@''REPLACE_LSTAT''@|$(REPLACE_LSTAT)|g' \ -e 's|@''REPLACE_MKDIR''@|$(REPLACE_MKDIR)|g' \ -e 's|@''REPLACE_MKFIFO''@|$(REPLACE_MKFIFO)|g' \ + -e 's|@''REPLACE_MKFIFOAT''@|$(REPLACE_MKFIFOAT)|g' \ -e 's|@''REPLACE_MKNOD''@|$(REPLACE_MKNOD)|g' \ + -e 's|@''REPLACE_MKNODAT''@|$(REPLACE_MKNODAT)|g' \ -e 's|@''REPLACE_STAT''@|$(REPLACE_STAT)|g' \ -e 's|@''REPLACE_UTIMENSAT''@|$(REPLACE_UTIMENSAT)|g' \ -e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \ @@ -3350,6 +3374,7 @@ time.h: time.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $( -e 's/@''GNULIB_STRFTIME''@/$(GNULIB_STRFTIME)/g' \ -e 's/@''GNULIB_STRPTIME''@/$(GNULIB_STRPTIME)/g' \ -e 's/@''GNULIB_TIMEGM''@/$(GNULIB_TIMEGM)/g' \ + -e 's/@''GNULIB_TIMESPEC_GET''@/$(GNULIB_TIMESPEC_GET)/g' \ -e 's/@''GNULIB_TIME_R''@/$(GNULIB_TIME_R)/g' \ -e 's/@''GNULIB_TIME_RZ''@/$(GNULIB_TIME_RZ)/g' \ -e 's/@''GNULIB_TZSET''@/$(GNULIB_TZSET)/g' \ @@ -3358,6 +3383,7 @@ time.h: time.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $( -e 's|@''HAVE_NANOSLEEP''@|$(HAVE_NANOSLEEP)|g' \ -e 's|@''HAVE_STRPTIME''@|$(HAVE_STRPTIME)|g' \ -e 's|@''HAVE_TIMEGM''@|$(HAVE_TIMEGM)|g' \ + -e 's|@''HAVE_TIMESPEC_GET''@|$(HAVE_TIMESPEC_GET)|g' \ -e 's|@''HAVE_TIMEZONE_T''@|$(HAVE_TIMEZONE_T)|g' \ -e 's|@''REPLACE_CTIME''@|$(REPLACE_CTIME)|g' \ -e 's|@''REPLACE_GMTIME''@|$(REPLACE_GMTIME)|g' \ @@ -3372,6 +3398,7 @@ time.h: time.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $( -e 's|@''SYS_TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(SYS_TIME_H_DEFINES_STRUCT_TIMESPEC)|g' \ -e 's|@''TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(TIME_H_DEFINES_STRUCT_TIMESPEC)|g' \ -e 's|@''UNISTD_H_DEFINES_STRUCT_TIMESPEC''@|$(UNISTD_H_DEFINES_STRUCT_TIMESPEC)|g' \ + -e 's|@''TIME_H_DEFINES_TIME_UTC''@|$(TIME_H_DEFINES_TIME_UTC)|g' \ -e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \ -e '/definition of _GL_ARG_NONNULL/r $(ARG_NONNULL_H)' \ -e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)' \ diff --git a/lib/libc-config.h b/lib/libc-config.h index d4e29951f35..c0eac707cfd 100644 --- a/lib/libc-config.h +++ b/lib/libc-config.h @@ -71,107 +71,112 @@ # endif #endif - -/* Prepare to include , which is our copy of glibc - . */ +#ifndef __attribute_maybe_unused__ +/* either does not exist, or is too old for Gnulib. + Prepare to include , which is Gnulib's version of a + more-recent glibc . */ /* Define _FEATURES_H so that does not include . */ -#ifndef _FEATURES_H -# define _FEATURES_H 1 -#endif +# ifndef _FEATURES_H +# define _FEATURES_H 1 +# endif /* Define __WORDSIZE so that does not attempt to include nonexistent files. Make it a syntax error, since Gnulib does not use __WORDSIZE now, and if Gnulib uses it later the syntax error will let us know that __WORDSIZE needs configuring. */ -#ifndef __WORDSIZE -# define __WORDSIZE %%% -#endif +# ifndef __WORDSIZE +# define __WORDSIZE %%% +# endif /* Undef the macros unconditionally defined by our copy of glibc , so that they do not clash with any system-defined versions. */ -#undef _SYS_CDEFS_H -#undef __ASMNAME -#undef __ASMNAME2 -#undef __BEGIN_DECLS -#undef __CONCAT -#undef __END_DECLS -#undef __HAVE_GENERIC_SELECTION -#undef __LDBL_COMPAT -#undef __LDBL_REDIR -#undef __LDBL_REDIR1 -#undef __LDBL_REDIR1_DECL -#undef __LDBL_REDIR1_NTH -#undef __LDBL_REDIR_DECL -#undef __LDBL_REDIR_NTH -#undef __LEAF -#undef __LEAF_ATTR -#undef __NTH -#undef __NTHNL -#undef __P -#undef __PMT -#undef __REDIRECT -#undef __REDIRECT_LDBL -#undef __REDIRECT_NTH -#undef __REDIRECT_NTHNL -#undef __REDIRECT_NTH_LDBL -#undef __STRING -#undef __THROW -#undef __THROWNL -#undef __always_inline -#undef __attribute__ -#undef __attribute_alloc_size__ -#undef __attribute_artificial__ -#undef __attribute_const__ -#undef __attribute_deprecated__ -#undef __attribute_deprecated_msg__ -#undef __attribute_format_arg__ -#undef __attribute_format_strfmon__ -#undef __attribute_malloc__ -#undef __attribute_noinline__ -#undef __attribute_nonstring__ -#undef __attribute_pure__ -#undef __attribute_used__ -#undef __attribute_warn_unused_result__ -#undef __bos -#undef __bos0 -#undef __errordecl -#undef __extension__ -#undef __extern_always_inline -#undef __extern_inline -#undef __flexarr -#undef __fortify_function -#undef __glibc_c99_flexarr_available -#undef __glibc_clang_has_extension -#undef __glibc_likely -#undef __glibc_macro_warning -#undef __glibc_macro_warning1 -#undef __glibc_unlikely -#undef __inline -#undef __ptr_t -#undef __restrict -#undef __restrict_arr -#undef __va_arg_pack -#undef __va_arg_pack_len -#undef __warnattr -#undef __warndecl +# undef _SYS_CDEFS_H +# undef __ASMNAME +# undef __ASMNAME2 +# undef __BEGIN_DECLS +# undef __CONCAT +# undef __END_DECLS +# undef __HAVE_GENERIC_SELECTION +# undef __LDBL_COMPAT +# undef __LDBL_REDIR +# undef __LDBL_REDIR1 +# undef __LDBL_REDIR1_DECL +# undef __LDBL_REDIR1_NTH +# undef __LDBL_REDIR2_DECL +# undef __LDBL_REDIR_DECL +# undef __LDBL_REDIR_NTH +# undef __LEAF +# undef __LEAF_ATTR +# undef __NTH +# undef __NTHNL +# undef __REDIRECT +# undef __REDIRECT_LDBL +# undef __REDIRECT_NTH +# undef __REDIRECT_NTHNL +# undef __REDIRECT_NTH_LDBL +# undef __STRING +# undef __THROW +# undef __THROWNL +# undef __attr_access +# undef __attribute__ +# undef __attribute_alloc_size__ +# undef __attribute_artificial__ +# undef __attribute_const__ +# undef __attribute_deprecated__ +# undef __attribute_deprecated_msg__ +# undef __attribute_format_arg__ +# undef __attribute_format_strfmon__ +# undef __attribute_malloc__ +# undef __attribute_noinline__ +# undef __attribute_nonstring__ +# undef __attribute_pure__ +# undef __attribute_returns_twice__ +# undef __attribute_used__ +# undef __attribute_warn_unused_result__ +# undef __bos +# undef __bos0 +# undef __errordecl +# undef __extension__ +# undef __extern_always_inline +# undef __extern_inline +# undef __flexarr +# undef __fortify_function +# undef __glibc_c99_flexarr_available +# undef __glibc_has_attribute +# undef __glibc_has_builtin +# undef __glibc_has_extension +# undef __glibc_macro_warning +# undef __glibc_macro_warning1 +# undef __glibc_objsize +# undef __glibc_objsize0 +# undef __glibc_unlikely +# undef __inline +# undef __ptr_t +# undef __restrict +# undef __restrict_arr +# undef __va_arg_pack +# undef __va_arg_pack_len +# undef __warnattr /* Include our copy of glibc . */ -#include +# include /* __inline is too pessimistic for non-GCC. */ -#undef __inline -#ifndef HAVE___INLINE -# if 199901 <= __STDC_VERSION__ || defined inline -# define __inline inline -# else -# define __inline +# undef __inline +# ifndef HAVE___INLINE +# if 199901 <= __STDC_VERSION__ || defined inline +# define __inline inline +# else +# define __inline +# endif # endif -#endif + +#endif /* defined __glibc_likely */ /* A substitute for glibc , good enough for Gnulib. */ #define attribute_hidden -#define libc_hidden_proto(name, ...) +#define libc_hidden_proto(name) #define libc_hidden_def(name) #define libc_hidden_weak(name) #define libc_hidden_ver(local, name) diff --git a/lib/malloc/dynarray-skeleton.c b/lib/malloc/dynarray-skeleton.c new file mode 100644 index 00000000000..4995fd1c049 --- /dev/null +++ b/lib/malloc/dynarray-skeleton.c @@ -0,0 +1,525 @@ +/* Type-safe arrays which grow dynamically. + Copyright (C) 2017-2021 Free Software Foundation, Inc. + This file is part of the GNU C Library. + + The GNU C Library is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public + License as published by the Free Software Foundation; either + version 3 of the License, or (at your option) any later version. + + The GNU C Library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public + License along with the GNU C Library; if not, see + . */ + +/* Pre-processor macros which act as parameters: + + DYNARRAY_STRUCT + The struct tag of dynamic array to be defined. + DYNARRAY_ELEMENT + The type name of the element type. Elements are copied + as if by memcpy, and can change address as the dynamic + array grows. + DYNARRAY_PREFIX + The prefix of the functions which are defined. + + The following parameters are optional: + + DYNARRAY_ELEMENT_FREE + DYNARRAY_ELEMENT_FREE (E) is evaluated to deallocate the + contents of elements. E is of type DYNARRAY_ELEMENT *. + DYNARRAY_ELEMENT_INIT + DYNARRAY_ELEMENT_INIT (E) is evaluated to initialize a new + element. E is of type DYNARRAY_ELEMENT *. + If DYNARRAY_ELEMENT_FREE but not DYNARRAY_ELEMENT_INIT is + defined, new elements are automatically zero-initialized. + Otherwise, new elements have undefined contents. + DYNARRAY_INITIAL_SIZE + The size of the statically allocated array (default: + at least 2, more elements if they fit into 128 bytes). + Must be a preprocessor constant. If DYNARRAY_INITIAL_SIZE is 0, + there is no statically allocated array at, and all non-empty + arrays are heap-allocated. + DYNARRAY_FINAL_TYPE + The name of the type which holds the final array. If not + defined, is PREFIX##finalize not provided. DYNARRAY_FINAL_TYPE + must be a struct type, with members of type DYNARRAY_ELEMENT and + size_t at the start (in this order). + + These macros are undefined after this header file has been + included. + + The following types are provided (their members are private to the + dynarray implementation): + + struct DYNARRAY_STRUCT + + The following functions are provided: + + void DYNARRAY_PREFIX##init (struct DYNARRAY_STRUCT *); + void DYNARRAY_PREFIX##free (struct DYNARRAY_STRUCT *); + bool DYNARRAY_PREFIX##has_failed (const struct DYNARRAY_STRUCT *); + void DYNARRAY_PREFIX##mark_failed (struct DYNARRAY_STRUCT *); + size_t DYNARRAY_PREFIX##size (const struct DYNARRAY_STRUCT *); + DYNARRAY_ELEMENT *DYNARRAY_PREFIX##begin (const struct DYNARRAY_STRUCT *); + DYNARRAY_ELEMENT *DYNARRAY_PREFIX##end (const struct DYNARRAY_STRUCT *); + DYNARRAY_ELEMENT *DYNARRAY_PREFIX##at (struct DYNARRAY_STRUCT *, size_t); + void DYNARRAY_PREFIX##add (struct DYNARRAY_STRUCT *, DYNARRAY_ELEMENT); + DYNARRAY_ELEMENT *DYNARRAY_PREFIX##emplace (struct DYNARRAY_STRUCT *); + bool DYNARRAY_PREFIX##resize (struct DYNARRAY_STRUCT *, size_t); + void DYNARRAY_PREFIX##remove_last (struct DYNARRAY_STRUCT *); + void DYNARRAY_PREFIX##clear (struct DYNARRAY_STRUCT *); + + The following functions are provided are provided if the + prerequisites are met: + + bool DYNARRAY_PREFIX##finalize (struct DYNARRAY_STRUCT *, + DYNARRAY_FINAL_TYPE *); + (if DYNARRAY_FINAL_TYPE is defined) + DYNARRAY_ELEMENT *DYNARRAY_PREFIX##finalize (struct DYNARRAY_STRUCT *, + size_t *); + (if DYNARRAY_FINAL_TYPE is not defined) +*/ + +#include + +#include +#include +#include + +#ifndef DYNARRAY_STRUCT +# error "DYNARRAY_STRUCT must be defined" +#endif + +#ifndef DYNARRAY_ELEMENT +# error "DYNARRAY_ELEMENT must be defined" +#endif + +#ifndef DYNARRAY_PREFIX +# error "DYNARRAY_PREFIX must be defined" +#endif + +#ifdef DYNARRAY_INITIAL_SIZE +# if DYNARRAY_INITIAL_SIZE < 0 +# error "DYNARRAY_INITIAL_SIZE must be non-negative" +# endif +# if DYNARRAY_INITIAL_SIZE > 0 +# define DYNARRAY_HAVE_SCRATCH 1 +# else +# define DYNARRAY_HAVE_SCRATCH 0 +# endif +#else +/* Provide a reasonable default which limits the size of + DYNARRAY_STRUCT. */ +# define DYNARRAY_INITIAL_SIZE \ + (sizeof (DYNARRAY_ELEMENT) > 64 ? 2 : 128 / sizeof (DYNARRAY_ELEMENT)) +# define DYNARRAY_HAVE_SCRATCH 1 +#endif + +/* Public type definitions. */ + +/* All fields of this struct are private to the implementation. */ +struct DYNARRAY_STRUCT +{ + union + { + struct dynarray_header dynarray_abstract; + struct + { + /* These fields must match struct dynarray_header. */ + size_t used; + size_t allocated; + DYNARRAY_ELEMENT *array; + } dynarray_header; + } u; + +#if DYNARRAY_HAVE_SCRATCH + /* Initial inline allocation. */ + DYNARRAY_ELEMENT scratch[DYNARRAY_INITIAL_SIZE]; +#endif +}; + +/* Internal use only: Helper macros. */ + +/* Ensure macro-expansion of DYNARRAY_PREFIX. */ +#define DYNARRAY_CONCAT0(prefix, name) prefix##name +#define DYNARRAY_CONCAT1(prefix, name) DYNARRAY_CONCAT0(prefix, name) +#define DYNARRAY_NAME(name) DYNARRAY_CONCAT1(DYNARRAY_PREFIX, name) + +/* Use DYNARRAY_FREE instead of DYNARRAY_NAME (free), + so that Gnulib does not change 'free' to 'rpl_free'. */ +#define DYNARRAY_FREE DYNARRAY_CONCAT1 (DYNARRAY_NAME (f), ree) + +/* Address of the scratch buffer if any. */ +#if DYNARRAY_HAVE_SCRATCH +# define DYNARRAY_SCRATCH(list) (list)->scratch +#else +# define DYNARRAY_SCRATCH(list) NULL +#endif + +/* Internal use only: Helper functions. */ + +/* Internal function. Call DYNARRAY_ELEMENT_FREE with the array + elements. Name mangling needed due to the DYNARRAY_ELEMENT_FREE + macro expansion. */ +static inline void +DYNARRAY_NAME (free__elements__) (DYNARRAY_ELEMENT *__dynarray_array, + size_t __dynarray_used) +{ +#ifdef DYNARRAY_ELEMENT_FREE + for (size_t __dynarray_i = 0; __dynarray_i < __dynarray_used; ++__dynarray_i) + DYNARRAY_ELEMENT_FREE (&__dynarray_array[__dynarray_i]); +#endif /* DYNARRAY_ELEMENT_FREE */ +} + +/* Internal function. Free the non-scratch array allocation. */ +static inline void +DYNARRAY_NAME (free__array__) (struct DYNARRAY_STRUCT *list) +{ +#if DYNARRAY_HAVE_SCRATCH + if (list->u.dynarray_header.array != list->scratch) + free (list->u.dynarray_header.array); +#else + free (list->u.dynarray_header.array); +#endif +} + +/* Public functions. */ + +/* Initialize a dynamic array object. This must be called before any + use of the object. */ +__nonnull ((1)) +static void +DYNARRAY_NAME (init) (struct DYNARRAY_STRUCT *list) +{ + list->u.dynarray_header.used = 0; + list->u.dynarray_header.allocated = DYNARRAY_INITIAL_SIZE; + list->u.dynarray_header.array = DYNARRAY_SCRATCH (list); +} + +/* Deallocate the dynamic array and its elements. */ +__attribute_maybe_unused__ __nonnull ((1)) +static void +DYNARRAY_FREE (struct DYNARRAY_STRUCT *list) +{ + DYNARRAY_NAME (free__elements__) + (list->u.dynarray_header.array, list->u.dynarray_header.used); + DYNARRAY_NAME (free__array__) (list); + DYNARRAY_NAME (init) (list); +} + +/* Return true if the dynamic array is in an error state. */ +__nonnull ((1)) +static inline bool +DYNARRAY_NAME (has_failed) (const struct DYNARRAY_STRUCT *list) +{ + return list->u.dynarray_header.allocated == __dynarray_error_marker (); +} + +/* Mark the dynamic array as failed. All elements are deallocated as + a side effect. */ +__nonnull ((1)) +static void +DYNARRAY_NAME (mark_failed) (struct DYNARRAY_STRUCT *list) +{ + DYNARRAY_NAME (free__elements__) + (list->u.dynarray_header.array, list->u.dynarray_header.used); + DYNARRAY_NAME (free__array__) (list); + list->u.dynarray_header.array = DYNARRAY_SCRATCH (list); + list->u.dynarray_header.used = 0; + list->u.dynarray_header.allocated = __dynarray_error_marker (); +} + +/* Return the number of elements which have been added to the dynamic + array. */ +__nonnull ((1)) +static inline size_t +DYNARRAY_NAME (size) (const struct DYNARRAY_STRUCT *list) +{ + return list->u.dynarray_header.used; +} + +/* Return a pointer to the array element at INDEX. Terminate the + process if INDEX is out of bounds. */ +__nonnull ((1)) +static inline DYNARRAY_ELEMENT * +DYNARRAY_NAME (at) (struct DYNARRAY_STRUCT *list, size_t index) +{ + if (__glibc_unlikely (index >= DYNARRAY_NAME (size) (list))) + __libc_dynarray_at_failure (DYNARRAY_NAME (size) (list), index); + return list->u.dynarray_header.array + index; +} + +/* Return a pointer to the first array element, if any. For a + zero-length array, the pointer can be NULL even though the dynamic + array has not entered the failure state. */ +__nonnull ((1)) +static inline DYNARRAY_ELEMENT * +DYNARRAY_NAME (begin) (struct DYNARRAY_STRUCT *list) +{ + return list->u.dynarray_header.array; +} + +/* Return a pointer one element past the last array element. For a + zero-length array, the pointer can be NULL even though the dynamic + array has not entered the failure state. */ +__nonnull ((1)) +static inline DYNARRAY_ELEMENT * +DYNARRAY_NAME (end) (struct DYNARRAY_STRUCT *list) +{ + return list->u.dynarray_header.array + list->u.dynarray_header.used; +} + +/* Internal function. Slow path for the add function below. */ +static void +DYNARRAY_NAME (add__) (struct DYNARRAY_STRUCT *list, DYNARRAY_ELEMENT item) +{ + if (__glibc_unlikely + (!__libc_dynarray_emplace_enlarge (&list->u.dynarray_abstract, + DYNARRAY_SCRATCH (list), + sizeof (DYNARRAY_ELEMENT)))) + { + DYNARRAY_NAME (mark_failed) (list); + return; + } + + /* Copy the new element and increase the array length. */ + list->u.dynarray_header.array[list->u.dynarray_header.used++] = item; +} + +/* Add ITEM at the end of the array, enlarging it by one element. + Mark *LIST as failed if the dynamic array allocation size cannot be + increased. */ +__nonnull ((1)) +static inline void +DYNARRAY_NAME (add) (struct DYNARRAY_STRUCT *list, DYNARRAY_ELEMENT item) +{ + /* Do nothing in case of previous error. */ + if (DYNARRAY_NAME (has_failed) (list)) + return; + + /* Enlarge the array if necessary. */ + if (__glibc_unlikely (list->u.dynarray_header.used + == list->u.dynarray_header.allocated)) + { + DYNARRAY_NAME (add__) (list, item); + return; + } + + /* Copy the new element and increase the array length. */ + list->u.dynarray_header.array[list->u.dynarray_header.used++] = item; +} + +/* Internal function. Building block for the emplace functions below. + Assumes space for one more element in *LIST. */ +static inline DYNARRAY_ELEMENT * +DYNARRAY_NAME (emplace__tail__) (struct DYNARRAY_STRUCT *list) +{ + DYNARRAY_ELEMENT *result + = &list->u.dynarray_header.array[list->u.dynarray_header.used]; + ++list->u.dynarray_header.used; +#if defined (DYNARRAY_ELEMENT_INIT) + DYNARRAY_ELEMENT_INIT (result); +#elif defined (DYNARRAY_ELEMENT_FREE) + memset (result, 0, sizeof (*result)); +#endif + return result; +} + +/* Internal function. Slow path for the emplace function below. */ +static DYNARRAY_ELEMENT * +DYNARRAY_NAME (emplace__) (struct DYNARRAY_STRUCT *list) +{ + if (__glibc_unlikely + (!__libc_dynarray_emplace_enlarge (&list->u.dynarray_abstract, + DYNARRAY_SCRATCH (list), + sizeof (DYNARRAY_ELEMENT)))) + { + DYNARRAY_NAME (mark_failed) (list); + return NULL; + } + return DYNARRAY_NAME (emplace__tail__) (list); +} + +/* Allocate a place for a new element in *LIST and return a pointer to + it. The pointer can be NULL if the dynamic array cannot be + enlarged due to a memory allocation failure. */ +__attribute_maybe_unused__ __attribute_warn_unused_result__ __nonnull ((1)) +static +/* Avoid inlining with the larger initialization code. */ +#if !(defined (DYNARRAY_ELEMENT_INIT) || defined (DYNARRAY_ELEMENT_FREE)) +inline +#endif +DYNARRAY_ELEMENT * +DYNARRAY_NAME (emplace) (struct DYNARRAY_STRUCT *list) +{ + /* Do nothing in case of previous error. */ + if (DYNARRAY_NAME (has_failed) (list)) + return NULL; + + /* Enlarge the array if necessary. */ + if (__glibc_unlikely (list->u.dynarray_header.used + == list->u.dynarray_header.allocated)) + return (DYNARRAY_NAME (emplace__) (list)); + return DYNARRAY_NAME (emplace__tail__) (list); +} + +/* Change the size of *LIST to SIZE. If SIZE is larger than the + existing size, new elements are added (which can be initialized). + Otherwise, the list is truncated, and elements are freed. Return + false on memory allocation failure (and mark *LIST as failed). */ +__attribute_maybe_unused__ __nonnull ((1)) +static bool +DYNARRAY_NAME (resize) (struct DYNARRAY_STRUCT *list, size_t size) +{ + if (size > list->u.dynarray_header.used) + { + bool ok; +#if defined (DYNARRAY_ELEMENT_INIT) + /* The new elements have to be initialized. */ + size_t old_size = list->u.dynarray_header.used; + ok = __libc_dynarray_resize (&list->u.dynarray_abstract, + size, DYNARRAY_SCRATCH (list), + sizeof (DYNARRAY_ELEMENT)); + if (ok) + for (size_t i = old_size; i < size; ++i) + { + DYNARRAY_ELEMENT_INIT (&list->u.dynarray_header.array[i]); + } +#elif defined (DYNARRAY_ELEMENT_FREE) + /* Zero initialization is needed so that the elements can be + safely freed. */ + ok = __libc_dynarray_resize_clear + (&list->u.dynarray_abstract, size, + DYNARRAY_SCRATCH (list), sizeof (DYNARRAY_ELEMENT)); +#else + ok = __libc_dynarray_resize (&list->u.dynarray_abstract, + size, DYNARRAY_SCRATCH (list), + sizeof (DYNARRAY_ELEMENT)); +#endif + if (__glibc_unlikely (!ok)) + DYNARRAY_NAME (mark_failed) (list); + return ok; + } + else + { + /* The list has shrunk in size. Free the removed elements. */ + DYNARRAY_NAME (free__elements__) + (list->u.dynarray_header.array + size, + list->u.dynarray_header.used - size); + list->u.dynarray_header.used = size; + return true; + } +} + +/* Remove the last element of LIST if it is present. */ +__attribute_maybe_unused__ __nonnull ((1)) +static void +DYNARRAY_NAME (remove_last) (struct DYNARRAY_STRUCT *list) +{ + /* used > 0 implies that the array is the non-failed state. */ + if (list->u.dynarray_header.used > 0) + { + size_t new_length = list->u.dynarray_header.used - 1; +#ifdef DYNARRAY_ELEMENT_FREE + DYNARRAY_ELEMENT_FREE (&list->u.dynarray_header.array[new_length]); +#endif + list->u.dynarray_header.used = new_length; + } +} + +/* Remove all elements from the list. The elements are freed, but the + list itself is not. */ +__attribute_maybe_unused__ __nonnull ((1)) +static void +DYNARRAY_NAME (clear) (struct DYNARRAY_STRUCT *list) +{ + /* free__elements__ does nothing if the list is in the failed + state. */ + DYNARRAY_NAME (free__elements__) + (list->u.dynarray_header.array, list->u.dynarray_header.used); + list->u.dynarray_header.used = 0; +} + +#ifdef DYNARRAY_FINAL_TYPE +/* Transfer the dynamic array to a permanent location at *RESULT. + Returns true on success on false on allocation failure. In either + case, *LIST is re-initialized and can be reused. A NULL pointer is + stored in *RESULT if LIST refers to an empty list. On success, the + pointer in *RESULT is heap-allocated and must be deallocated using + free. */ +__attribute_maybe_unused__ __attribute_warn_unused_result__ __nonnull ((1, 2)) +static bool +DYNARRAY_NAME (finalize) (struct DYNARRAY_STRUCT *list, + DYNARRAY_FINAL_TYPE *result) +{ + struct dynarray_finalize_result res; + if (__libc_dynarray_finalize (&list->u.dynarray_abstract, + DYNARRAY_SCRATCH (list), + sizeof (DYNARRAY_ELEMENT), &res)) + { + /* On success, the result owns all the data. */ + DYNARRAY_NAME (init) (list); + *result = (DYNARRAY_FINAL_TYPE) { res.array, res.length }; + return true; + } + else + { + /* On error, we need to free all data. */ + DYNARRAY_FREE (list); + errno = ENOMEM; + return false; + } +} +#else /* !DYNARRAY_FINAL_TYPE */ +/* Transfer the dynamic array to a heap-allocated array and return a + pointer to it. The pointer is NULL if memory allocation fails, or + if the array is empty, so this function should be used only for + arrays which are known not be empty (usually because they always + have a sentinel at the end). If LENGTHP is not NULL, the array + length is written to *LENGTHP. *LIST is re-initialized and can be + reused. */ +__attribute_maybe_unused__ __attribute_warn_unused_result__ __nonnull ((1)) +static DYNARRAY_ELEMENT * +DYNARRAY_NAME (finalize) (struct DYNARRAY_STRUCT *list, size_t *lengthp) +{ + struct dynarray_finalize_result res; + if (__libc_dynarray_finalize (&list->u.dynarray_abstract, + DYNARRAY_SCRATCH (list), + sizeof (DYNARRAY_ELEMENT), &res)) + { + /* On success, the result owns all the data. */ + DYNARRAY_NAME (init) (list); + if (lengthp != NULL) + *lengthp = res.length; + return res.array; + } + else + { + /* On error, we need to free all data. */ + DYNARRAY_FREE (list); + errno = ENOMEM; + return NULL; + } +} +#endif /* !DYNARRAY_FINAL_TYPE */ + +/* Undo macro definitions. */ + +#undef DYNARRAY_CONCAT0 +#undef DYNARRAY_CONCAT1 +#undef DYNARRAY_NAME +#undef DYNARRAY_SCRATCH +#undef DYNARRAY_HAVE_SCRATCH + +#undef DYNARRAY_STRUCT +#undef DYNARRAY_ELEMENT +#undef DYNARRAY_PREFIX +#undef DYNARRAY_ELEMENT_FREE +#undef DYNARRAY_ELEMENT_INIT +#undef DYNARRAY_INITIAL_SIZE +#undef DYNARRAY_FINAL_TYPE diff --git a/lib/malloc/dynarray.h b/lib/malloc/dynarray.h new file mode 100644 index 00000000000..84e4394bf32 --- /dev/null +++ b/lib/malloc/dynarray.h @@ -0,0 +1,178 @@ +/* Type-safe arrays which grow dynamically. Shared definitions. + Copyright (C) 2017-2021 Free Software Foundation, Inc. + This file is part of the GNU C Library. + + The GNU C Library is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public + License as published by the Free Software Foundation; either + version 3 of the License, or (at your option) any later version. + + The GNU C Library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public + License along with the GNU C Library; if not, see + . */ + +/* To use the dynarray facility, you need to include + and define the parameter macros + documented in that file. + + A minimal example which provides a growing list of integers can be + defined like this: + + struct int_array + { + // Pointer to result array followed by its length, + // as required by DYNARRAY_FINAL_TYPE. + int *array; + size_t length; + }; + + #define DYNARRAY_STRUCT dynarray_int + #define DYNARRAY_ELEMENT int + #define DYNARRAY_PREFIX dynarray_int_ + #define DYNARRAY_FINAL_TYPE struct int_array + #include + + To create a three-element array with elements 1, 2, 3, use this + code: + + struct dynarray_int dyn; + dynarray_int_init (&dyn); + for (int i = 1; i <= 3; ++i) + { + int *place = dynarray_int_emplace (&dyn); + assert (place != NULL); + *place = i; + } + struct int_array result; + bool ok = dynarray_int_finalize (&dyn, &result); + assert (ok); + assert (result.length == 3); + assert (result.array[0] == 1); + assert (result.array[1] == 2); + assert (result.array[2] == 3); + free (result.array); + + If the elements contain resources which must be freed, define + DYNARRAY_ELEMENT_FREE appropriately, like this: + + struct str_array + { + char **array; + size_t length; + }; + + #define DYNARRAY_STRUCT dynarray_str + #define DYNARRAY_ELEMENT char * + #define DYNARRAY_ELEMENT_FREE(ptr) free (*ptr) + #define DYNARRAY_PREFIX dynarray_str_ + #define DYNARRAY_FINAL_TYPE struct str_array + #include + + Compared to scratch buffers, dynamic arrays have the following + features: + + - They have an element type, and are not just an untyped buffer of + bytes. + + - When growing, previously stored elements are preserved. (It is + expected that scratch_buffer_grow_preserve and + scratch_buffer_set_array_size eventually go away because all + current users are moved to dynamic arrays.) + + - Scratch buffers have a more aggressive growth policy because + growing them typically means a retry of an operation (across an + NSS service module boundary), which is expensive. + + - For the same reason, scratch buffers have a much larger initial + stack allocation. */ + +#ifndef _DYNARRAY_H +#define _DYNARRAY_H + +#include +#include +#include + +struct dynarray_header +{ + size_t used; + size_t allocated; + void *array; +}; + +/* Marker used in the allocated member to indicate that an error was + encountered. */ +static inline size_t +__dynarray_error_marker (void) +{ + return -1; +} + +/* Internal function. See the has_failed function in + dynarray-skeleton.c. */ +static inline bool +__dynarray_error (struct dynarray_header *list) +{ + return list->allocated == __dynarray_error_marker (); +} + +/* Internal function. Enlarge the dynamically allocated area of the + array to make room for one more element. SCRATCH is a pointer to + the scratch area (which is not heap-allocated and must not be + freed). ELEMENT_SIZE is the size, in bytes, of one element. + Return false on failure, true on success. */ +bool __libc_dynarray_emplace_enlarge (struct dynarray_header *, + void *scratch, size_t element_size); + +/* Internal function. Enlarge the dynamically allocated area of the + array to make room for at least SIZE elements (which must be larger + than the existing used part of the dynamic array). SCRATCH is a + pointer to the scratch area (which is not heap-allocated and must + not be freed). ELEMENT_SIZE is the size, in bytes, of one element. + Return false on failure, true on success. */ +bool __libc_dynarray_resize (struct dynarray_header *, size_t size, + void *scratch, size_t element_size); + +/* Internal function. Like __libc_dynarray_resize, but clear the new + part of the dynamic array. */ +bool __libc_dynarray_resize_clear (struct dynarray_header *, size_t size, + void *scratch, size_t element_size); + +/* Internal type. */ +struct dynarray_finalize_result +{ + void *array; + size_t length; +}; + +/* Internal function. Copy the dynamically-allocated area to an + explicitly-sized heap allocation. SCRATCH is a pointer to the + embedded scratch space. ELEMENT_SIZE is the size, in bytes, of the + element type. On success, true is returned, and pointer and length + are written to *RESULT. On failure, false is returned. The caller + has to take care of some of the memory management; this function is + expected to be called from dynarray-skeleton.c. */ +bool __libc_dynarray_finalize (struct dynarray_header *list, void *scratch, + size_t element_size, + struct dynarray_finalize_result *result); + + +/* Internal function. Terminate the process after an index error. + SIZE is the number of elements of the dynamic array. INDEX is the + lookup index which triggered the failure. */ +_Noreturn void __libc_dynarray_at_failure (size_t size, size_t index); + +#ifndef _ISOMAC +libc_hidden_proto (__libc_dynarray_emplace_enlarge) +libc_hidden_proto (__libc_dynarray_resize) +libc_hidden_proto (__libc_dynarray_resize_clear) +libc_hidden_proto (__libc_dynarray_finalize) +libc_hidden_proto (__libc_dynarray_at_failure) +#endif + +#endif /* _DYNARRAY_H */ diff --git a/lib/malloc/dynarray_at_failure.c b/lib/malloc/dynarray_at_failure.c new file mode 100644 index 00000000000..a4424593748 --- /dev/null +++ b/lib/malloc/dynarray_at_failure.c @@ -0,0 +1,35 @@ +/* Report an dynamic array index out of bounds condition. + Copyright (C) 2017-2021 Free Software Foundation, Inc. + This file is part of the GNU C Library. + + The GNU C Library is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public + License as published by the Free Software Foundation; either + version 3 of the License, or (at your option) any later version. + + The GNU C Library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public + License along with the GNU C Library; if not, see + . */ + +#include +#include +#include + +void +__libc_dynarray_at_failure (size_t size, size_t index) +{ +#ifdef _LIBC + char buf[200]; + __snprintf (buf, sizeof (buf), "Fatal glibc error: " + "array index %zu not less than array length %zu\n", + index, size); +#else + abort (); +#endif +} +libc_hidden_def (__libc_dynarray_at_failure) diff --git a/lib/malloc/dynarray_emplace_enlarge.c b/lib/malloc/dynarray_emplace_enlarge.c new file mode 100644 index 00000000000..7ac4b6db403 --- /dev/null +++ b/lib/malloc/dynarray_emplace_enlarge.c @@ -0,0 +1,73 @@ +/* Increase the size of a dynamic array in preparation of an emplace operation. + Copyright (C) 2017-2021 Free Software Foundation, Inc. + This file is part of the GNU C Library. + + The GNU C Library is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public + License as published by the Free Software Foundation; either + version 3 of the License, or (at your option) any later version. + + The GNU C Library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public + License along with the GNU C Library; if not, see + . */ + +#include +#include +#include +#include +#include + +bool +__libc_dynarray_emplace_enlarge (struct dynarray_header *list, + void *scratch, size_t element_size) +{ + size_t new_allocated; + if (list->allocated == 0) + { + /* No scratch buffer provided. Choose a reasonable default + size. */ + if (element_size < 4) + new_allocated = 16; + else if (element_size < 8) + new_allocated = 8; + else + new_allocated = 4; + } + else + /* Increase the allocated size, using an exponential growth + policy. */ + { + new_allocated = list->allocated + list->allocated / 2 + 1; + if (new_allocated <= list->allocated) + { + /* Overflow. */ + __set_errno (ENOMEM); + return false; + } + } + + size_t new_size; + if (INT_MULTIPLY_WRAPV (new_allocated, element_size, &new_size)) + return false; + void *new_array; + if (list->array == scratch) + { + /* The previous array was not heap-allocated. */ + new_array = malloc (new_size); + if (new_array != NULL && list->array != NULL) + memcpy (new_array, list->array, list->used * element_size); + } + else + new_array = realloc (list->array, new_size); + if (new_array == NULL) + return false; + list->array = new_array; + list->allocated = new_allocated; + return true; +} +libc_hidden_def (__libc_dynarray_emplace_enlarge) diff --git a/lib/malloc/dynarray_finalize.c b/lib/malloc/dynarray_finalize.c new file mode 100644 index 00000000000..be9441e313d --- /dev/null +++ b/lib/malloc/dynarray_finalize.c @@ -0,0 +1,62 @@ +/* Copy the dynamically-allocated area to an explicitly-sized heap allocation. + Copyright (C) 2017-2021 Free Software Foundation, Inc. + This file is part of the GNU C Library. + + The GNU C Library is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public + License as published by the Free Software Foundation; either + version 3 of the License, or (at your option) any later version. + + The GNU C Library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public + License along with the GNU C Library; if not, see + . */ + +#include +#include +#include + +bool +__libc_dynarray_finalize (struct dynarray_header *list, + void *scratch, size_t element_size, + struct dynarray_finalize_result *result) +{ + if (__dynarray_error (list)) + /* The caller will reported the deferred error. */ + return false; + + size_t used = list->used; + + /* Empty list. */ + if (used == 0) + { + /* An empty list could still be backed by a heap-allocated + array. Free it if necessary. */ + if (list->array != scratch) + free (list->array); + *result = (struct dynarray_finalize_result) { NULL, 0 }; + return true; + } + + size_t allocation_size = used * element_size; + void *heap_array = malloc (allocation_size); + if (heap_array != NULL) + { + /* The new array takes ownership of the strings. */ + if (list->array != NULL) + memcpy (heap_array, list->array, allocation_size); + if (list->array != scratch) + free (list->array); + *result = (struct dynarray_finalize_result) + { .array = heap_array, .length = used }; + return true; + } + else + /* The caller will perform the freeing operation. */ + return false; +} +libc_hidden_def (__libc_dynarray_finalize) diff --git a/lib/malloc/dynarray_resize.c b/lib/malloc/dynarray_resize.c new file mode 100644 index 00000000000..92bbddd4461 --- /dev/null +++ b/lib/malloc/dynarray_resize.c @@ -0,0 +1,64 @@ +/* Increase the size of a dynamic array. + Copyright (C) 2017-2021 Free Software Foundation, Inc. + This file is part of the GNU C Library. + + The GNU C Library is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public + License as published by the Free Software Foundation; either + version 3 of the License, or (at your option) any later version. + + The GNU C Library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public + License along with the GNU C Library; if not, see + . */ + +#include +#include +#include +#include +#include + +bool +__libc_dynarray_resize (struct dynarray_header *list, size_t size, + void *scratch, size_t element_size) +{ + /* The existing allocation provides sufficient room. */ + if (size <= list->allocated) + { + list->used = size; + return true; + } + + /* Otherwise, use size as the new allocation size. The caller is + expected to provide the final size of the array, so there is no + over-allocation here. */ + + size_t new_size_bytes; + if (INT_MULTIPLY_WRAPV (size, element_size, &new_size_bytes)) + { + /* Overflow. */ + __set_errno (ENOMEM); + return false; + } + void *new_array; + if (list->array == scratch) + { + /* The previous array was not heap-allocated. */ + new_array = malloc (new_size_bytes); + if (new_array != NULL && list->array != NULL) + memcpy (new_array, list->array, list->used * element_size); + } + else + new_array = realloc (list->array, new_size_bytes); + if (new_array == NULL) + return false; + list->array = new_array; + list->allocated = size; + list->used = size; + return true; +} +libc_hidden_def (__libc_dynarray_resize) diff --git a/lib/malloc/dynarray_resize_clear.c b/lib/malloc/dynarray_resize_clear.c new file mode 100644 index 00000000000..99c2cc87c31 --- /dev/null +++ b/lib/malloc/dynarray_resize_clear.c @@ -0,0 +1,35 @@ +/* Increase the size of a dynamic array and clear the new part. + Copyright (C) 2017-2021 Free Software Foundation, Inc. + This file is part of the GNU C Library. + + The GNU C Library is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public + License as published by the Free Software Foundation; either + version 3 of the License, or (at your option) any later version. + + The GNU C Library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public + License along with the GNU C Library; if not, see + . */ + +#include +#include + +bool +__libc_dynarray_resize_clear (struct dynarray_header *list, size_t size, + void *scratch, size_t element_size) +{ + size_t old_size = list->used; + if (!__libc_dynarray_resize (list, size, scratch, element_size)) + return false; + /* __libc_dynarray_resize already checked for overflow. */ + char *array = list->array; + memset (array + (old_size * element_size), 0, + (size - old_size) * element_size); + return true; +} +libc_hidden_def (__libc_dynarray_resize_clear) diff --git a/lib/malloc/scratch_buffer_grow.c b/lib/malloc/scratch_buffer_grow.c index 41befe3d65f..e7606d81cd7 100644 --- a/lib/malloc/scratch_buffer_grow.c +++ b/lib/malloc/scratch_buffer_grow.c @@ -1,5 +1,5 @@ /* Variable-sized buffer with on-stack default allocation. - Copyright (C) 2015-2020 Free Software Foundation, Inc. + Copyright (C) 2015-2021 Free Software Foundation, Inc. This file is part of the GNU C Library. The GNU C Library is free software; you can redistribute it and/or diff --git a/lib/malloc/scratch_buffer_grow_preserve.c b/lib/malloc/scratch_buffer_grow_preserve.c index aef232938d5..59f8c710001 100644 --- a/lib/malloc/scratch_buffer_grow_preserve.c +++ b/lib/malloc/scratch_buffer_grow_preserve.c @@ -1,5 +1,5 @@ /* Variable-sized buffer with on-stack default allocation. - Copyright (C) 2015-2020 Free Software Foundation, Inc. + Copyright (C) 2015-2021 Free Software Foundation, Inc. This file is part of the GNU C Library. The GNU C Library is free software; you can redistribute it and/or diff --git a/lib/malloc/scratch_buffer_set_array_size.c b/lib/malloc/scratch_buffer_set_array_size.c index 5f5e4c24f5a..e2b9f31211a 100644 --- a/lib/malloc/scratch_buffer_set_array_size.c +++ b/lib/malloc/scratch_buffer_set_array_size.c @@ -1,5 +1,5 @@ /* Variable-sized buffer with on-stack default allocation. - Copyright (C) 2015-2020 Free Software Foundation, Inc. + Copyright (C) 2015-2021 Free Software Foundation, Inc. This file is part of the GNU C Library. The GNU C Library is free software; you can redistribute it and/or diff --git a/lib/mini-gmp.c b/lib/mini-gmp.c index d34fe525e4c..de061e673ac 100644 --- a/lib/mini-gmp.c +++ b/lib/mini-gmp.c @@ -4521,7 +4521,7 @@ mpz_export (void *r, size_t *countp, int order, size_t size, int endian, mp_size_t un; if (nails != 0) - gmp_die ("mpz_import: Nails not supported."); + gmp_die ("mpz_export: Nails not supported."); assert (order == 1 || order == -1); assert (endian >= -1 && endian <= 1); diff --git a/lib/mktime-internal.h b/lib/mktime-internal.h index b765a37ee34..9c447bd7b05 100644 --- a/lib/mktime-internal.h +++ b/lib/mktime-internal.h @@ -1,5 +1,5 @@ /* Internals of mktime and related functions - Copyright 2016-2020 Free Software Foundation, Inc. + Copyright 2016-2021 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Paul Eggert . diff --git a/lib/nstrftime.c b/lib/nstrftime.c index 8ba6975552b..2f5e4fbe639 100644 --- a/lib/nstrftime.c +++ b/lib/nstrftime.c @@ -19,7 +19,7 @@ # define USE_IN_EXTENDED_LOCALE_MODEL 1 # define HAVE_STRUCT_ERA_ENTRY 1 # define HAVE_TM_GMTOFF 1 -# define HAVE_TM_ZONE 1 +# define HAVE_STRUCT_TM_TM_ZONE 1 # define HAVE_TZNAME 1 # include "../locale/localeinfo.h" #else @@ -499,7 +499,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize) #endif zone = NULL; -#if HAVE_TM_ZONE +#if HAVE_STRUCT_TM_TM_ZONE /* The POSIX test suite assumes that setting the environment variable TZ to a new value before calling strftime() will influence the result (the %Z format) even if the information in @@ -516,7 +516,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize) } else { -# if !HAVE_TM_ZONE +# if !HAVE_STRUCT_TM_TM_ZONE /* Infer the zone name from *TZ instead of from TZNAME. */ tzname_vec = tz->tzname_copy; # endif diff --git a/lib/regex.c b/lib/regex.c index 88173bb1052..f76a416b3b5 100644 --- a/lib/regex.c +++ b/lib/regex.c @@ -1,5 +1,5 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2020 Free Software Foundation, Inc. + Copyright (C) 2002-2021 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa . diff --git a/lib/regex_internal.h b/lib/regex_internal.h index be2fa4fe78e..4c634edcbfa 100644 --- a/lib/regex_internal.h +++ b/lib/regex_internal.h @@ -32,6 +32,7 @@ #include #include +#include #include #include @@ -444,25 +445,6 @@ typedef struct re_dfa_t re_dfa_t; #define re_string_skip_bytes(pstr,idx) ((pstr)->cur_idx += (idx)) #define re_string_set_index(pstr,idx) ((pstr)->cur_idx = (idx)) -#if defined _LIBC || HAVE_ALLOCA -# include -#endif - -#ifndef _LIBC -# if HAVE_ALLOCA -/* The OS usually guarantees only one guard page at the bottom of the stack, - and a page size can be as small as 4096 bytes. So we cannot safely - allocate anything larger than 4096 bytes. Also care for the possibility - of a few compiler-allocated temporary stack slots. */ -# define __libc_use_alloca(n) ((n) < 4032) -# else -/* alloca is implemented with malloc, so just use malloc. */ -# define __libc_use_alloca(n) 0 -# undef alloca -# define alloca(n) malloc (n) -# endif -#endif - #ifdef _LIBC # define MALLOC_0_IS_NONNULL 1 #elif !defined MALLOC_0_IS_NONNULL @@ -848,12 +830,14 @@ re_string_elem_size_at (const re_string_t *pstr, Idx idx) } #endif /* RE_ENABLE_I18N */ -#ifndef FALLTHROUGH -# if (__GNUC__ >= 7) || (__clang_major__ >= 10) +#ifdef _LIBC +# if __GNUC__ >= 7 # define FALLTHROUGH __attribute__ ((__fallthrough__)) # else # define FALLTHROUGH ((void) 0) # endif +#else +# include "attribute.h" #endif #endif /* _REGEX_INTERNAL_H */ diff --git a/lib/regexec.c b/lib/regexec.c index 395e37db591..15dc57bd0e6 100644 --- a/lib/regexec.c +++ b/lib/regexec.c @@ -1,5 +1,5 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2020 Free Software Foundation, Inc. + Copyright (C) 2002-2021 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa . @@ -1355,6 +1355,12 @@ pop_fail_stack (struct re_fail_stack_t *fs, Idx *pidx, Idx nregs, return fs->stack[num].node; } + +#define DYNARRAY_STRUCT regmatch_list +#define DYNARRAY_ELEMENT regmatch_t +#define DYNARRAY_PREFIX regmatch_list_ +#include + /* Set the positions where the subexpressions are starts/ends to registers PMATCH. Note: We assume that pmatch[0] is already set, and @@ -1370,8 +1376,8 @@ set_regs (const regex_t *preg, const re_match_context_t *mctx, size_t nmatch, re_node_set eps_via_nodes; struct re_fail_stack_t *fs; struct re_fail_stack_t fs_body = { 0, 2, NULL }; - regmatch_t *prev_idx_match; - bool prev_idx_match_malloced = false; + struct regmatch_list prev_match; + regmatch_list_init (&prev_match); DEBUG_ASSERT (nmatch > 1); DEBUG_ASSERT (mctx->state_log != NULL); @@ -1388,18 +1394,13 @@ set_regs (const regex_t *preg, const re_match_context_t *mctx, size_t nmatch, cur_node = dfa->init_node; re_node_set_init_empty (&eps_via_nodes); - if (__libc_use_alloca (nmatch * sizeof (regmatch_t))) - prev_idx_match = (regmatch_t *) alloca (nmatch * sizeof (regmatch_t)); - else + if (!regmatch_list_resize (&prev_match, nmatch)) { - prev_idx_match = re_malloc (regmatch_t, nmatch); - if (prev_idx_match == NULL) - { - free_fail_stack_return (fs); - return REG_ESPACE; - } - prev_idx_match_malloced = true; + regmatch_list_free (&prev_match); + free_fail_stack_return (fs); + return REG_ESPACE; } + regmatch_t *prev_idx_match = regmatch_list_begin (&prev_match); memcpy (prev_idx_match, pmatch, sizeof (regmatch_t) * nmatch); for (idx = pmatch[0].rm_so; idx <= pmatch[0].rm_eo ;) @@ -1417,8 +1418,7 @@ set_regs (const regex_t *preg, const re_match_context_t *mctx, size_t nmatch, if (reg_idx == nmatch) { re_node_set_free (&eps_via_nodes); - if (prev_idx_match_malloced) - re_free (prev_idx_match); + regmatch_list_free (&prev_match); return free_fail_stack_return (fs); } cur_node = pop_fail_stack (fs, &idx, nmatch, pmatch, @@ -1427,8 +1427,7 @@ set_regs (const regex_t *preg, const re_match_context_t *mctx, size_t nmatch, else { re_node_set_free (&eps_via_nodes); - if (prev_idx_match_malloced) - re_free (prev_idx_match); + regmatch_list_free (&prev_match); return REG_NOERROR; } } @@ -1442,8 +1441,7 @@ set_regs (const regex_t *preg, const re_match_context_t *mctx, size_t nmatch, if (__glibc_unlikely (cur_node == -2)) { re_node_set_free (&eps_via_nodes); - if (prev_idx_match_malloced) - re_free (prev_idx_match); + regmatch_list_free (&prev_match); free_fail_stack_return (fs); return REG_ESPACE; } @@ -1453,15 +1451,13 @@ set_regs (const regex_t *preg, const re_match_context_t *mctx, size_t nmatch, else { re_node_set_free (&eps_via_nodes); - if (prev_idx_match_malloced) - re_free (prev_idx_match); + regmatch_list_free (&prev_match); return REG_NOMATCH; } } } re_node_set_free (&eps_via_nodes); - if (prev_idx_match_malloced) - re_free (prev_idx_match); + regmatch_list_free (&prev_match); return free_fail_stack_return (fs); } @@ -3251,7 +3247,7 @@ expand_bkref_cache (re_match_context_t *mctx, re_node_set *cur_nodes, /* Build transition table for the state. Return true if successful. */ -static bool +static bool __attribute_noinline__ build_trtable (const re_dfa_t *dfa, re_dfastate_t *state) { reg_errcode_t err; @@ -3259,36 +3255,20 @@ build_trtable (const re_dfa_t *dfa, re_dfastate_t *state) int ch; bool need_word_trtable = false; bitset_word_t elem, mask; - bool dests_node_malloced = false; - bool dest_states_malloced = false; Idx ndests; /* Number of the destination states from 'state'. */ re_dfastate_t **trtable; - re_dfastate_t **dest_states = NULL, **dest_states_word, **dest_states_nl; - re_node_set follows, *dests_node; - bitset_t *dests_ch; + re_dfastate_t *dest_states[SBC_MAX]; + re_dfastate_t *dest_states_word[SBC_MAX]; + re_dfastate_t *dest_states_nl[SBC_MAX]; + re_node_set follows; bitset_t acceptable; - struct dests_alloc - { - re_node_set dests_node[SBC_MAX]; - bitset_t dests_ch[SBC_MAX]; - } *dests_alloc; - /* We build DFA states which corresponds to the destination nodes from 'state'. 'dests_node[i]' represents the nodes which i-th destination state contains, and 'dests_ch[i]' represents the characters which i-th destination state accepts. */ - if (__libc_use_alloca (sizeof (struct dests_alloc))) - dests_alloc = (struct dests_alloc *) alloca (sizeof (struct dests_alloc)); - else - { - dests_alloc = re_malloc (struct dests_alloc, 1); - if (__glibc_unlikely (dests_alloc == NULL)) - return false; - dests_node_malloced = true; - } - dests_node = dests_alloc->dests_node; - dests_ch = dests_alloc->dests_ch; + re_node_set dests_node[SBC_MAX]; + bitset_t dests_ch[SBC_MAX]; /* Initialize transition table. */ state->word_trtable = state->trtable = NULL; @@ -3298,8 +3278,6 @@ build_trtable (const re_dfa_t *dfa, re_dfastate_t *state) ndests = group_nodes_into_DFAstates (dfa, state, dests_node, dests_ch); if (__glibc_unlikely (ndests <= 0)) { - if (dests_node_malloced) - re_free (dests_alloc); /* Return false in case of an error, true otherwise. */ if (ndests == 0) { @@ -3314,38 +3292,14 @@ build_trtable (const re_dfa_t *dfa, re_dfastate_t *state) err = re_node_set_alloc (&follows, ndests + 1); if (__glibc_unlikely (err != REG_NOERROR)) - goto out_free; - - /* Avoid arithmetic overflow in size calculation. */ - size_t ndests_max - = ((SIZE_MAX - (sizeof (re_node_set) + sizeof (bitset_t)) * SBC_MAX) - / (3 * sizeof (re_dfastate_t *))); - if (__glibc_unlikely (ndests_max < ndests)) - goto out_free; - - if (__libc_use_alloca ((sizeof (re_node_set) + sizeof (bitset_t)) * SBC_MAX - + ndests * 3 * sizeof (re_dfastate_t *))) - dest_states = (re_dfastate_t **) - alloca (ndests * 3 * sizeof (re_dfastate_t *)); - else { - dest_states = re_malloc (re_dfastate_t *, ndests * 3); - if (__glibc_unlikely (dest_states == NULL)) - { -out_free: - if (dest_states_malloced) - re_free (dest_states); - re_node_set_free (&follows); - for (i = 0; i < ndests; ++i) - re_node_set_free (dests_node + i); - if (dests_node_malloced) - re_free (dests_alloc); - return false; - } - dest_states_malloced = true; + out_free: + re_node_set_free (&follows); + for (i = 0; i < ndests; ++i) + re_node_set_free (dests_node + i); + return false; } - dest_states_word = dest_states + ndests; - dest_states_nl = dest_states_word + ndests; + bitset_empty (acceptable); /* Then build the states for all destinations. */ @@ -3470,16 +3424,9 @@ build_trtable (const re_dfa_t *dfa, re_dfastate_t *state) } } - if (dest_states_malloced) - re_free (dest_states); - re_node_set_free (&follows); for (i = 0; i < ndests; ++i) re_node_set_free (dests_node + i); - - if (dests_node_malloced) - re_free (dests_alloc); - return true; } diff --git a/lib/scratch_buffer.h b/lib/scratch_buffer.h index 3e2b5ef27db..603b0d65d0a 100644 --- a/lib/scratch_buffer.h +++ b/lib/scratch_buffer.h @@ -21,6 +21,7 @@ #include +#define __libc_scratch_buffer_dupfree gl_scratch_buffer_dupfree #define __libc_scratch_buffer_grow gl_scratch_buffer_grow #define __libc_scratch_buffer_grow_preserve gl_scratch_buffer_grow_preserve #define __libc_scratch_buffer_set_array_size gl_scratch_buffer_set_array_size diff --git a/lib/stddef.in.h b/lib/stddef.in.h index ba7195a9102..0f506a5b18b 100644 --- a/lib/stddef.in.h +++ b/lib/stddef.in.h @@ -49,6 +49,23 @@ # ifndef _@GUARD_PREFIX@_STDDEF_H +/* On AIX 7.2, with xlc in 64-bit mode, defines max_align_t to a + type with alignment 4, but 'long' has alignment 8. */ +# if defined _AIX && defined _ARCH_PPC64 +# if !GNULIB_defined_max_align_t +# ifdef _MAX_ALIGN_T +/* /usr/include/stddef.h has already defined max_align_t. Override it. */ +typedef long rpl_max_align_t; +# define max_align_t rpl_max_align_t +# else +/* Prevent /usr/include/stddef.h from defining max_align_t. */ +typedef long max_align_t; +# define _MAX_ALIGN_T +# endif +# define GNULIB_defined_max_align_t 1 +# endif +# endif + /* The include_next requires a split double-inclusion guard. */ # @INCLUDE_NEXT@ @NEXT_STDDEF_H@ @@ -86,8 +103,10 @@ we are currently compiling with gcc. On MSVC, max_align_t is defined only in C++ mode, after was included. Its definition is good since it has an alignment of 8 (on x86 - and x86_64). */ -#if defined _MSC_VER && defined __cplusplus + and x86_64). + Similarly on OS/2 kLIBC. */ +#if (defined _MSC_VER || (defined __KLIBC__ && !defined __LIBCN__)) \ + && defined __cplusplus # include #else # if ! (@HAVE_MAX_ALIGN_T@ || defined _GCC_MAX_ALIGN_T) diff --git a/lib/string.in.h b/lib/string.in.h index 9f68e77c767..c76c1820b36 100644 --- a/lib/string.in.h +++ b/lib/string.in.h @@ -69,6 +69,14 @@ # include #endif +/* AIX 7.2 declares ffsl and ffsll in , not in . */ +/* But in any case avoid namespace pollution on glibc systems. */ +#if ((@GNULIB_FFSL@ || @GNULIB_FFSLL@ || defined GNULIB_POSIXCHECK) \ + && defined _AIX) \ + && ! defined __GLIBC__ +# include +#endif + /* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */ /* The definition of _GL_ARG_NONNULL is copied here. */ @@ -110,10 +118,18 @@ _GL_WARN_ON_USE (ffsl, "ffsl is not portable - use the ffsl module"); /* Find the index of the least-significant set bit. */ #if @GNULIB_FFSLL@ -# if !@HAVE_FFSLL@ +# if @REPLACE_FFSLL@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# define ffsll rpl_ffsll +# endif +_GL_FUNCDECL_RPL (ffsll, int, (long long int i)); +_GL_CXXALIAS_RPL (ffsll, int, (long long int i)); +# else +# if !@HAVE_FFSLL@ _GL_FUNCDECL_SYS (ffsll, int, (long long int i)); -# endif +# endif _GL_CXXALIAS_SYS (ffsll, int, (long long int i)); +# endif _GL_CXXALIASWARN (ffsll); #elif defined GNULIB_POSIXCHECK # undef ffsll diff --git a/lib/sys_stat.in.h b/lib/sys_stat.in.h index ccdb5cbd143..13d12943cd0 100644 --- a/lib/sys_stat.in.h +++ b/lib/sys_stat.in.h @@ -713,11 +713,21 @@ _GL_WARN_ON_USE (mkfifo, "mkfifo is not portable - " #if @GNULIB_MKFIFOAT@ -# if !@HAVE_MKFIFOAT@ +# if @REPLACE_MKFIFOAT@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef mkfifoat +# define mkfifoat rpl_mkfifoat +# endif +_GL_FUNCDECL_RPL (mkfifoat, int, (int fd, char const *file, mode_t mode) + _GL_ARG_NONNULL ((2))); +_GL_CXXALIAS_RPL (mkfifoat, int, (int fd, char const *file, mode_t mode)); +# else +# if !@HAVE_MKFIFOAT@ _GL_FUNCDECL_SYS (mkfifoat, int, (int fd, char const *file, mode_t mode) _GL_ARG_NONNULL ((2))); -# endif +# endif _GL_CXXALIAS_SYS (mkfifoat, int, (int fd, char const *file, mode_t mode)); +# endif _GL_CXXALIASWARN (mkfifoat); #elif defined GNULIB_POSIXCHECK # undef mkfifoat @@ -756,13 +766,25 @@ _GL_WARN_ON_USE (mknod, "mknod is not portable - " #if @GNULIB_MKNODAT@ -# if !@HAVE_MKNODAT@ +# if @REPLACE_MKNODAT@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef mknodat +# define mknodat rpl_mknodat +# endif +_GL_FUNCDECL_RPL (mknodat, int, + (int fd, char const *file, mode_t mode, dev_t dev) + _GL_ARG_NONNULL ((2))); +_GL_CXXALIAS_RPL (mknodat, int, + (int fd, char const *file, mode_t mode, dev_t dev)); +# else +# if !@HAVE_MKNODAT@ _GL_FUNCDECL_SYS (mknodat, int, (int fd, char const *file, mode_t mode, dev_t dev) _GL_ARG_NONNULL ((2))); -# endif +# endif _GL_CXXALIAS_SYS (mknodat, int, (int fd, char const *file, mode_t mode, dev_t dev)); +# endif _GL_CXXALIASWARN (mknodat); #elif defined GNULIB_POSIXCHECK # undef mknodat diff --git a/lib/tempname.c b/lib/tempname.c index 3d91deef1e1..e243483eaf8 100644 --- a/lib/tempname.c +++ b/lib/tempname.c @@ -22,6 +22,7 @@ #include #include +#include #include @@ -61,7 +62,8 @@ # define __gen_tempname gen_tempname # define __mkdir mkdir # define __open open -# define __lxstat64(version, file, buf) lstat (file, buf) +# define __lstat64(file, buf) lstat (file, buf) +# define __stat64(file, buf) stat (file, buf) # define __getrandom getrandom # define __clock_gettime64 clock_gettime # define __timespec64 timespec @@ -76,13 +78,14 @@ typedef uint_fast64_t random_value; #define BASE_62_POWER (62LL * 62 * 62 * 62 * 62 * 62 * 62 * 62 * 62 * 62) static random_value -random_bits (random_value var) +random_bits (random_value var, bool use_getrandom) { random_value r; - if (__getrandom (&r, sizeof r, 0) == sizeof r) + /* Without GRND_NONBLOCK it can be blocked for minutes on some systems. */ + if (use_getrandom && __getrandom (&r, sizeof r, GRND_NONBLOCK) == sizeof r) return r; #if _LIBC || (defined CLOCK_MONOTONIC && HAVE_CLOCK_GETTIME) - /* Add entropy if getrandom is not supported. */ + /* Add entropy if getrandom did not work. */ struct __timespec64 tv; __clock_gettime64 (CLOCK_MONOTONIC, &tv); var ^= tv.tv_nsec; @@ -96,7 +99,7 @@ static int direxists (const char *dir) { struct_stat64 buf; - return __xstat64 (_STAT_VER, dir, &buf) == 0 && S_ISDIR (buf.st_mode); + return __stat64 (dir, &buf) == 0 && S_ISDIR (buf.st_mode); } /* Path search algorithm, for tmpnam, tmpfile, etc. If DIR is @@ -188,7 +191,7 @@ try_nocreate (char *tmpl, void *flags _GL_UNUSED) { struct_stat64 st; - if (__lxstat64 (_STAT_VER, tmpl, &st) == 0 || errno == EOVERFLOW) + if (__lstat64 (tmpl, &st) == 0 || errno == EOVERFLOW) __set_errno (EEXIST); return errno == ENOENT ? 0 : -1; } @@ -267,6 +270,13 @@ try_tempname_len (char *tmpl, int suffixlen, void *args, /* How many random base-62 digits can currently be extracted from V. */ int vdigits = 0; + /* Whether to consume entropy when acquiring random bits. On the + first try it's worth the entropy cost with __GT_NOCREATE, which + is inherently insecure and can use the entropy to make it a bit + less secure. On the (rare) second and later attempts it might + help against DoS attacks. */ + bool use_getrandom = tryfunc == try_nocreate; + /* Least unfair value for V. If V is less than this, V can generate BASE_62_DIGITS digits fairly. Otherwise it might be biased. */ random_value const unfair_min @@ -290,7 +300,10 @@ try_tempname_len (char *tmpl, int suffixlen, void *args, if (vdigits == 0) { do - v = random_bits (v); + { + v = random_bits (v, use_getrandom); + use_getrandom = true; + } while (unfair_min <= v); vdigits = BASE_62_DIGITS; diff --git a/lib/time-internal.h b/lib/time-internal.h index 63a3f9e3db1..067ee729eda 100644 --- a/lib/time-internal.h +++ b/lib/time-internal.h @@ -24,7 +24,7 @@ struct tm_zone members are zero. */ struct tm_zone *next; -#if HAVE_TZNAME && !HAVE_TM_ZONE +#if HAVE_TZNAME && !HAVE_STRUCT_TM_TM_ZONE /* Copies of recent strings taken from tzname[0] and tzname[1]. The copies are in ABBRS, so that they survive tzset. Null if unknown. */ char *tzname_copy[2]; diff --git a/lib/time.in.h b/lib/time.in.h index 958dc0bd292..1385980cdf5 100644 --- a/lib/time.in.h +++ b/lib/time.in.h @@ -101,6 +101,25 @@ struct __time_t_must_be_integral { # define GNULIB_defined_struct_time_t_must_be_integral 1 # endif +/* Define TIME_UTC, a positive integer constant used for timespec_get(). */ +# if ! @TIME_H_DEFINES_TIME_UTC@ +# if !GNULIB_defined_TIME_UTC +# define TIME_UTC 1 +# define GNULIB_defined_TIME_UTC 1 +# endif +# endif + +/* Set *TS to the current time, and return BASE. + Upon failure, return 0. */ +# if @GNULIB_TIMESPEC_GET@ +# if ! @HAVE_TIMESPEC_GET@ +_GL_FUNCDECL_SYS (timespec_get, int, (struct timespec *ts, int base) + _GL_ARG_NONNULL ((1))); +# endif +_GL_CXXALIAS_SYS (timespec_get, int, (struct timespec *ts, int base)); +_GL_CXXALIASWARN (timespec_get); +# endif + /* Sleep for at least RQTP seconds unless interrupted, If interrupted, return -1 and store the remaining time into RMTP. See . */ diff --git a/lib/time_rz.c b/lib/time_rz.c index 65e20cc5661..3ac053c6219 100644 --- a/lib/time_rz.c +++ b/lib/time_rz.c @@ -71,7 +71,7 @@ tzalloc (char const *name) if (tz) { tz->next = NULL; -#if HAVE_TZNAME && !HAVE_TM_ZONE +#if HAVE_TZNAME && !HAVE_STRUCT_TM_TM_ZONE tz->tzname_copy[0] = tz->tzname_copy[1] = NULL; #endif tz->tz_is_set = !!name; @@ -83,13 +83,13 @@ tzalloc (char const *name) } /* Save into TZ any nontrivial time zone abbreviation used by TM, and - update *TM (if HAVE_TM_ZONE) or *TZ (if !HAVE_TM_ZONE && - HAVE_TZNAME) if they use the abbreviation. Return true if - successful, false (setting errno) otherwise. */ + update *TM (if HAVE_STRUCT_TM_TM_ZONE) or *TZ (if + !HAVE_STRUCT_TM_TM_ZONE && HAVE_TZNAME) if they use the abbreviation. + Return true if successful, false (setting errno) otherwise. */ static bool save_abbr (timezone_t tz, struct tm *tm) { -#if HAVE_TM_ZONE || HAVE_TZNAME +#if HAVE_STRUCT_TM_TM_ZONE || HAVE_TZNAME char const *zone = NULL; char *zone_copy = (char *) ""; @@ -97,7 +97,7 @@ save_abbr (timezone_t tz, struct tm *tm) int tzname_index = -1; # endif -# if HAVE_TM_ZONE +# if HAVE_STRUCT_TM_TM_ZONE zone = tm->tm_zone; # endif @@ -145,7 +145,7 @@ save_abbr (timezone_t tz, struct tm *tm) } /* Replace the zone name so that its lifetime matches that of TZ. */ -# if HAVE_TM_ZONE +# if HAVE_STRUCT_TM_TM_ZONE tm->tm_zone = zone_copy; # else if (0 <= tzname_index) @@ -303,7 +303,7 @@ mktime_z (timezone_t tz, struct tm *tm) tm_1.tm_isdst = tm->tm_isdst; time_t t = mktime (&tm_1); bool ok = 0 <= tm_1.tm_yday; -#if HAVE_TM_ZONE || HAVE_TZNAME +#if HAVE_STRUCT_TM_TM_ZONE || HAVE_TZNAME ok = ok && save_abbr (tz, &tm_1); #endif if (revert_tz (old_tz) && ok) diff --git a/lib/timegm.c b/lib/timegm.c index fa30943084d..e4127e71c0b 100644 --- a/lib/timegm.c +++ b/lib/timegm.c @@ -1,6 +1,6 @@ /* Convert UTC calendar time to simple time. Like mktime but assumes UTC. - Copyright (C) 1994-2020 Free Software Foundation, Inc. + Copyright (C) 1994-2021 Free Software Foundation, Inc. This file is part of the GNU C Library. The GNU C Library is free software; you can redistribute it and/or diff --git a/lib/utimens.c b/lib/utimens.c index 5bbae058132..44d1ea003e2 100644 --- a/lib/utimens.c +++ b/lib/utimens.c @@ -27,6 +27,7 @@ #include #include #include +#include #include #include #include @@ -52,7 +53,9 @@ /* Avoid recursion with rpl_futimens or rpl_utimensat. */ #undef futimens -#undef utimensat +#if !HAVE_NEARLY_WORKING_UTIMENSAT +# undef utimensat +#endif /* Solaris 9 mistakenly succeeds when given a non-directory with a trailing slash. Force the use of rpl_stat for a fix. */ @@ -246,6 +249,20 @@ fdutimens (int fd, char const *file, struct timespec const timespec[2]) # if HAVE_UTIMENSAT if (fd < 0) { +# if defined __APPLE__ && defined __MACH__ + size_t len = strlen (file); + if (len > 0 && file[len - 1] == '/') + { + struct stat statbuf; + if (stat (file, &statbuf) < 0) + return -1; + if (!S_ISDIR (statbuf.st_mode)) + { + errno = ENOTDIR; + return -1; + } + } +# endif result = utimensat (AT_FDCWD, file, ts, 0); # ifdef __linux__ /* Work around a kernel bug: diff --git a/lib/utimensat.c b/lib/utimensat.c index 2cea64f6982..9fdecd681f6 100644 --- a/lib/utimensat.c +++ b/lib/utimensat.c @@ -24,14 +24,40 @@ #include #include #include +#include +#include #include "stat-time.h" #include "timespec.h" #include "utimens.h" -#if HAVE_UTIMENSAT +#if HAVE_NEARLY_WORKING_UTIMENSAT +/* Use the original utimensat(), but correct the trailing slash handling. */ +int +rpl_utimensat (int fd, char const *file, struct timespec const times[2], + int flag) # undef utimensat +{ + size_t len = strlen (file); + if (len && file[len - 1] == '/') + { + struct stat st; + if (fstatat (fd, file, &st, flag & AT_SYMLINK_NOFOLLOW) < 0) + return -1; + if (!S_ISDIR (st.st_mode)) + { + errno = ENOTDIR; + return -1; + } + } + + return utimensat (fd, file, times, flag); +} + +#else + +# if HAVE_UTIMENSAT /* If we have a native utimensat, but are compiling this file, then utimensat was defined to rpl_utimensat by our replacement @@ -42,24 +68,25 @@ local_utimensat provides the fallback manipulation. */ static int local_utimensat (int, char const *, struct timespec const[2], int); -# define AT_FUNC_NAME local_utimensat +# define AT_FUNC_NAME local_utimensat /* Like utimensat, but work around native bugs. */ int rpl_utimensat (int fd, char const *file, struct timespec const times[2], int flag) +# undef utimensat { -# if defined __linux__ || defined __sun +# if defined __linux__ || defined __sun struct timespec ts[2]; -# endif +# endif /* See comments in utimens.c for details. */ static int utimensat_works_really; /* 0 = unknown, 1 = yes, -1 = no. */ if (0 <= utimensat_works_really) { int result; -# if defined __linux__ || defined __sun +# if defined __linux__ || defined __sun struct stat st; /* As recently as Linux kernel 2.6.32 (Dec 2009), several file systems (xfs, ntfs-3g) have bugs with a single UTIME_OMIT, @@ -90,7 +117,7 @@ rpl_utimensat (int fd, char const *file, struct timespec const times[2], ts[1] = times[1]; times = ts; } -# ifdef __hppa__ +# ifdef __hppa__ /* Linux kernel 2.6.22.19 on hppa does not reject invalid tv_nsec values. */ else if (times @@ -104,8 +131,36 @@ rpl_utimensat (int fd, char const *file, struct timespec const times[2], errno = EINVAL; return -1; } +# endif +# endif +# if defined __APPLE__ && defined __MACH__ + /* macOS 10.13 does not reject invalid tv_nsec values either. */ + if (times + && ((times[0].tv_nsec != UTIME_OMIT + && times[0].tv_nsec != UTIME_NOW + && ! (0 <= times[0].tv_nsec + && times[0].tv_nsec < TIMESPEC_HZ)) + || (times[1].tv_nsec != UTIME_OMIT + && times[1].tv_nsec != UTIME_NOW + && ! (0 <= times[1].tv_nsec + && times[1].tv_nsec < TIMESPEC_HZ)))) + { + errno = EINVAL; + return -1; + } + size_t len = strlen (file); + if (len > 0 && file[len - 1] == '/') + { + struct stat statbuf; + if (fstatat (fd, file, &statbuf, 0) < 0) + return -1; + if (!S_ISDIR (statbuf.st_mode)) + { + errno = ENOTDIR; + return -1; + } + } # endif -# endif result = utimensat (fd, file, times, flag); /* Linux kernel 2.6.25 has a bug where it returns EINVAL for UTIME_NOW or UTIME_OMIT with non-zero tv_sec, which @@ -129,11 +184,11 @@ rpl_utimensat (int fd, char const *file, struct timespec const times[2], return local_utimensat (fd, file, times, flag); } -#else /* !HAVE_UTIMENSAT */ +# else /* !HAVE_UTIMENSAT */ -# define AT_FUNC_NAME utimensat +# define AT_FUNC_NAME utimensat -#endif /* !HAVE_UTIMENSAT */ +# endif /* !HAVE_UTIMENSAT */ /* Set the access and modification timestamps of FILE to be TIMESPEC[0] and TIMESPEC[1], respectively; relative to directory @@ -146,15 +201,17 @@ rpl_utimensat (int fd, char const *file, struct timespec const times[2], Return 0 on success, -1 (setting errno) on failure. */ /* AT_FUNC_NAME is now utimensat or local_utimensat. */ -#define AT_FUNC_F1 lutimens -#define AT_FUNC_F2 utimens -#define AT_FUNC_USE_F1_COND AT_SYMLINK_NOFOLLOW -#define AT_FUNC_POST_FILE_PARAM_DECLS , struct timespec const ts[2], int flag -#define AT_FUNC_POST_FILE_ARGS , ts -#include "at-func.c" -#undef AT_FUNC_NAME -#undef AT_FUNC_F1 -#undef AT_FUNC_F2 -#undef AT_FUNC_USE_F1_COND -#undef AT_FUNC_POST_FILE_PARAM_DECLS -#undef AT_FUNC_POST_FILE_ARGS +# define AT_FUNC_F1 lutimens +# define AT_FUNC_F2 utimens +# define AT_FUNC_USE_F1_COND AT_SYMLINK_NOFOLLOW +# define AT_FUNC_POST_FILE_PARAM_DECLS , struct timespec const ts[2], int flag +# define AT_FUNC_POST_FILE_ARGS , ts +# include "at-func.c" +# undef AT_FUNC_NAME +# undef AT_FUNC_F1 +# undef AT_FUNC_F2 +# undef AT_FUNC_USE_F1_COND +# undef AT_FUNC_POST_FILE_PARAM_DECLS +# undef AT_FUNC_POST_FILE_ARGS + +#endif /* !HAVE_NEARLY_WORKING_UTIMENSAT */ diff --git a/lib/verify.h b/lib/verify.h index 3cdcdca5671..65514c34b9e 100644 --- a/lib/verify.h +++ b/lib/verify.h @@ -22,16 +22,10 @@ /* Define _GL_HAVE__STATIC_ASSERT to 1 if _Static_assert (R, DIAGNOSTIC) - works as per C11. This is supported by GCC 4.6.0 and later, in C - mode, and by clang (also in C++ mode). + works as per C11. This is supported by GCC 4.6.0+ and by clang 4+. Define _GL_HAVE__STATIC_ASSERT1 to 1 if _Static_assert (R) works as - per C2X. This is supported by GCC 9.1 and later, and by clang in - C++1z mode. - - Define _GL_HAVE_STATIC_ASSERT1 if static_assert (R) works as per - C++17. This is supported by GCC 9.1 and later, and by clang in - C++1z mode. + per C2X. This is supported by GCC 9.1+. Support compilers claiming conformance to the relevant standard, and also support GCC when not pedantic. If we were willing to slow @@ -47,18 +41,6 @@ || (!defined __STRICT_ANSI__ && 9 <= __GNUC__)) # define _GL_HAVE__STATIC_ASSERT1 1 # endif -#else -# if 4 <= __clang_major__ -# define _GL_HAVE__STATIC_ASSERT 1 -# endif -# if 4 <= __clang_major__ && 201411 <= __cpp_static_assert -# define _GL_HAVE__STATIC_ASSERT1 1 -# endif -# if 201703L <= __cplusplus \ - || 9 <= __GNUC__ \ - || (4 <= __clang_major__ && 201411 <= __cpp_static_assert) -# define _GL_HAVE_STATIC_ASSERT1 1 -# endif #endif /* FreeBSD 9.1 , included by and lots of other @@ -225,7 +207,9 @@ template Unfortunately, unlike C11, this implementation must appear as an ordinary declaration, and cannot appear inside struct { ... }. */ -#if defined _GL_HAVE__STATIC_ASSERT +#if 200410 <= __cpp_static_assert +# define _GL_VERIFY(R, DIAGNOSTIC, ...) static_assert (R, DIAGNOSTIC) +#elif defined _GL_HAVE__STATIC_ASSERT # define _GL_VERIFY(R, DIAGNOSTIC, ...) _Static_assert (R, DIAGNOSTIC) #else # define _GL_VERIFY(R, DIAGNOSTIC, ...) \ @@ -239,7 +223,7 @@ template # define _Static_assert(...) \ _GL_VERIFY (__VA_ARGS__, "static assertion failed", -) # endif -# if !defined _GL_HAVE_STATIC_ASSERT1 && !defined static_assert +# if __cpp_static_assert < 201411 && !defined static_assert # define static_assert _Static_assert /* C11 requires this #define. */ # endif #endif diff --git a/m4/canonicalize.m4 b/m4/canonicalize.m4 index 475fa15d6bd..0dfb2da9a6a 100644 --- a/m4/canonicalize.m4 +++ b/m4/canonicalize.m4 @@ -1,4 +1,4 @@ -# canonicalize.m4 serial 35 +# canonicalize.m4 serial 37 dnl Copyright (C) 2003-2007, 2009-2021 Free Software Foundation, Inc. @@ -78,68 +78,106 @@ AC_DEFUN([gl_CANONICALIZE_LGPL_SEPARATE], # so is the latter. AC_DEFUN([gl_FUNC_REALPATH_WORKS], [ - AC_CHECK_FUNCS_ONCE([realpath]) + AC_CHECK_FUNCS_ONCE([realpath lstat]) AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles AC_CACHE_CHECK([whether realpath works], [gl_cv_func_realpath_works], [ rm -rf conftest.a conftest.d touch conftest.a + # Assume that if we have lstat, we can also check symlinks. + if test $ac_cv_func_lstat = yes; then + ln -s conftest.a conftest.l + fi mkdir conftest.d AC_RUN_IFELSE([ AC_LANG_PROGRAM([[ ]GL_NOCRASH[ + #include #include #include ]], [[ int result = 0; + /* This test fails on Solaris 10. */ { char *name = realpath ("conftest.a", NULL); if (!(name && *name == '/')) result |= 1; free (name); } + /* This test fails on older versions of Cygwin. */ { char *name = realpath ("conftest.b/../conftest.a", NULL); if (name != NULL) result |= 2; free (name); } + /* This test fails on Cygwin 2.9. */ + #if HAVE_LSTAT { - char *name = realpath ("conftest.a/", NULL); - if (name != NULL) + char *name = realpath ("conftest.l/../conftest.a", NULL); + if (name != NULL || errno != ENOTDIR) result |= 4; free (name); } + #endif + /* This test fails on Mac OS X 10.13, OpenBSD 6.0. */ + { + char *name = realpath ("conftest.a/", NULL); + if (name != NULL) + result |= 8; + free (name); + } + /* This test fails on AIX 7, Solaris 10. */ { char *name1 = realpath (".", NULL); char *name2 = realpath ("conftest.d//./..", NULL); if (! name1 || ! name2 || strcmp (name1, name2)) - result |= 8; + result |= 16; free (name1); free (name2); } + #ifdef __linux__ + /* On Linux, // is the same as /. See also double-slash-root.m4. + realpath() should respect this. + This test fails on musl libc 1.2.2. */ + { + char *name = realpath ("//", NULL); + if (! name || strcmp (name, "/")) + result |= 32; + free (name); + } + #endif return result; ]]) ], [gl_cv_func_realpath_works=yes], - [gl_cv_func_realpath_works=no], + [case $? in + 32) gl_cv_func_realpath_works=nearly ;; + *) gl_cv_func_realpath_works=no ;; + esac + ], [case "$host_os" in # Guess yes on glibc systems. *-gnu* | gnu*) gl_cv_func_realpath_works="guessing yes" ;; - # Guess yes on musl systems. - *-musl*) gl_cv_func_realpath_works="guessing yes" ;; + # Guess 'nearly' on musl systems. + *-musl*) gl_cv_func_realpath_works="guessing nearly" ;; + # Guess no on Cygwin. + cygwin*) gl_cv_func_realpath_works="guessing no" ;; # Guess no on native Windows. mingw*) gl_cv_func_realpath_works="guessing no" ;; # If we don't know, obey --enable-cross-guesses. *) gl_cv_func_realpath_works="$gl_cross_guess_normal" ;; esac ]) - rm -rf conftest.a conftest.d + rm -rf conftest.a conftest.l conftest.d ]) case "$gl_cv_func_realpath_works" in *yes) - AC_DEFINE([FUNC_REALPATH_WORKS], [1], [Define to 1 if realpath() - can malloc memory, always gives an absolute path, and handles - trailing slash correctly.]) + AC_DEFINE([FUNC_REALPATH_WORKS], [1], + [Define to 1 if realpath() can malloc memory, always gives an absolute path, and handles leading slashes and a trailing slash correctly.]) + ;; + *nearly) + AC_DEFINE([FUNC_REALPATH_NEARLY_WORKS], [1], + [Define to 1 if realpath() can malloc memory, always gives an absolute path, and handles a trailing slash correctly.]) ;; esac ]) diff --git a/m4/extensions.m4 b/m4/extensions.m4 index f7333acbd4f..5792a9557a8 100644 --- a/m4/extensions.m4 +++ b/m4/extensions.m4 @@ -1,4 +1,4 @@ -# serial 21 -*- Autoconf -*- +# serial 22 -*- Autoconf -*- # Enable extensions on systems that normally disable them. # Copyright (C) 2003, 2006-2021 Free Software Foundation, Inc. @@ -212,4 +212,16 @@ dnl it should only be defined when necessary. AC_DEFUN_ONCE([gl_USE_SYSTEM_EXTENSIONS], [ AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS]) + + dnl On OpenBSD 6.8 with GCC, the include files contain a couple of + dnl definitions that are only activated with an explicit -D_ISOC11_SOURCE. + dnl That's because this version of GCC (4.2.1) supports the option + dnl '-std=gnu99' but not the option '-std=gnu11'. + AC_REQUIRE([AC_CANONICAL_HOST]) + case "$host_os" in + openbsd*) + AC_DEFINE([_ISOC11_SOURCE], [1], + [Define to enable the declarations of ISO C 11 types and functions.]) + ;; + esac ]) diff --git a/m4/fchmodat.m4 b/m4/fchmodat.m4 index 09380327799..66c0e308fcc 100644 --- a/m4/fchmodat.m4 +++ b/m4/fchmodat.m4 @@ -1,4 +1,4 @@ -# fchmodat.m4 serial 5 +# fchmodat.m4 serial 6 dnl Copyright (C) 2004-2021 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -16,11 +16,9 @@ AC_DEFUN([gl_FUNC_FCHMODAT], HAVE_FCHMODAT=0 else AC_CACHE_CHECK( - [whether fchmodat+AT_SYMLINK_NOFOLLOW works on non-symlinks], + [whether fchmodat works], [gl_cv_func_fchmodat_works], - [dnl This test fails on GNU/Linux with glibc 2.31 (but not on - dnl GNU/kFreeBSD nor GNU/Hurd) and Cygwin 2.9. - AC_RUN_IFELSE( + [AC_RUN_IFELSE( [AC_LANG_PROGRAM( [ AC_INCLUDES_DEFAULT[ @@ -44,27 +42,49 @@ AC_DEFUN([gl_FUNC_FCHMODAT], [[ int permissive = S_IRWXU | S_IRWXG | S_IRWXO; int desired = S_IRUSR | S_IWUSR; - static char const f[] = "conftest.fchmodat"; + int result = 0; + #define file "conftest.fchmodat" struct stat st; - if (creat (f, permissive) < 0) + if (creat (file, permissive) < 0) return 1; - if (fchmodat (AT_FDCWD, f, desired, AT_SYMLINK_NOFOLLOW) != 0) + /* Test whether fchmodat rejects a trailing slash on a non-directory. + This test fails on AIX 7.2. */ + if (fchmodat (AT_FDCWD, file "/", desired, 0) == 0) + result |= 2; + /* Test whether fchmodat+AT_SYMLINK_NOFOLLOW works on non-symlinks. + This test fails on GNU/Linux with glibc 2.31 (but not on + GNU/kFreeBSD nor GNU/Hurd) and Cygwin 2.9. */ + if (fchmodat (AT_FDCWD, file, desired, AT_SYMLINK_NOFOLLOW) != 0) + result |= 4; + if (stat (file, &st) != 0) return 1; - if (stat (f, &st) != 0) - return 1; - return ! ((st.st_mode & permissive) == desired); + if ((st.st_mode & permissive) != desired) + result |= 4; + return result; ]])], [gl_cv_func_fchmodat_works=yes], - [gl_cv_func_fchmodat_works=no], + [case $? in + 2) gl_cv_func_fchmodat_works='nearly' ;; + *) gl_cv_func_fchmodat_works=no ;; + esac + ], [case "$host_os" in - dnl Guess no on Linux with glibc and Cygwin, yes otherwise. + # Guess no on Linux with glibc and Cygwin. linux-gnu* | cygwin*) gl_cv_func_fchmodat_works="guessing no" ;; + # Guess 'nearly' on AIX. + aix*) gl_cv_func_fchmodat_works="guessing nearly" ;; + # If we don't know, obey --enable-cross-guesses. *) gl_cv_func_fchmodat_works="$gl_cross_guess_normal" ;; esac ]) rm -f conftest.fchmodat]) - case $gl_cv_func_fchmodat_works in + case "$gl_cv_func_fchmodat_works" in *yes) ;; + *nearly) + AC_DEFINE([HAVE_NEARLY_WORKING_FCHMODAT], [1], + [Define to 1 if fchmodat works, except for the trailing slash handling.]) + REPLACE_FCHMODAT=1 + ;; *) AC_DEFINE([NEED_FCHMODAT_NONSYMLINK_FIX], [1], [Define to 1 if fchmodat+AT_SYMLINK_NOFOLLOW does not work right on non-symlinks.]) diff --git a/m4/gnulib-common.m4 b/m4/gnulib-common.m4 index 535359b2cf6..f2eff10de6d 100644 --- a/m4/gnulib-common.m4 +++ b/m4/gnulib-common.m4 @@ -39,11 +39,12 @@ AC_DEFUN([gl_COMMON_BODY], [ this syntax with 'extern'. */ # define _Noreturn [[noreturn]] # elif ((!defined __cplusplus || defined __clang__) \ - && (201112 <= (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) \ - || _GL_GNUC_PREREQ (4, 7) \ - || (defined __apple_build_version__ \ - ? 6000000 <= __apple_build_version__ \ - : 3 < __clang_major__ + (5 <= __clang_minor__)))) + && (201112 <= (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) \ + || (!defined __STRICT_ANSI__ \ + && (_GL_GNUC_PREREQ (4, 7) \ + || (defined __apple_build_version__ \ + ? 6000000 <= __apple_build_version__ \ + : 3 < __clang_major__ + (5 <= __clang_minor__)))))) /* _Noreturn works as-is. */ # elif _GL_GNUC_PREREQ (2, 8) || defined __clang__ || 0x5110 <= __SUNPRO_C # define _Noreturn __attribute__ ((__noreturn__)) @@ -66,7 +67,9 @@ AC_DEFUN([gl_COMMON_BODY], [ #endif]) AH_VERBATIM([attribute], [/* Attributes. */ -#ifdef __has_attribute +#if (defined __has_attribute \ + && (!defined __clang_minor__ \ + || 3 < __clang_major__ + (5 <= __clang_minor__))) # define _GL_HAS_ATTRIBUTE(attr) __has_attribute (__##attr##__) #else # define _GL_HAS_ATTRIBUTE(attr) _GL_ATTR_##attr diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index ad109520dd1..cd6f7b4bbdf 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -75,6 +75,7 @@ AC_DEFUN([gl_EARLY], # Code from module dtoastr: # Code from module dtotimespec: # Code from module dup2: + # Code from module dynarray: # Code from module eloop-threshold: # Code from module environ: # Code from module errno: @@ -517,6 +518,7 @@ AC_DEFUN([gl_INIT], gl_gnulib_enabled_260941c0e5dc67ec9e87d1fb321c300b=false gl_gnulib_enabled_cloexec=false gl_gnulib_enabled_dirfd=false + gl_gnulib_enabled_dynarray=false gl_gnulib_enabled_925677f0343de64b89a9f0c790b4104c=false gl_gnulib_enabled_euidaccess=false gl_gnulib_enabled_getdtablesize=false @@ -564,6 +566,12 @@ AC_DEFUN([gl_INIT], gl_gnulib_enabled_dirfd=true fi } + func_gl_gnulib_m4code_dynarray () + { + if ! $gl_gnulib_enabled_dynarray; then + gl_gnulib_enabled_dynarray=true + fi + } func_gl_gnulib_m4code_925677f0343de64b89a9f0c790b4104c () { if ! $gl_gnulib_enabled_925677f0343de64b89a9f0c790b4104c; then @@ -797,6 +805,9 @@ AC_DEFUN([gl_INIT], if test $HAVE_READLINKAT = 0 || test $REPLACE_READLINKAT = 1; then func_gl_gnulib_m4code_03e0aaad4cb89ca757653bd367a6ccb7 fi + if test $ac_use_included_regex = yes; then + func_gl_gnulib_m4code_dynarray + fi if { test $HAVE_DECL_STRTOIMAX = 0 || test $REPLACE_STRTOIMAX = 1; } && test $ac_cv_type_long_long_int = yes; then func_gl_gnulib_m4code_strtoll fi @@ -819,6 +830,7 @@ AC_DEFUN([gl_INIT], AM_CONDITIONAL([gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b], [$gl_gnulib_enabled_260941c0e5dc67ec9e87d1fb321c300b]) AM_CONDITIONAL([gl_GNULIB_ENABLED_cloexec], [$gl_gnulib_enabled_cloexec]) AM_CONDITIONAL([gl_GNULIB_ENABLED_dirfd], [$gl_gnulib_enabled_dirfd]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_dynarray], [$gl_gnulib_enabled_dynarray]) AM_CONDITIONAL([gl_GNULIB_ENABLED_925677f0343de64b89a9f0c790b4104c], [$gl_gnulib_enabled_925677f0343de64b89a9f0c790b4104c]) AM_CONDITIONAL([gl_GNULIB_ENABLED_euidaccess], [$gl_gnulib_enabled_euidaccess]) AM_CONDITIONAL([gl_GNULIB_ENABLED_getdtablesize], [$gl_gnulib_enabled_getdtablesize]) @@ -1021,6 +1033,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/dtoastr.c lib/dtotimespec.c lib/dup2.c + lib/dynarray.h lib/eloop-threshold.h lib/errno.in.h lib/euidaccess.c @@ -1076,6 +1089,13 @@ AC_DEFUN([gl_FILE_LIST], [ lib/libc-config.h lib/limits.in.h lib/lstat.c + lib/malloc/dynarray-skeleton.c + lib/malloc/dynarray.h + lib/malloc/dynarray_at_failure.c + lib/malloc/dynarray_emplace_enlarge.c + lib/malloc/dynarray_finalize.c + lib/malloc/dynarray_resize.c + lib/malloc/dynarray_resize_clear.c lib/malloc/scratch_buffer.h lib/malloc/scratch_buffer_dupfree.c lib/malloc/scratch_buffer_grow.c diff --git a/m4/nstrftime.m4 b/m4/nstrftime.m4 index 4674442810b..b510554b947 100644 --- a/m4/nstrftime.m4 +++ b/m4/nstrftime.m4 @@ -1,4 +1,4 @@ -# serial 36 +# serial 37 # Copyright (C) 1996-1997, 1999-2007, 2009-2021 Free Software Foundation, Inc. # @@ -12,7 +12,7 @@ AC_DEFUN([gl_FUNC_GNU_STRFTIME], [ AC_REQUIRE([AC_C_RESTRICT]) - # This defines (or not) HAVE_TZNAME and HAVE_TM_ZONE. + # This defines (or not) HAVE_TZNAME and HAVE_STRUCT_TM_TM_ZONE. AC_REQUIRE([AC_STRUCT_TIMEZONE]) AC_REQUIRE([gl_TM_GMTOFF]) diff --git a/m4/stddef_h.m4 b/m4/stddef_h.m4 index 18e872f483e..cd666c4a58c 100644 --- a/m4/stddef_h.m4 +++ b/m4/stddef_h.m4 @@ -1,14 +1,19 @@ -dnl A placeholder for , for platforms that have issues. -# stddef_h.m4 serial 7 +# stddef_h.m4 serial 9 dnl Copyright (C) 2009-2021 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. +dnl A placeholder for , for platforms that have issues. + AC_DEFUN([gl_STDDEF_H], [ AC_REQUIRE([gl_STDDEF_H_DEFAULTS]) AC_REQUIRE([gt_TYPE_WCHAR_T]) + + dnl Persuade OpenBSD to declare max_align_t. + AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) + STDDEF_H= dnl Test whether the type max_align_t exists and whether its alignment @@ -23,6 +28,13 @@ AC_DEFUN([gl_STDDEF_H], int check1[2 * (__alignof__ (double) <= __alignof__ (max_align_t)) - 1]; int check2[2 * (__alignof__ (long double) <= __alignof__ (max_align_t)) - 1]; #endif + typedef struct { char a; max_align_t b; } max_helper; + typedef struct { char a; long b; } long_helper; + typedef struct { char a; double b; } double_helper; + typedef struct { char a; long double b; } long_double_helper; + int check3[2 * (offsetof (long_helper, b) <= offsetof (max_helper, b)) - 1]; + int check4[2 * (offsetof (double_helper, b) <= offsetof (max_helper, b)) - 1]; + int check5[2 * (offsetof (long_double_helper, b) <= offsetof (max_helper, b)) - 1]; ]])], [gl_cv_type_max_align_t=yes], [gl_cv_type_max_align_t=no]) diff --git a/m4/string_h.m4 b/m4/string_h.m4 index 3e65355735c..a4cc5b43783 100644 --- a/m4/string_h.m4 +++ b/m4/string_h.m4 @@ -5,7 +5,7 @@ # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. -# serial 28 +# serial 29 # Written by Paul Eggert. @@ -113,6 +113,7 @@ AC_DEFUN([gl_HEADER_STRING_H_DEFAULTS], HAVE_SIGDESCR_NP=1; AC_SUBST([HAVE_SIGDESCR_NP]) HAVE_DECL_STRSIGNAL=1; AC_SUBST([HAVE_DECL_STRSIGNAL]) HAVE_STRVERSCMP=1; AC_SUBST([HAVE_STRVERSCMP]) + REPLACE_FFSLL=0; AC_SUBST([REPLACE_FFSLL]) REPLACE_MEMCHR=0; AC_SUBST([REPLACE_MEMCHR]) REPLACE_MEMMEM=0; AC_SUBST([REPLACE_MEMMEM]) REPLACE_STPNCPY=0; AC_SUBST([REPLACE_STPNCPY]) diff --git a/m4/sys_stat_h.m4 b/m4/sys_stat_h.m4 index e8eac71b466..23cbdd28eb2 100644 --- a/m4/sys_stat_h.m4 +++ b/m4/sys_stat_h.m4 @@ -1,4 +1,4 @@ -# sys_stat_h.m4 serial 36 -*- Autoconf -*- +# sys_stat_h.m4 serial 38 -*- Autoconf -*- dnl Copyright (C) 2006-2021 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -104,7 +104,9 @@ AC_DEFUN([gl_SYS_STAT_H_DEFAULTS], REPLACE_LSTAT=0; AC_SUBST([REPLACE_LSTAT]) REPLACE_MKDIR=0; AC_SUBST([REPLACE_MKDIR]) REPLACE_MKFIFO=0; AC_SUBST([REPLACE_MKFIFO]) + REPLACE_MKFIFOAT=0; AC_SUBST([REPLACE_MKFIFOAT]) REPLACE_MKNOD=0; AC_SUBST([REPLACE_MKNOD]) + REPLACE_MKNODAT=0; AC_SUBST([REPLACE_MKNODAT]) REPLACE_STAT=0; AC_SUBST([REPLACE_STAT]) REPLACE_UTIMENSAT=0; AC_SUBST([REPLACE_UTIMENSAT]) ]) diff --git a/m4/time_h.m4 b/m4/time_h.m4 index 07e6967e45b..b6a1aa3bc0f 100644 --- a/m4/time_h.m4 +++ b/m4/time_h.m4 @@ -2,7 +2,7 @@ # Copyright (C) 2000-2001, 2003-2007, 2009-2021 Free Software Foundation, Inc. -# serial 13 +# serial 15 # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -25,6 +25,22 @@ AC_DEFUN([gl_HEADER_TIME_H_BODY], AC_REQUIRE([gl_CHECK_TYPE_STRUCT_TIMESPEC]) AC_REQUIRE([AC_C_RESTRICT]) + + AC_CACHE_CHECK([for TIME_UTC in ], + [gl_cv_time_h_has_TIME_UTC], + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM( + [[#include + ]], + [[static int x = TIME_UTC; x++;]])], + [gl_cv_time_h_has_TIME_UTC=yes], + [gl_cv_time_h_has_TIME_UTC=no])]) + if test $gl_cv_time_h_has_TIME_UTC = yes; then + TIME_H_DEFINES_TIME_UTC=1 + else + TIME_H_DEFINES_TIME_UTC=0 + fi + AC_SUBST([TIME_H_DEFINES_TIME_UTC]) ]) dnl Check whether 'struct timespec' is declared @@ -113,6 +129,7 @@ AC_DEFUN([gl_HEADER_TIME_H_DEFAULTS], GNULIB_STRFTIME=0; AC_SUBST([GNULIB_STRFTIME]) GNULIB_STRPTIME=0; AC_SUBST([GNULIB_STRPTIME]) GNULIB_TIMEGM=0; AC_SUBST([GNULIB_TIMEGM]) + GNULIB_TIMESPEC_GET=0; AC_SUBST([GNULIB_TIMESPEC_GET]) GNULIB_TIME_R=0; AC_SUBST([GNULIB_TIME_R]) GNULIB_TIME_RZ=0; AC_SUBST([GNULIB_TIME_RZ]) GNULIB_TZSET=0; AC_SUBST([GNULIB_TZSET]) @@ -123,6 +140,7 @@ AC_DEFUN([gl_HEADER_TIME_H_DEFAULTS], HAVE_NANOSLEEP=1; AC_SUBST([HAVE_NANOSLEEP]) HAVE_STRPTIME=1; AC_SUBST([HAVE_STRPTIME]) HAVE_TIMEGM=1; AC_SUBST([HAVE_TIMEGM]) + HAVE_TIMESPEC_GET=1; AC_SUBST([HAVE_TIMESPEC_GET]) dnl Even GNU libc does not have timezone_t yet. HAVE_TIMEZONE_T=0; AC_SUBST([HAVE_TIMEZONE_T]) dnl If another module says to replace or to not replace, do that. diff --git a/m4/utimensat.m4 b/m4/utimensat.m4 index bdabe24c568..b5bff1651f3 100644 --- a/m4/utimensat.m4 +++ b/m4/utimensat.m4 @@ -1,4 +1,4 @@ -# serial 7 +# serial 9 # See if we need to provide utimensat replacement. dnl Copyright (C) 2009-2021 Free Software Foundation, Inc. @@ -12,6 +12,7 @@ AC_DEFUN([gl_FUNC_UTIMENSAT], [ AC_REQUIRE([gl_SYS_STAT_H_DEFAULTS]) AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles AC_CHECK_FUNCS_ONCE([utimensat]) if test $ac_cv_func_utimensat = no; then HAVE_UTIMENSAT=0 @@ -28,10 +29,19 @@ AC_DEFUN([gl_FUNC_UTIMENSAT], const char *f = "conftest.file"; if (close (creat (f, 0600))) return 1; + /* Test whether a trailing slash is handled correctly. + This fails on AIX 7.2. */ + { + struct timespec ts[2]; + ts[0].tv_sec = 345183300; ts[0].tv_nsec = 0; + ts[1] = ts[0]; + if (utimensat (AT_FDCWD, "conftest.file/", ts, 0) == 0) + result |= 2; + } /* Test whether the AT_SYMLINK_NOFOLLOW flag is supported. */ { if (utimensat (AT_FDCWD, f, NULL, AT_SYMLINK_NOFOLLOW)) - result |= 2; + result |= 4; } /* Test whether UTIME_NOW and UTIME_OMIT work. */ { @@ -41,7 +51,7 @@ AC_DEFUN([gl_FUNC_UTIMENSAT], ts[1].tv_sec = 1; ts[1].tv_nsec = UTIME_NOW; if (utimensat (AT_FDCWD, f, ts, 0)) - result |= 4; + result |= 8; } sleep (1); { @@ -52,19 +62,44 @@ AC_DEFUN([gl_FUNC_UTIMENSAT], ts[1].tv_sec = 1; ts[1].tv_nsec = UTIME_OMIT; if (utimensat (AT_FDCWD, f, ts, 0)) - result |= 8; - if (stat (f, &st)) result |= 16; - else if (st.st_ctime < st.st_atime) + if (stat (f, &st)) result |= 32; + else if (st.st_ctime < st.st_atime) + result |= 64; } return result; ]])], [gl_cv_func_utimensat_works=yes], - [gl_cv_func_utimensat_works=no], - [gl_cv_func_utimensat_works="guessing yes"])]) - if test "$gl_cv_func_utimensat_works" = no; then - REPLACE_UTIMENSAT=1 - fi + [case $? in + 2) gl_cv_func_utimensat_works='nearly' ;; + *) gl_cv_func_utimensat_works=no ;; + esac + ], + [case "$host_os" in + # Guess yes on Linux or glibc systems. + linux-* | linux | *-gnu* | gnu*) + gl_cv_func_utimensat_works="guessing yes" ;; + # Guess 'nearly' on AIX. + aix*) + gl_cv_func_utimensat_works="guessing nearly" ;; + # If we don't know, obey --enable-cross-guesses. + *) + gl_cv_func_utimensat_works="$gl_cross_guess_normal" ;; + esac + ]) + ]) + case "$gl_cv_func_utimensat_works" in + *yes) + ;; + *nearly) + AC_DEFINE([HAVE_NEARLY_WORKING_UTIMENSAT], [1], + [Define to 1 if utimensat works, except for the trailing slash handling.]) + REPLACE_UTIMENSAT=1 + ;; + *) + REPLACE_UTIMENSAT=1 + ;; + esac fi ]) From b99ec5d5b11154bafb193ceaaac6976daafe3f82 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Fri, 22 Jan 2021 11:47:22 -0800 Subject: [PATCH 107/133] Work around __has_attribute bug in clang 3.4 * src/conf_post.h (HAS_ATTRIBUTE): * src/emacs-module.h.in (EMACS_ATTRIBUTE_NONNULL): Port to clang 3.4 and earlier. --- src/conf_post.h | 4 +++- src/emacs-module.h.in | 4 +++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/src/conf_post.h b/src/conf_post.h index bd56f29e287..176ab28b21a 100644 --- a/src/conf_post.h +++ b/src/conf_post.h @@ -71,7 +71,9 @@ typedef bool bool_bf; It is used only on arguments like cleanup that are handled here. This macro should be used only in #if expressions, as Oracle Studio 12.5's __has_attribute does not work in plain code. */ -#ifdef __has_attribute +#if (defined __has_attribute \ + && (!defined __clang_minor__ \ + || 3 < __clang_major__ + (5 <= __clang_minor__))) # define HAS_ATTRIBUTE(a) __has_attribute (__##a##__) #else # define HAS_ATTRIBUTE(a) HAS_ATTR_##a diff --git a/src/emacs-module.h.in b/src/emacs-module.h.in index 2989b439109..fe52587c1a5 100644 --- a/src/emacs-module.h.in +++ b/src/emacs-module.h.in @@ -51,7 +51,9 @@ information how to write modules and use this header file. #if 3 < __GNUC__ + (3 <= __GNUC_MINOR__) # define EMACS_ATTRIBUTE_NONNULL(...) \ __attribute__ ((__nonnull__ (__VA_ARGS__))) -#elif defined __has_attribute +#elif (defined __has_attribute \ + && (!defined __clang_minor__ \ + || 3 < __clang_major__ + (5 <= __clang_minor__))) # if __has_attribute (__nonnull__) # define EMACS_ATTRIBUTE_NONNULL(...) \ __attribute__ ((__nonnull__ (__VA_ARGS__))) From ba25a82855a2c03c25fec83f3056c166b692e94f Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 22 Jan 2021 21:07:35 +0100 Subject: [PATCH 108/133] Mention undo-amalgamate-change-group in the lispref manual * doc/lispref/text.texi (Atomic Changes): Mention undo-amalgamate-change-group (bug#42303). --- doc/lispref/text.texi | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index 0b567d82c61..35bc6f9f161 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -5608,6 +5608,11 @@ This function accepts all the changes in the change group specified by @defun cancel-change-group handle This function cancels and undoes all the changes in the change group specified by @var{handle}. +@end defun + +@defun undo-amalgamate-change-group +Amalgamate changes in change-group since @var{handle}. I.e., remove +all undo boundaries between the state of @var{handle} and now. @end defun Your code should use @code{unwind-protect} to make sure the group is From b9d0cdcacbd3da93b4ebfa10d778efb618881ccc Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 22 Jan 2021 16:56:57 -0500 Subject: [PATCH 109/133] * lisp/simple.el (newline-and-indent): Disable `electric-indent-mode` With `electric-indent-mode` enabled, `newline-and-indent` ends up indenting 3 times: once for the original line and twice on the new line. `reindent-then-newline-and-indent` is even worse, indenting twice both lines. None of those commands should be affected by `electric-indent-mode` since they even explicitly say in their name when and how they do indentation. (reindent-then-newline-and-indent): Temporarily disable `electric-indent-mode` as well. --- lisp/simple.el | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/lisp/simple.el b/lisp/simple.el index 2c6e3916cd4..8d4e4a7a6bb 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -820,9 +820,10 @@ With ARG, perform this action that many times." (delete-horizontal-space t) (unless arg (setq arg 1)) - (dotimes (_ arg) - (newline nil t) - (indent-according-to-mode))) + (let ((electric-indent-mode nil)) + (dotimes (_ arg) + (newline nil t) + (indent-according-to-mode)))) (defun reindent-then-newline-and-indent () "Reindent current line, insert newline, then indent the new line. @@ -832,7 +833,8 @@ In programming language modes, this is the same as TAB. In some text modes, where TAB inserts a tab, this indents to the column specified by the function `current-left-margin'." (interactive "*") - (let ((pos (point))) + (let ((pos (point)) + (electric-indent-mode nil)) ;; Be careful to insert the newline before indenting the line. ;; Otherwise, the indentation might be wrong. (newline) From 5821dee0949b2913c07970d6e4b8bb8e8a35f036 Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Sat, 23 Jan 2021 02:53:12 +0200 Subject: [PATCH 110/133] Erase the buffer only after fetching the new contents * lisp/progmodes/xref.el (xref-revert-buffer): Erase the buffer only after fetching the new contents (bug#46042). --- lisp/progmodes/xref.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index aecb30a0ad4..abaa0dc5e8b 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -967,10 +967,10 @@ Return an alist of the form ((FILENAME . (XREF ...)) ...)." (let ((inhibit-read-only t) (buffer-undo-list t)) (save-excursion - (erase-buffer) (condition-case err - (xref--insert-xrefs - (xref--analyze (funcall xref--fetcher))) + (let ((alist (xref--analyze (funcall xref--fetcher)))) + (erase-buffer) + (xref--insert-xrefs alist)) (user-error (insert (propertize From cc98d0bf5225c281f91152aa838c4cb093df52e9 Mon Sep 17 00:00:00 2001 From: Dmitry Gutov Date: Sat, 23 Jan 2021 02:58:53 +0200 Subject: [PATCH 111/133] ; xref-revert-buffer: Drop the (goto-char) at the end --- lisp/progmodes/xref.el | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index abaa0dc5e8b..898cb4fb4c1 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -975,8 +975,7 @@ Return an alist of the form ((FILENAME . (XREF ...)) ...)." (insert (propertize (error-message-string err) - 'face 'error)))) - (goto-char (point-min))))) + 'face 'error))))))) (defun xref-show-definitions-buffer (fetcher alist) "Show the definitions list in a regular window. From 8d8e1dfd05fd79859e8206de0e89329b0d862ce1 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 23 Jan 2021 12:51:57 +0200 Subject: [PATCH 112/133] Clean up the recently added self-pipe mechanism for WINDOWSNT * src/process.c (child_signal_init, child_signal_read) (child_signal_notify): #ifdef away on WINDOWSNT. --- src/process.c | 23 +++++++++++++++++++++-- 1 file changed, 21 insertions(+), 2 deletions(-) diff --git a/src/process.c b/src/process.c index 57105982c15..697d9b0b19b 100644 --- a/src/process.c +++ b/src/process.c @@ -290,7 +290,10 @@ static int child_signal_read_fd = -1; status changes. */ static int child_signal_write_fd = -1; static void child_signal_init (void); +#ifndef WINDOWSNT +/* FIXME: This is never used, on all platforms. */ static void child_signal_read (int, void *); +#endif static void child_signal_notify (void); /* Indexed by descriptor, gives the process (if any) for that descriptor. */ @@ -7148,8 +7151,18 @@ process has been transmitted to the serial port. */) have the same process ID. To avoid a deadlock when receiving SIGCHLD while - `wait_reading_process_output' is in `pselect', the SIGCHLD handler - will notify the `pselect' using a pipe. */ + 'wait_reading_process_output' is in 'pselect', the SIGCHLD handler + will notify the `pselect' using a self-pipe. The deadlock could + occur if SIGCHLD is delivered outside of the 'pselect' call, in + which case 'pselect' will not be interrupted by the signal, and + will therefore wait on the process's output descriptor for the + output that will never come. + + WINDOWSNT doesn't need this facility because its 'pselect' + emulation (see 'sys_select' in w32proc.c) waits on a subprocess + handle, which becomes signaled when the process exits, and also + because that emulation delays the delivery of the simulated SIGCHLD + until all the output from the subprocess has been consumed. */ /* Set up `child_signal_read_fd' and `child_signal_write_fd'. */ @@ -7159,6 +7172,7 @@ child_signal_init (void) /* Either both are initialized, or both are uninitialized. */ eassert ((child_signal_read_fd < 0) == (child_signal_write_fd < 0)); +#ifndef WINDOWSNT if (0 <= child_signal_read_fd) return; /* already done */ @@ -7185,8 +7199,10 @@ child_signal_init (void) fd_callback_info[fds[0]].flags &= ~KEYBOARD_FD; child_signal_read_fd = fds[0]; child_signal_write_fd = fds[1]; +#endif /* !WINDOWSNT */ } +#ifndef WINDOWSNT /* Consume a process status change. */ static void @@ -7198,6 +7214,7 @@ child_signal_read (int fd, void *data) if (emacs_read (fd, &dummy, 1) < 0) emacs_perror ("reading from child signal FD"); } +#endif /* !WINDOWSNT */ /* Notify `wait_reading_process_output' of a process status change. */ @@ -7205,11 +7222,13 @@ child_signal_read (int fd, void *data) static void child_signal_notify (void) { +#ifndef WINDOWSNT int fd = child_signal_write_fd; eassert (0 <= fd); char dummy = 0; if (emacs_write (fd, &dummy, 1) != 1) emacs_perror ("writing to child signal FD"); +#endif } /* LIB_CHILD_HANDLER is a SIGCHLD handler that Emacs calls while doing From f0517ab9c2e140d306fea6285589a1c02dac5064 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sat, 23 Jan 2021 12:13:03 +0100 Subject: [PATCH 113/133] * test/infra/gitlab-ci.yml (.job-template): Check also for test/lib-src/*.el. --- test/infra/gitlab-ci.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index 2f71d12bdb3..5a0ab54e4b9 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -72,6 +72,7 @@ default: - lisp/**/*.el - src/*.{h,c} - test/infra/* + - test/lib-src/*.el - test/lisp/**/*.el - test/src/*.el - changes: From 6a6fde0375d499a418f81a0dafe803d6cb0d4c97 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sat, 23 Jan 2021 16:59:07 +0100 Subject: [PATCH 114/133] Fix failed autorevert test on emba * test/lisp/autorevert-tests.el (auto-revert-test05-global-notify): Check, whether buffer is alive. --- test/lisp/autorevert-tests.el | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el index 6da515bb2c8..683e3ea30d4 100644 --- a/test/lisp/autorevert-tests.el +++ b/test/lisp/autorevert-tests.el @@ -524,8 +524,10 @@ This expects `auto-revert--messages' to be bound by (auto-revert-test--write-file "1-b" file-1) (auto-revert-test--wait-for-buffer-text buf-1 "1-b" (auto-revert--timeout)) - (should (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-1)) + ;; On emba, `buf-1' is a killed buffer. + (when (buffer-live-p buf-1) + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-1))) ;; Write a buffer to a new file, then modify the new file on disk. (with-current-buffer buf-2 From aeff424c555da7e80775482db84eecef10286fc3 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Sat, 23 Jan 2021 17:24:34 +0100 Subject: [PATCH 115/133] Mark both ends of self-pipe a nonblocking. While no deadlocks caused by the blocking write end have been reported yet, marking both ends nonblocking is consistent and also recommended in the GNU/Linux manpage of 'select'. * src/process.c (child_signal_init): Mark write end of self-pipe as nonblocking. --- src/process.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/process.c b/src/process.c index 697d9b0b19b..9b1de19f0ae 100644 --- a/src/process.c +++ b/src/process.c @@ -7195,6 +7195,8 @@ child_signal_init (void) eassert (0 <= fds[1]); if (fcntl (fds[0], F_SETFL, O_NONBLOCK) != 0) emacs_perror ("fcntl"); + if (fcntl (fds[1], F_SETFL, O_NONBLOCK) != 0) + emacs_perror ("fcntl"); add_read_fd (fds[0], child_signal_read, NULL); fd_callback_info[fds[0]].flags &= ~KEYBOARD_FD; child_signal_read_fd = fds[0]; From 59e9ec72442d264a3e08c9886ad3b49fa8dc9f37 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Sat, 23 Jan 2021 18:39:20 +0100 Subject: [PATCH 116/133] Add a FIXME comment to improve the SIGCHLD race condition handling. * src/process.c: Add FIXME comment describing how we could avoid the self-pipe on modern Unix-like systems. --- src/process.c | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/process.c b/src/process.c index 9b1de19f0ae..8abdcd4f0c1 100644 --- a/src/process.c +++ b/src/process.c @@ -7164,6 +7164,11 @@ process has been transmitted to the serial port. */) because that emulation delays the delivery of the simulated SIGCHLD until all the output from the subprocess has been consumed. */ +/* FIXME: On Unix-like systems that have a proper 'pselect' + (HAVE_PSELECT), we should block SIGCHLD in + 'wait_reading_process_output' and pass a non-NULL signal mask to + 'pselect' to avoid the need for the self-pipe. */ + /* Set up `child_signal_read_fd' and `child_signal_write_fd'. */ static void From 27a023d02928366f52ab8d5e5c398ef080483523 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Sat, 23 Jan 2021 19:04:53 +0100 Subject: [PATCH 117/133] * .clang-format: Fix base style. --- .clang-format | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.clang-format b/.clang-format index 9ab09a86ff2..44200a39952 100644 --- a/.clang-format +++ b/.clang-format @@ -1,5 +1,5 @@ Language: Cpp -BasedOnStyle: LLVM +BasedOnStyle: GNU AlignEscapedNewlinesLeft: true AlwaysBreakAfterReturnType: TopLevelDefinitions BreakBeforeBinaryOperators: All From 17fec603709eb879297a4a0ff0c535c00a13066b Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Sat, 23 Jan 2021 19:08:52 +0100 Subject: [PATCH 118/133] Avoid a few compilation warnings in Objective-C code. * src/nsfns.m (Fns_frame_restack): Remove unused variable 'flag'. * src/nsmenu.m (ns_update_menubar): Remove unused variable 'pool'. * src/nsterm.m (focus_view, hide_bell): Define conditionally. (ns_update_end): Define variable 'view' conditionally. (ns_redraw_scroll_bars): Don't define unused function. (copyRect): Don't perform arithmetic on 'void' pointers. (nswindow_orderedIndex_sort): Make static. --- src/nsfns.m | 1 - src/nsmenu.m | 1 - src/nsterm.m | 31 +++++++++++++++++++++---------- 3 files changed, 21 insertions(+), 12 deletions(-) diff --git a/src/nsfns.m b/src/nsfns.m index ae114f83e4d..24ea7d7f63b 100644 --- a/src/nsfns.m +++ b/src/nsfns.m @@ -1487,7 +1487,6 @@ Frames are listed from topmost (first) to bottommost (last). */) { EmacsWindow *window = (EmacsWindow *)[FRAME_NS_VIEW (f1) window]; NSWindow *window2 = [FRAME_NS_VIEW (f2) window]; - BOOL flag = !NILP (above); if ([window restackWindow:window2 above:!NILP (above)]) return Qt; diff --git a/src/nsmenu.m b/src/nsmenu.m index 8086f56854e..f8219d27026 100644 --- a/src/nsmenu.m +++ b/src/nsmenu.m @@ -101,7 +101,6 @@ static void ns_update_menubar (struct frame *f, bool deep_p) { - NSAutoreleasePool *pool; BOOL needsSet = NO; id menu = [NSApp mainMenu]; bool owfi; diff --git a/src/nsterm.m b/src/nsterm.m index c5815ce8d10..df3934c5c34 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -272,7 +272,9 @@ - (NSColor *)colorUsingDefaultColorSpace /* display update */ static struct frame *ns_updating_frame; +#if !defined (NS_DRAW_TO_BUFFER) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400 static NSView *focus_view = NULL; +#endif static int ns_window_num = 0; static BOOL gsaved = NO; static BOOL ns_fake_keydown = NO; @@ -1139,7 +1141,9 @@ static NSRect constrain_frame_rect(NSRect frameRect, bool isFullscreen) external (RIF) call; for whole frame, called after gui_update_window_end -------------------------------------------------------------------------- */ { +#if !defined (NS_DRAW_TO_BUFFER) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400 EmacsView *view = FRAME_NS_VIEW (f); +#endif NSTRACE_WHEN (NSTRACE_GROUP_UPDATES, "ns_update_end"); @@ -1449,7 +1453,7 @@ -(void)remove } } - +#if !defined (NS_DRAW_TO_BUFFER) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400 static void hide_bell (void) /* -------------------------------------------------------------------------- @@ -1463,6 +1467,7 @@ -(void)remove [bell_view remove]; } } +#endif /* ========================================================================== @@ -2876,6 +2881,8 @@ so some key presses (TAB) are swallowed by the system. */ ========================================================================== */ +#if 0 +/* FIXME: Remove this function. */ static void ns_redraw_scroll_bars (struct frame *f) { @@ -2890,6 +2897,7 @@ so some key presses (TAB) are swallowed by the system. */ [view display]; } } +#endif void @@ -8399,21 +8407,23 @@ - (void)copyRect:(NSRect)srcRect to:(NSRect)dstRect void *pixels = CGBitmapContextGetData (context); int rowSize = CGBitmapContextGetBytesPerRow (context); int srcRowSize = NSWidth (srcRect) * scale * bpp; - void *srcPixels = pixels + (int)(NSMinY (srcRect) * scale * rowSize - + NSMinX (srcRect) * scale * bpp); - void *dstPixels = pixels + (int)(NSMinY (dstRect) * scale * rowSize - + NSMinX (dstRect) * scale * bpp); + void *srcPixels = (char *) pixels + + (int) (NSMinY (srcRect) * scale * rowSize + + NSMinX (srcRect) * scale * bpp); + void *dstPixels = (char *) pixels + + (int) (NSMinY (dstRect) * scale * rowSize + + NSMinX (dstRect) * scale * bpp); if (NSIntersectsRect (srcRect, dstRect) && NSMinY (srcRect) < NSMinY (dstRect)) for (int y = NSHeight (srcRect) * scale - 1 ; y >= 0 ; y--) - memmove (dstPixels + y * rowSize, - srcPixels + y * rowSize, + memmove ((char *) dstPixels + y * rowSize, + (char *) srcPixels + y * rowSize, srcRowSize); else for (int y = 0 ; y < NSHeight (srcRect) * scale ; y++) - memmove (dstPixels + y * rowSize, - srcPixels + y * rowSize, + memmove ((char *) dstPixels + y * rowSize, + (char *) srcPixels + y * rowSize, srcRowSize); #if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 @@ -8742,7 +8752,8 @@ - (void)makeKeyAndOrderFront:(id)sender /* The array returned by [NSWindow parentWindow] may already be sorted, but the documentation doesn't tell us whether or not it is, so to be safe we'll sort it. */ -NSInteger nswindow_orderedIndex_sort (id w1, id w2, void *c) +static NSInteger +nswindow_orderedIndex_sort (id w1, id w2, void *c) { NSInteger i1 = [w1 orderedIndex]; NSInteger i2 = [w2 orderedIndex]; From 8dcb19fc5e3afee7a951194a892f4731bee8ed31 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Sat, 23 Jan 2021 19:10:22 +0100 Subject: [PATCH 119/133] Add a unit test testing interaction between threads and processes. This unit test tests that we can call 'accept-process-output' in parallel from multiple threads. * test/src/process-tests.el (process-tests/multiple-threads-waiting): New unit test. --- test/src/process-tests.el | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/test/src/process-tests.el b/test/src/process-tests.el index 949f73595b4..676e1b1ac32 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el @@ -789,6 +789,35 @@ have written output." (should (equal calls (list (list process "finished\n")))))))))) +(ert-deftest process-tests/multiple-threads-waiting () + (skip-unless (fboundp 'make-thread)) + (with-timeout (60 (ert-fail "Test timed out")) + (process-tests--with-processes processes + (let ((threads ()) + (cat (executable-find "cat"))) + (skip-unless cat) + (dotimes (i 10) + (let* ((name (format "test %d" i)) + (process (make-process :name name + :command (list cat) + :coding 'no-conversion + :noquery t + :connection-type 'pipe))) + (push process processes) + (set-process-thread process nil) + (push (make-thread + (lambda () + (while (accept-process-output process))) + name) + threads))) + (mapc #'process-send-eof processes) + (cl-loop for process in processes + and thread in threads + do + (thread-join thread) + (should (eq (process-status process) 'exit)) + (should (eql (process-exit-status process) 0))))))) + (defun process-tests--eval (command form) "Return a command that evaluates FORM in an Emacs subprocess. COMMAND must be a list returned by From d860ca98ccb4ff9ff3b2348c3a7156ef010f2284 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 23 Jan 2021 21:04:13 +0200 Subject: [PATCH 120/133] ; * src/process.c (child_signal_read): Remove FIXME comment. --- src/process.c | 1 - 1 file changed, 1 deletion(-) diff --git a/src/process.c b/src/process.c index 8abdcd4f0c1..1df4ed9ce03 100644 --- a/src/process.c +++ b/src/process.c @@ -291,7 +291,6 @@ static int child_signal_read_fd = -1; static int child_signal_write_fd = -1; static void child_signal_init (void); #ifndef WINDOWSNT -/* FIXME: This is never used, on all platforms. */ static void child_signal_read (int, void *); #endif static void child_signal_notify (void); From 30d95d33737e4694b579c38328564716d10217b6 Mon Sep 17 00:00:00 2001 From: Gabriel do Nascimento Ribeiro Date: Sat, 23 Jan 2021 15:38:42 -0300 Subject: [PATCH 121/133] Use single post-command-hook on hl-line modes * lisp/hl-line.el (hl-line-mode, global-hl-line-mode): Ensure that 'maybe-unhighlight' is called after line is highlighted. (Bug#45946) (hl-line-unhighlight, global-hl-line-unhighlight): Set overlay variable to nil after overlay is deleted. --- lisp/hl-line.el | 58 +++++++++++++++++++++---------------------------- 1 file changed, 25 insertions(+), 33 deletions(-) diff --git a/lisp/hl-line.el b/lisp/hl-line.el index 73870f9579e..82952e934b6 100644 --- a/lisp/hl-line.el +++ b/lisp/hl-line.el @@ -45,11 +45,7 @@ ;; An overlay is used. In the non-sticky cases, this overlay is ;; active only on the selected window. A hook is added to ;; `post-command-hook' to activate the overlay and move it to the line -;; about point. To get the non-sticky behavior, `hl-line-unhighlight' -;; is added to `pre-command-hook' as well. This function deactivates -;; the overlay unconditionally in case the command changes the -;; selected window. (It does so rather than keeping track of changes -;; in the selected window). +;; about point. ;; You could make variable `global-hl-line-mode' buffer-local and set ;; it to nil to avoid highlighting specific buffers, when the global @@ -91,9 +87,9 @@ when `global-hl-line-sticky-flag' is non-nil.") (set symbol value) (dolist (buffer (buffer-list)) (with-current-buffer buffer - (when hl-line-overlay + (when (overlayp hl-line-overlay) (overlay-put hl-line-overlay 'face hl-line-face)))) - (when global-hl-line-overlay + (when (overlayp global-hl-line-overlay) (overlay-put global-hl-line-overlay 'face hl-line-face)))) (defcustom hl-line-sticky-flag t @@ -141,9 +137,7 @@ non-selected window. Hl-Line mode uses the function `hl-line-highlight' on `post-command-hook' in this case. When `hl-line-sticky-flag' is nil, Hl-Line mode highlights the -line about point in the selected window only. In this case, it -uses the function `hl-line-maybe-unhighlight' in -addition to `hl-line-highlight' on `post-command-hook'." +line about point in the selected window only." :group 'hl-line (if hl-line-mode (progn @@ -151,12 +145,10 @@ addition to `hl-line-highlight' on `post-command-hook'." (add-hook 'change-major-mode-hook #'hl-line-unhighlight nil t) (hl-line-highlight) (setq hl-line-overlay-buffer (current-buffer)) - (add-hook 'post-command-hook #'hl-line-highlight nil t) - (add-hook 'post-command-hook #'hl-line-maybe-unhighlight nil t)) + (add-hook 'post-command-hook #'hl-line-highlight nil t)) (remove-hook 'post-command-hook #'hl-line-highlight t) (hl-line-unhighlight) - (remove-hook 'change-major-mode-hook #'hl-line-unhighlight t) - (remove-hook 'post-command-hook #'hl-line-maybe-unhighlight t))) + (remove-hook 'change-major-mode-hook #'hl-line-unhighlight t))) (defun hl-line-make-overlay () (let ((ol (make-overlay (point) (point)))) @@ -168,17 +160,19 @@ addition to `hl-line-highlight' on `post-command-hook'." "Activate the Hl-Line overlay on the current line." (if hl-line-mode ; Might be changed outside the mode function. (progn - (unless hl-line-overlay + (unless (overlayp hl-line-overlay) (setq hl-line-overlay (hl-line-make-overlay))) ; To be moved. (overlay-put hl-line-overlay 'window (unless hl-line-sticky-flag (selected-window))) - (hl-line-move hl-line-overlay)) + (hl-line-move hl-line-overlay) + (hl-line-maybe-unhighlight)) (hl-line-unhighlight))) (defun hl-line-unhighlight () "Deactivate the Hl-Line overlay on the current line." - (when hl-line-overlay - (delete-overlay hl-line-overlay))) + (when (overlayp hl-line-overlay) + (delete-overlay hl-line-overlay) + (setq hl-line-overlay nil))) (defun hl-line-maybe-unhighlight () "Maybe deactivate the Hl-Line overlay on the current line. @@ -191,8 +185,7 @@ such overlays in all buffers except the current one." (not (eq curbuf hlob)) (not (minibufferp))) (with-current-buffer hlob - (when (overlayp hl-line-overlay) - (delete-overlay hl-line-overlay)))) + (hl-line-unhighlight))) (when (and (overlayp hl-line-overlay) (eq (overlay-buffer hl-line-overlay) curbuf)) (setq hl-line-overlay-buffer curbuf)))) @@ -205,8 +198,8 @@ If `global-hl-line-sticky-flag' is non-nil, Global Hl-Line mode highlights the line about the current buffer's point in all live windows. -Global-Hl-Line mode uses the functions `global-hl-line-highlight' -and `global-hl-line-maybe-unhighlight' on `post-command-hook'." +Global-Hl-Line mode uses the function `global-hl-line-highlight' +on `post-command-hook'." :global t :group 'hl-line (if global-hl-line-mode @@ -214,25 +207,24 @@ and `global-hl-line-maybe-unhighlight' on `post-command-hook'." ;; In case `kill-all-local-variables' is called. (add-hook 'change-major-mode-hook #'global-hl-line-unhighlight) (global-hl-line-highlight-all) - (add-hook 'post-command-hook #'global-hl-line-highlight) - (add-hook 'post-command-hook #'global-hl-line-maybe-unhighlight)) + (add-hook 'post-command-hook #'global-hl-line-highlight)) (global-hl-line-unhighlight-all) (remove-hook 'post-command-hook #'global-hl-line-highlight) - (remove-hook 'change-major-mode-hook #'global-hl-line-unhighlight) - (remove-hook 'post-command-hook #'global-hl-line-maybe-unhighlight))) + (remove-hook 'change-major-mode-hook #'global-hl-line-unhighlight))) (defun global-hl-line-highlight () "Highlight the current line in the current window." (when global-hl-line-mode ; Might be changed outside the mode function. (unless (window-minibuffer-p) - (unless global-hl-line-overlay + (unless (overlayp global-hl-line-overlay) (setq global-hl-line-overlay (hl-line-make-overlay))) ; To be moved. (unless (member global-hl-line-overlay global-hl-line-overlays) (push global-hl-line-overlay global-hl-line-overlays)) (overlay-put global-hl-line-overlay 'window (unless global-hl-line-sticky-flag (selected-window))) - (hl-line-move global-hl-line-overlay)))) + (hl-line-move global-hl-line-overlay) + (global-hl-line-maybe-unhighlight)))) (defun global-hl-line-highlight-all () "Highlight the current line in all live windows." @@ -243,8 +235,9 @@ and `global-hl-line-maybe-unhighlight' on `post-command-hook'." (defun global-hl-line-unhighlight () "Deactivate the Global-Hl-Line overlay on the current line." - (when global-hl-line-overlay - (delete-overlay global-hl-line-overlay))) + (when (overlayp global-hl-line-overlay) + (delete-overlay global-hl-line-overlay) + (setq global-hl-line-overlay nil))) (defun global-hl-line-maybe-unhighlight () "Maybe deactivate the Global-Hl-Line overlay on the current line. @@ -256,9 +249,8 @@ all such overlays in all buffers except the current one." (bufferp ovb) (not (eq ovb (current-buffer))) (not (minibufferp))) - (with-current-buffer ovb - (when (overlayp global-hl-line-overlay) - (delete-overlay global-hl-line-overlay)))))) + (with-current-buffer ovb + (global-hl-line-unhighlight))))) global-hl-line-overlays)) (defun global-hl-line-unhighlight-all () From 7c9841b8428edfbc369eccf54788b668d4b27328 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Sat, 23 Jan 2021 11:35:44 -0800 Subject: [PATCH 122/133] Update from Gnulib by running admin/merge-gnulib --- lib/cdefs.h | 6 ++++-- lib/explicit_bzero.c | 16 +++++++++++++--- 2 files changed, 17 insertions(+), 5 deletions(-) diff --git a/lib/cdefs.h b/lib/cdefs.h index de74f4211cf..17a0919cd83 100644 --- a/lib/cdefs.h +++ b/lib/cdefs.h @@ -320,14 +320,16 @@ #endif /* The nonnull function attribute marks pointer parameters that - must not be NULL. Do not define __nonnull if it is already defined, - for portability when this file is used in Gnulib. */ + must not be NULL. */ #ifndef __nonnull # if __GNUC_PREREQ (3,3) || __glibc_has_attribute (__nonnull__) # define __nonnull(params) __attribute__ ((__nonnull__ params)) # else # define __nonnull(params) # endif +#elif !defined __GLIBC__ +# undef __nonnull +# define __nonnull(params) _GL_ATTRIBUTE_NONNULL (params) #endif /* If fortification mode, we warn about unused results of certain diff --git a/lib/explicit_bzero.c b/lib/explicit_bzero.c index feea4446c06..f50ed0875d7 100644 --- a/lib/explicit_bzero.c +++ b/lib/explicit_bzero.c @@ -54,11 +54,21 @@ explicit_bzero (void *s, size_t len) explicit_memset (s, '\0', len); #elif HAVE_MEMSET_S (void) memset_s (s, len, '\0', len); -#else +#elif defined __GNUC__ && !defined __clang__ memset (s, '\0', len); -# if defined __GNUC__ && !defined __clang__ /* Compiler barrier. */ asm volatile ("" ::: "memory"); -# endif +#elif defined __clang__ + memset (s, '\0', len); + /* Compiler barrier. */ + /* With asm ("" ::: "memory") LLVM analyzes uses of 's' and finds that the + whole thing is dead and eliminates it. Use 'g' to work around this + problem. See . */ + __asm__ volatile ("" : : "g"(s) : "memory"); +#else + /* Invoke memset through a volatile function pointer. This defeats compiler + optimizations. */ + void * (* const volatile volatile_memset) (void *, int, size_t) = memset; + (void) volatile_memset (s, '\0', len); #endif } From 259edd435e0c02c3c906e8b34e7ece37724ccf11 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 23 Jan 2021 20:38:54 +0100 Subject: [PATCH 123/133] Add a mechanism for buffer-local thing-at-points * doc/lispref/text.texi (Buffer Contents): Document it. * lisp/thingatpt.el (thing-at-point-provider-alist): New variable. (thing-at-point): Use it. --- doc/lispref/text.texi | 19 +++++++++++++++++++ etc/NEWS | 6 ++++++ lisp/thingatpt.el | 35 ++++++++++++++++++++++++++++++++--- 3 files changed, 57 insertions(+), 3 deletions(-) diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index 35bc6f9f161..14854a5aafa 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -334,6 +334,25 @@ but there is no peace. (thing-at-point 'whitespace) @result{} nil @end example + +@defvar thing-at-point-provider-alist +This variable allows users and modes to tweak how +@code{thing-at-point} works. It's an association list of @var{thing}s +and functions (called with zero parameters) to return that thing. +Entries for @var{thing} will be evaluated in turn until a +non-@code{nil} result is returned. + +For instance, a major mode could say: + +@lisp +(setq-local thing-at-point-provider-alist + (append thing-at-point-provider-alist + '((url . my-mode--url-at-point)))) +@end lisp + +If no providers have a non-@code{nil} return, the @var{thing} will be +computed the standard way. +@end defvar @end defun @node Comparing Text diff --git a/etc/NEWS b/etc/NEWS index 357c75b7e96..6a80493e239 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1564,6 +1564,12 @@ that makes it a valid button. *** New macro `named-let` that provides Scheme's "named let" looping construct +** thingatpt + ++++ +*** New variable 'thing-at-point-provider-alist'. +This allows mode-specific alterations to how `thing-at-point' works. + ** Miscellaneous --- diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index 67d4092d407..c52fcfcc051 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -52,8 +52,30 @@ ;;; Code: +(require 'cl-lib) (provide 'thingatpt) +(defvar thing-at-point-provider-alist nil + "Alist of providers for returning a \"thing\" at point. +This variable can be set globally, or appended to buffer-locally +by modes, to provide functions that will return a \"thing\" at +point. The first provider for the \"thing\" that returns a +non-nil value wins. + +For instance, a major mode could say: + +\(setq-local thing-at-point-provider-alist + (append thing-at-point-provider-alist + \\='((url . my-mode--url-at-point)))) + +to provide a way to get an `url' at point in that mode. The +provider functions are called with no parameters at the point in +question. + +\"things\" include `symbol', `list', `sexp', `defun', `filename', +`url', `email', `uuid', `word', `sentence', `whitespace', `line', +and `page'.") + ;; Basic movement ;;;###autoload @@ -143,11 +165,18 @@ strip text properties from the return value. See the file `thingatpt.el' for documentation on how to define a symbol as a valid THING." (let ((text - (if (get thing 'thing-at-point) - (funcall (get thing 'thing-at-point)) + (cond + ((cl-loop for (pthing . function) in thing-at-point-provider-alist + when (eq pthing thing) + for result = (funcall function) + when result + return result)) + ((get thing 'thing-at-point) + (funcall (get thing 'thing-at-point))) + (t (let ((bounds (bounds-of-thing-at-point thing))) (when bounds - (buffer-substring (car bounds) (cdr bounds))))))) + (buffer-substring (car bounds) (cdr bounds)))))))) (when (and text no-properties (sequencep text)) (set-text-properties 0 (length text) nil text)) text)) From b7068be5c410c5592856aeebd7aa4d62b1dc68e5 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 23 Jan 2021 20:39:45 +0100 Subject: [PATCH 124/133] Provide a (thing-at-point 'url) in eww buffers * lisp/net/eww.el (eww-mode): Allow (thing-at-point 'url) to work in eww buffers. (eww--url-at-point): New function. --- lisp/net/eww.el | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/lisp/net/eww.el b/lisp/net/eww.el index d131b2bf8c9..e39a4c33b20 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -1050,9 +1050,16 @@ the like." ;; multi-page isearch support (setq-local multi-isearch-next-buffer-function #'eww-isearch-next-buffer) (setq truncate-lines t) + (setq-local thing-at-point-provider-alist + (append thing-at-point-provider-alist + '((url . eww--url-at-point)))) (buffer-disable-undo) (setq buffer-read-only t)) +(defun eww--url-at-point () + "`thing-at-point' provider function." + (get-text-property (point) 'shr-url)) + ;;;###autoload (defun eww-browse-url (url &optional new-window) "Ask the EWW browser to load URL. From 1559cc445a306b61b2a47c710e049ea26fe5265d Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 23 Jan 2021 16:04:36 -0500 Subject: [PATCH 125/133] Fix missing file&line info in "Unknown defun property" warnings * lisp/emacs-lisp/byte-run.el (defmacro, defun): Use `macroexp--warn-and-return` rather than `message`. * lisp/emacs-lisp/macroexp.el: Fix `macroexp--compiling-p`. (macroexp--warn-and-return): Don't try and detect repetition on forms like `nil`. (macroexp-macroexpand): Don't forget to bind `macroexpand-all-environment`. --- lisp/emacs-lisp/byte-run.el | 16 +++++++++++----- lisp/emacs-lisp/macroexp.el | 14 ++++++++------ 2 files changed, 19 insertions(+), 11 deletions(-) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 0f8dd5a2842..88f362d24f0 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -232,8 +232,11 @@ 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)) - (message "Warning: Unknown macro property %S in %S" - (car x) name)))) + (macroexp--warn-and-return + (format-message + "Unknown macro property %S in %S" + (car x) name) + nil)))) decls))) ;; Refresh font-lock if this is a new macro, or it is an ;; existing macro whose 'no-font-lock-keyword declaration @@ -301,9 +304,12 @@ The return value is undefined. (cdr body) body))) nil) - (t (message "Warning: Unknown defun property `%S' in %S" - (car x) name))))) - decls)) + (t + (macroexp--warn-and-return + (format-message "Unknown defun property `%S' in %S" + (car x) name) + nil))))) + decls)) (def (list 'defalias (list 'quote name) (list 'function diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 37844977f8f..aa49bccc8d0 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -127,7 +127,7 @@ and also to avoid outputting the warning during normal execution." (cond ((null msg) form) ((macroexp--compiling-p) - (if (gethash form macroexp--warned) + (if (and (consp form) (gethash form macroexp--warned)) ;; Already wrapped this exp with a warning: avoid inf-looping ;; where we keep adding the same warning onto `form' because ;; macroexpand-all gets right back to macroexpanding `form'. @@ -138,9 +138,10 @@ and also to avoid outputting the warning during normal execution." ,form))) (t (unless compile-only - (message "%s%s" (if (stringp load-file-name) - (concat (file-relative-name load-file-name) ": ") - "") + (message "%sWarning: %s" + (if (stringp load-file-name) + (concat (file-relative-name load-file-name) ": ") + "") msg)) form)))) @@ -180,8 +181,9 @@ and also to avoid outputting the warning during normal execution." (defun macroexp-macroexpand (form env) "Like `macroexpand' but checking obsolescence." - (let ((new-form - (macroexpand form env))) + (let* ((macroexpand-all-environment env) + (new-form + (macroexpand form env))) (if (and (not (eq form new-form)) ;It was a macro call. (car-safe form) (symbolp (car form)) From 75f6b264f549ee66faae75bfbad4d3f7602e2a64 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 23 Jan 2021 23:12:05 +0100 Subject: [PATCH 126/133] Make (subdirs . nil) in .dir-locals.el work * lisp/files.el (dir-locals-collect-variables): Don't destructively modify the cached structure (bug#17205), because that means that (subdirs . nil) doesn't work. --- lisp/files.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lisp/files.el b/lisp/files.el index d2e5413b3ad..7af5549bcb0 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -4062,7 +4062,7 @@ Return the new variables list." (subdirs (assq 'subdirs alist))) (if (or (not subdirs) (progn - (setq alist (delq subdirs alist)) + (setq alist (remq subdirs alist)) (cdr-safe subdirs)) ;; TODO someone might want to extend this to allow ;; integer values for subdir, where N means From 0ebf9d6cef211a3eddcf035aa8494d95ab7a2649 Mon Sep 17 00:00:00 2001 From: Eric Abrahamsen Date: Sat, 23 Jan 2021 14:24:09 -0800 Subject: [PATCH 127/133] Properly initialize gnus-search-namazu-index-directory * lisp/gnus/gnus-search.el (gnus-search-namazu): We were missing the appropriate :initform on this slot definition (Bug#46047). --- lisp/gnus/gnus-search.el | 1 + 1 file changed, 1 insertion(+) diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el index 5c6a5b9efd0..44780609af7 100644 --- a/lisp/gnus/gnus-search.el +++ b/lisp/gnus/gnus-search.el @@ -909,6 +909,7 @@ quirks.") (defclass gnus-search-namazu (gnus-search-indexed) ((index-directory :initarg :index-directory + :initform (symbol-value 'gnus-search-namazu-index-directory) :type string :custom directory) (program From 7cc970e7e3939672ec8ae490fff8300395e16b76 Mon Sep 17 00:00:00 2001 From: Jean Louis Date: Sun, 24 Jan 2021 00:34:44 +0100 Subject: [PATCH 128/133] Add support for dired compressing .lz/.lzo files * lisp/dired-aux.el (dired-compress-files-alist): Add support for .lz/.lzo files (bug#44901). --- lisp/dired-aux.el | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index f860743a066..c765e4be45d 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1168,6 +1168,8 @@ ARGS are command switches passed to PROGRAM.") ("\\.tar\\.bz2\\'" . "tar -cf - %i | bzip2 -c9 > %o") ("\\.tar\\.xz\\'" . "tar -cf - %i | xz -c9 > %o") ("\\.tar\\.zst\\'" . "tar -cf - %i | zstd -19 -o %o") + ("\\.tar\\.lz\\'" . "tar -cf - %i | lzip -c9 > %o") + ("\\.tar\\.lzo\\'" . "tar -cf - %i | lzop -c9 > %o") ("\\.zip\\'" . "zip %o -r --filesync %i") ("\\.pax\\'" . "pax -wf %o %i")) "Control the compression shell command for `dired-do-compress-to'. From e1902ac6182b156efaaf93013a707abb4b627765 Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Sat, 23 Jan 2021 23:31:13 +0000 Subject: [PATCH 129/133] Fix recently uncovered 'make check' failures For discussion, see the following thread: https://lists.gnu.org/r/emacs-devel/2021-01/msg01111.html * test/lisp/autorevert-tests.el (auto-revert-test07-auto-revert-several-buffers): * test/lisp/emacs-lisp/seq-tests.el (test-seq-do-indexed) (test-seq-random-elt-take-all): Fix errors from using add-to-list on lexical variables. * test/lisp/emacs-lisp/cl-lib-tests.el (cl-lib-defstruct-record): Expect test to succeed when byte-compiled following change of 2021-01-23 'Fix missing file&line info in "Unknown defun property" warnings'. (cl-lib-tests--dummy-function): Remove; no longer needed. (old-struct): Silence byte-compiler warning about unused lexical variable. --- test/lisp/autorevert-tests.el | 19 ++++++++++--------- test/lisp/emacs-lisp/cl-lib-tests.el | 9 +-------- test/lisp/emacs-lisp/seq-tests.el | 23 ++++++++++------------- 3 files changed, 21 insertions(+), 30 deletions(-) diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el index 683e3ea30d4..45cf6353960 100644 --- a/test/lisp/autorevert-tests.el +++ b/test/lisp/autorevert-tests.el @@ -609,11 +609,12 @@ This expects `auto-revert--messages' to be bound by (should auto-revert-mode)) (dotimes (i num-buffers) - (add-to-list - 'buffers - (make-indirect-buffer - (car buffers) (format "%s-%d" (buffer-file-name (car buffers)) i) 'clone) - 'append)) + (push (make-indirect-buffer + (car buffers) + (format "%s-%d" (buffer-file-name (car buffers)) i) + 'clone) + buffers)) + (setq buffers (nreverse buffers)) (dolist (buf buffers) (with-current-buffer buf (should (string-equal (buffer-string) "any text")) @@ -640,10 +641,10 @@ This expects `auto-revert--messages' to be bound by (auto-revert-tests--write-file "any text" tmpfile (pop times)) (dotimes (i num-buffers) - (add-to-list - 'buffers - (generate-new-buffer (format "%s-%d" (file-name-nondirectory tmpfile) i)) - 'append)) + (push (generate-new-buffer + (format "%s-%d" (file-name-nondirectory tmpfile) i)) + buffers)) + (setq buffers (nreverse buffers)) (dolist (buf buffers) (with-current-buffer buf (insert-file-contents tmpfile 'visit) diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index 97a44c43ef7..065ca4fa651 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -543,15 +543,7 @@ (apply (lambda (x) (+ x 1)) (list 8))))) '(5 (6 5) (6 6) 9)))) -(defun cl-lib-tests--dummy-function () - ;; Dummy function to see if the file is compiled. - t) - (ert-deftest cl-lib-defstruct-record () - ;; This test fails when compiled, see Bug#24402/27718. - :expected-result (if (byte-code-function-p - (symbol-function 'cl-lib-tests--dummy-function)) - :failed :passed) (cl-defstruct foo x) (let ((x (make-foo :x 42))) (should (recordp x)) @@ -566,6 +558,7 @@ (should (eq (type-of x) 'vector)) (cl-old-struct-compat-mode 1) + (defvar cl-struct-foo) (let ((cl-struct-foo (cl--struct-get-class 'foo))) (setf (symbol-function 'cl-struct-foo) :quick-object-witness-check) (should (eq (type-of x) 'foo)) diff --git a/test/lisp/emacs-lisp/seq-tests.el b/test/lisp/emacs-lisp/seq-tests.el index 670398354a6..05c7fbe781e 100644 --- a/test/lisp/emacs-lisp/seq-tests.el +++ b/test/lisp/emacs-lisp/seq-tests.el @@ -29,6 +29,9 @@ (require 'ert) (require 'seq) +(eval-when-compile + (require 'cl-lib)) + (defmacro with-test-sequences (spec &rest body) "Successively bind VAR to a list, vector, and string built from SEQ. Evaluate BODY for each created sequence. @@ -108,16 +111,12 @@ Evaluate BODY for each created sequence. '((a 0) (b 1) (c 2) (d 3))))) (ert-deftest test-seq-do-indexed () - (let ((result nil)) - (seq-do-indexed (lambda (elt i) - (add-to-list 'result (list elt i))) - nil) - (should (equal result nil))) + (let (result) + (seq-do-indexed (lambda (elt i) (push (list elt i) result)) ()) + (should-not result)) (with-test-sequences (seq '(4 5 6)) - (let ((result nil)) - (seq-do-indexed (lambda (elt i) - (add-to-list 'result (list elt i))) - seq) + (let (result) + (seq-do-indexed (lambda (elt i) (push (list elt i) result)) seq) (should (equal (seq-elt result 0) '(6 2))) (should (equal (seq-elt result 1) '(5 1))) (should (equal (seq-elt result 2) '(4 0)))))) @@ -410,12 +409,10 @@ Evaluate BODY for each created sequence. (ert-deftest test-seq-random-elt-take-all () (let ((seq '(a b c d e)) - (elts '())) - (should (= 0 (length elts))) + elts) (dotimes (_ 1000) (let ((random-elt (seq-random-elt seq))) - (add-to-list 'elts - random-elt))) + (cl-pushnew random-elt elts))) (should (= 5 (length elts))))) (ert-deftest test-seq-random-elt-signal-on-empty () From d4dd12d3589559e61cdce978c40e1eb86a871266 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Sun, 24 Jan 2021 13:56:18 +0100 Subject: [PATCH 130/133] Add more assertions to recently-added process test. * test/src/process-tests.el (process-tests/multiple-threads-waiting): Also check that 'thread-join' and 'thread-last-error' return the expected errors. --- test/src/process-tests.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/src/process-tests.el b/test/src/process-tests.el index 676e1b1ac32..a3fba8d328b 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el @@ -814,7 +814,8 @@ have written output." (cl-loop for process in processes and thread in threads do - (thread-join thread) + (should-not (thread-join thread)) + (should-not (thread-last-error)) (should (eq (process-status process) 'exit)) (should (eql (process-exit-status process) 0))))))) From b26e09e0f02b94d72bddfb108a16daffb74139f6 Mon Sep 17 00:00:00 2001 From: Eric Abrahamsen Date: Sun, 24 Jan 2021 10:09:05 -0800 Subject: [PATCH 131/133] Fix insertion logic of newly subscribed Gnus groups * lisp/gnus/gnus-start.el (gnus-subscribe-newsgroup): This was a misunderstanding of the next/previous argument: no group should ever be inserted before "dummy.group". (gnus-group-change-level): Make it clearer that PREVIOUS can be nil. In fact none of this code would error on a nil value, but it _looks_ like nil is unexpected. --- lisp/gnus/gnus-start.el | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index fbdbf41dc05..cf37a1ccdfc 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -637,7 +637,7 @@ the first newsgroup." ;; We subscribe the group by changing its level to `subscribed'. (gnus-group-change-level newsgroup gnus-level-default-subscribed - gnus-level-killed (or next "dummy.group")) + gnus-level-killed next) (gnus-request-update-group-status newsgroup 'subscribe) (gnus-message 5 "Subscribe newsgroup: %s" newsgroup) (run-hook-with-args 'gnus-subscribe-newsgroup-functions newsgroup) @@ -1282,7 +1282,8 @@ string name) to insert this group before." (gnus-dribble-enter (format "(gnus-group-change-level %S %S %S %S %S)" group level oldlevel - (cadr (member previous gnus-group-list)) + (when previous + (cadr (member previous gnus-group-list))) fromkilled))) ;; Then we remove the newgroup from any old structures, if needed. @@ -1341,9 +1342,10 @@ string name) to insert this group before." ;; at the head of `gnus-newsrc-alist'. (push info (cdr gnus-newsrc-alist)) (puthash group (list num info) gnus-newsrc-hashtb) - (when (stringp previous) + (when (and previous (stringp previous)) (setq previous (gnus-group-entry previous))) - (let ((idx (or (seq-position gnus-group-list (caadr previous)) + (let ((idx (or (and previous + (seq-position gnus-group-list (caadr previous))) (length gnus-group-list)))) (push group (nthcdr idx gnus-group-list))) (gnus-dribble-enter From 3cefda090304bbbce43d242072918ca855326842 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sun, 24 Jan 2021 19:26:02 +0100 Subject: [PATCH 132/133] Make Tramp's insert-directory more robust * lisp/net/tramp-sh.el (tramp-sh-handle-insert-directory): Use `tramp-sh--quoting-style-options'. * test/lisp/net/tramp-tests.el (tramp--test-hpux-p, tramp--test-ksh-p): Remove superfluous nil. (tramp--test-sh-no-ls--dired-p): New defun. (tramp--test-special-characters): Use it. --- lisp/net/tramp-sh.el | 7 ++---- test/lisp/net/tramp-tests.el | 46 +++++++++++++++++++++++------------- 2 files changed, 31 insertions(+), 22 deletions(-) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index d7ca7c9780c..ed3d15377c3 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -2617,11 +2617,8 @@ The method used must be an out-of-band method." filename switches wildcard full-directory-p) (when (stringp switches) (setq switches (split-string switches))) - (when (tramp-get-ls-command-with ;FIXME: tramp-sh--quoting-style-options? - v "--quoting-style=literal --show-control-chars") - (setq switches - (append - switches '("--quoting-style=literal" "--show-control-chars")))) + (setq switches + (append switches (split-string (tramp-sh--quoting-style-options v)))) (unless (tramp-get-ls-command-with v "--dired") (setq switches (delete "--dired" switches))) (when wildcard diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 4c84507807b..7757c55c16b 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -5720,16 +5720,16 @@ This requires restrictions of file name syntax." (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) 'tramp-ftp-file-name-handler)) +(defun tramp--test-crypt-p () + "Check, whether the remote directory is crypted" + (tramp-crypt-file-name-p tramp-test-temporary-file-directory)) + (defun tramp--test-docker-p () "Check, whether the docker method is used. This does not support some special file names." (string-equal "docker" (file-remote-p tramp-test-temporary-file-directory 'method))) -(defun tramp--test-crypt-p () - "Check, whether the remote directory is crypted" - (tramp-crypt-file-name-p tramp-test-temporary-file-directory)) - (defun tramp--test-ftp-p () "Check, whether an FTP-like method is used. This does not support globbing characters in file names (yet)." @@ -5748,7 +5748,7 @@ If optional METHOD is given, it is checked first." "Check, whether the remote host runs HP-UX. Several special characters do not work properly there." ;; We must refill the cache. `file-truename' does it. - (file-truename tramp-test-temporary-file-directory) nil + (file-truename tramp-test-temporary-file-directory) (string-match-p "^HP-UX" (tramp-get-connection-property tramp-test-vec "uname" ""))) @@ -5757,7 +5757,7 @@ Several special characters do not work properly there." ksh93 makes some strange conversions of non-latin characters into a $'' syntax." ;; We must refill the cache. `file-truename' does it. - (file-truename tramp-test-temporary-file-directory) nil + (file-truename tramp-test-temporary-file-directory) (string-match-p "ksh$" (tramp-get-connection-property tramp-test-vec "remote-shell" ""))) @@ -5787,6 +5787,15 @@ This does not support special file names." "Check, whether the remote host runs a based method from tramp-sh.el." (tramp-sh-file-name-handler-p tramp-test-vec)) +(defun tramp--test-sh-no-ls--dired-p () + "Check, whether the remote host runs a based method from tramp-sh.el. +Additionally, ls does not support \"--dired\"." + (and (tramp--test-sh-p) + (with-temp-buffer + ;; We must refill the cache. `insert-directory' does it. + (insert-directory tramp-test-temporary-file-directory "-al") + (not (tramp-get-connection-property tramp-test-vec "ls--dired" nil))))) + (defun tramp--test-share-p () "Check, whether the method needs a share." (and (tramp--test-gvfs-p) @@ -6023,17 +6032,20 @@ This requires restrictions of file name syntax." ;; expanded to . (let ((files (list - (if (or (tramp--test-ange-ftp-p) - (tramp--test-gvfs-p) - (tramp--test-rclone-p) - (tramp--test-sudoedit-p) - (tramp--test-windows-nt-or-smb-p)) - "foo bar baz" - (if (or (tramp--test-adb-p) - (tramp--test-docker-p) - (eq system-type 'cygwin)) - " foo bar baz " - " foo\tbar baz\t")) + (cond ((or (tramp--test-ange-ftp-p) + (tramp--test-gvfs-p) + (tramp--test-rclone-p) + (tramp--test-sudoedit-p) + (tramp--test-windows-nt-or-smb-p)) + "foo bar baz") + ((or (tramp--test-adb-p) + (tramp--test-docker-p) + (eq system-type 'cygwin)) + " foo bar baz ") + ((tramp--test-sh-no-ls--dired-p) + "\tfoo bar baz\t") + (t " foo\tbar baz\t")) + "@foo@bar@baz@" "$foo$bar$$baz$" "-foo-bar-baz-" "%foo%bar%baz%" From e5aaa1251cfb9d6d18682a5eda137a2e12ca4213 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 24 Jan 2021 20:53:36 +0100 Subject: [PATCH 133/133] Add some elisp-mode font lock tests --- test/lisp/progmodes/elisp-mode-tests.el | 51 +++++++++++++++++++++++++ 1 file changed, 51 insertions(+) diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el index fd43707f277..0da0e393535 100644 --- a/test/lisp/progmodes/elisp-mode-tests.el +++ b/test/lisp/progmodes/elisp-mode-tests.el @@ -834,5 +834,56 @@ to (xref-elisp-test-descr-to-target xref)." (indent-region (point-min) (point-max)) (should (equal (buffer-string) orig))))) +(defun test--font (form search) + (with-temp-buffer + (emacs-lisp-mode) + (if (stringp form) + (insert form) + (pp form (current-buffer))) + (font-lock-debug-fontify) + (goto-char (point-min)) + (and (re-search-forward search nil t) + (get-text-property (match-beginning 1) 'face)))) + +(ert-deftest test-elisp-font-keywords-1 () + ;; Special form. + (should (eq (test--font '(if foo bar) "(\\(if\\)") + 'font-lock-keyword-face)) + ;; Macro. + (should (eq (test--font '(when foo bar) "(\\(when\\)") + 'font-lock-keyword-face)) + (should (eq (test--font '(condition-case nil + (foo) + (error (if a b))) + "(\\(if\\)") + 'font-lock-keyword-face)) + (should (eq (test--font '(condition-case nil + (foo) + (when (if a b))) + "(\\(when\\)") + 'nil))) + +(ert-deftest test-elisp-font-keywords-2 () + :expected-result :failed ; FIXME bug#43265 + (should (eq (test--font '(condition-case nil + (foo) + (error (when a b))) + "(\\(when\\)") + 'font-lock-keyword-face))) + +(ert-deftest test-elisp-font-keywords-3 () + :expected-result :failed ; FIXME bug#43265 + (should (eq (test--font '(setq a '(if when zot)) + "(\\(if\\)") + nil))) + +(ert-deftest test-elisp-font-keywords-if () + :expected-result :failed ; FIXME bug#43265 + (should (eq (test--font '(condition-case nil + (foo) + ((if foo) (when a b))) + "(\\(if\\)") + nil))) + (provide 'elisp-mode-tests) ;;; elisp-mode-tests.el ends here